From hhubner at common-lisp.net  Fri Feb  1 10:22:15 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri,  1 Feb 2008 05:22:15 -0500 (EST)
Subject: [bknr-cvs] r2435 - branches/trunk-reorg/projects/quickhoney/src
Message-ID: <20080201102215.BFFA8310A3@common-lisp.net>

Author: hhubner
Date: Fri Feb  1 05:22:06 2008
New Revision: 2435

Modified:
   branches/trunk-reorg/projects/quickhoney/src/image.lisp
   branches/trunk-reorg/projects/quickhoney/src/init.lisp
Log:
Fix default external format, we're using UTF-8.
Display image in encoded content of RSS feed.


Modified: branches/trunk-reorg/projects/quickhoney/src/image.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/image.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/image.lisp	Fri Feb  1 05:22:06 2008
@@ -6,6 +6,13 @@
 	   :index-reader images-for-client
 	   :index-keys all-clients)))
 
+(defmethod rss-item-pub-date ((item quickhoney-image))
+  (blob-timestamp item))
+
+(defmethod rss-item-encoded-content ((item quickhoney-image))
+  (with-output-to-string (s)
+    (html-stream s ((:img :src (format nil "http://~A/image/~A" (header-in :host) (store-object-id item)))))))
+
 (defvar *last-image-upload-timestamp* 0)
 
 (defmethod initialize-transient-instance :after ((image quickhoney-image))

Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/init.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/init.lisp	Fri Feb  1 05:22:06 2008
@@ -8,6 +8,7 @@
 	    "/usr/lib/libssl.so"
 	    "/usr/local/lib/libgd.so"
 	    "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so"))
+  (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
   (when *store*
     (close-store))
   (make-instance 'store


From hhubner at common-lisp.net  Fri Feb  1 10:56:53 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri,  1 Feb 2008 05:56:53 -0500 (EST)
Subject: [bknr-cvs] r2436 - in branches/trunk-reorg: bknr/datastore/src
	projects/quickhoney/src
Message-ID: <20080201105653.B5C481B022@common-lisp.net>

Author: hhubner
Date: Fri Feb  1 05:56:52 2008
New Revision: 2436

Modified:
   branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd
   branches/trunk-reorg/projects/quickhoney/src/load.lisp
Log:
Quickhoney startup fixes.


Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd	(original)
+++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd	Fri Feb  1 05:56:52 2008
@@ -29,7 +29,7 @@
 					       (:file "class" :depends-on ("package" "utils"))
 					       #+(or cmu allegro openmcl sbcl)
 					       (:file "smbpasswd" :depends-on ("utils"))
-					       (:file "actor" :depends-on ("utils"))
+					       #-sbcl (:file "actor" :depends-on ("utils"))
 					       (:file "reader" :depends-on ("utils"))
 					       (:file "crypt-md5" :depends-on ("utils"))
 					       (:file "capability" :depends-on ("utils"))

Modified: branches/trunk-reorg/projects/quickhoney/src/load.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/load.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/load.lisp	Fri Feb  1 05:56:52 2008
@@ -3,6 +3,7 @@
 (asdf:oos 'asdf:load-op :quickhoney)
 (asdf:oos 'asdf:load-op :swank)
 
-(swank::create-swank-server 4085 :spawn #'swank::simple-announce-function t)
+(swank::create-server :port 4085)
 
+#+cmu
 (mp::startup-idle-and-top-level-loops)


From hhubner at common-lisp.net  Fri Feb  1 12:01:52 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri,  1 Feb 2008 07:01:52 -0500 (EST)
Subject: [bknr-cvs] r2437 - in
	branches/trunk-reorg/projects/quickhoney/website: static templates
Message-ID: <20080201120152.B613E50009@common-lisp.net>

Author: hhubner
Date: Fri Feb  1 07:01:51 2008
New Revision: 2437

Modified:
   branches/trunk-reorg/projects/quickhoney/website/static/javascript.js
   branches/trunk-reorg/projects/quickhoney/website/static/styles.css
   branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
Log:
Fix navigation - This was very simple, and I really regret that using
achors to store navigation information had not occured to me two years
ago.  One can now deep link into the Quickhoney site, a feature that is
used by the RSS feed.  Also, inner-site navigation updates the anchor now,
making it possible to store links to anything.


Modified: branches/trunk-reorg/projects/quickhoney/website/static/javascript.js
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/static/javascript.js	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/static/javascript.js	Fri Feb  1 07:01:51 2008
@@ -531,14 +531,14 @@
 
     if (current_directory) {
 	if (current_subdirectory) {
-	    path_links[0] = '<a href="#" onclick="show_page(' + "'" + current_directory + "'" + ');">' + current_directory + '</a>';
+	    path_links[0] = '<a href="#' + current_directory + '" onclick="show_page(' + "'" + current_directory + "'" + ');">' + current_directory + '</a>';
 	} else {
 	    path_links[0] = current_directory;
 	}
     }
     if (current_subdirectory) {
 	if (current_image) {
-	    path_links[1] = '<a href="#" onclick="subdirectory(' + "'" + current_subdirectory + "'" + ');">' + current_subdirectory + '</a>';
+	    path_links[1] = '<a href="#' + current_directory + "/" + current_subdirectory + '" onclick="subdirectory(' + "'" + current_subdirectory + "'" + ');">' + current_subdirectory + '</a>';
 	} else {
 	    path_links[1] = current_subdirectory;
 	}
@@ -646,6 +646,7 @@
 	} else {
 	    buttons[i].style.visibility = 'hidden';
 	    buttons[i].src = new_image;
+	    buttons[i].parentNode.href = '#' + current_directory + '/' + subdirectory_name;
 	    eval("button_links[i].onclick = function onclick(event) { subdirectory('" + subdirectory_name + "'); }");
 	}
     }
@@ -734,13 +735,16 @@
 
     if (query_result_pages.length > 1) {
 	if (current_page > 0) {
-	    push(result_links, '<a href="#" onclick="goto_page(' + (current_page - 1) + ');">&lt;&lt;</a>');
+	    push(result_links,
+		 '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page - 1) +
+		 '" onclick="goto_page(' + (current_page - 1) + ');">&lt;&lt;</a>');
 	} else {
 	    push(result_links, '&lt;&lt;');
 	}
 	var last_page = position_to_page(query_result.length - 1);
 	if (current_page < last_page) {
-	    push(result_links, '<a href="#" onclick="goto_page(' + (current_page + 1).toString() + ');">&gt;&gt;</a>');
+	    push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() +
+		 '" onclick="goto_page(' + (current_page + 1).toString() + ');">&gt;&gt;</a>');
 	} else {
 	    push(result_links, '&gt;&gt;');
 	}
@@ -764,7 +768,8 @@
 	    if (page_number == current_page) {
 		push(result_links, (page_number + 1).toString());
 	    } else {
-		push(result_links, '<a href="#" onclick="goto_page(' + page_number + ');">' + (page_number + 1) + '</a>');
+		push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() +
+		     '" onclick="goto_page(' + page_number + ');">' + (page_number + 1) + '</a>');
 	    }
 	}
 
@@ -795,7 +800,9 @@
 	for (var image_index = 2; image_index < row.length; image_index++) {
 	    var image = row[image_index];
 	    thumbnail_html
-		+= '<a href="#" onclick="display_image(' + "'" + image.position + "'" + ');">'
+		+= '<a href="#'
+		+ current_directory + '/' + current_subdirectory + '/' + image.name
+		+ '" onclick="display_image(' + "'" + image.position + "'" + ');">'
 		+ '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" '
 		+ ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + ',8" '
 		+ ' onload="reveal_image(this);" />'
@@ -813,15 +820,20 @@
     var result_links = [];
 
     if (query_position > 0) {
-	push(result_links, '<a href="#" onclick="display_image(' + (query_position - 1) + ');">&lt;&lt;</a>');
+	push(result_links, '<a href="#'
+	     + current_directory + '/' + current_subdirectory + '/' + query_result[query_position - 1].name
+	     + '" onclick="display_image(' + (query_position - 1) + ');">&lt;&lt;</a>');
     } else {
 	push(result_links, '&lt;&lt;');
     }
     if (query_position < (query_result.length - 1)) {
-	push(result_links, '<a href="#" onclick="display_image(' + (query_position + 1) + ');">&gt;&gt;</a>');
+	push(result_links, '<a href="#'
+	     + current_directory + '/' + current_subdirectory + '/' + query_result[query_position + 1].name
+	     + '" onclick="display_image(' + (query_position + 1) + ');">&gt;&gt;</a>');
     } else {
 	push(result_links, '&gt;&gt;');
     }
+    document.getElementById('back_to_results_link').href = '#' + current_directory + '/' + current_subdirectory + '/' + position_to_page(query_position);
 
     document.getElementById("image_navbar").innerHTML = result_links.join(" ");
     document.getElementById("result_image_count").innerHTML = "result " + (query_position + 1) + " of " + query_result.length;
@@ -1012,37 +1024,35 @@
 }
 
 function init() {
-    if (document.location.href.indexOf("#debug") != -1) {
-	want_debugger = true;
+    var path = (document.location.href + "#").split("#")[1];
+
+    if (path) {
+	if (path == "debug") {
+
+	    want_debugger = true;
 	
-	document.getElementById("debugger").style.visibility = 'visible';
-	document.getElementById("debugger").style.left = '730px';
-	document.getElementById("debugger").style.width = '400px';
-	document.getElementById("debugger").style.heigth = '640px';
-    } else {
-	document.getElementById("debugger").style.left = "1px";
-	document.getElementById("debugger").style.right = "1px";
-	document.getElementById("debugger").style.width = "1px";
-	document.getElementById("debugger").style.height = "1px";
-    }
+	    document.getElementById("debugger").style.visibility = 'visible';
+	    document.getElementById("debugger").style.left = '730px';
+	    document.getElementById("debugger").style.width = '400px';
+	    document.getElementById("debugger").style.heigth = '640px';
 
-    debug('init - path is ', document.location.href);
+	} else if (path == "update") {
 
-    if (document.location.href.indexOf("#update") != -1) {
-	if ((navigator.platform == "MacPPC") && (navigator.userAgent.indexOf("MSIE 5.") != -1)) {
-	    alert("CMS functionality not supported on IE5/Mac");
+	    if ((navigator.platform == "MacPPC") && (navigator.userAgent.indexOf("MSIE 5.") != -1)) {
+		alert("CMS functionality not supported on IE5/Mac");
+	    } else {
+		wants_cms = true;
+		document.getElementById("login_form").style.visibility = 'visible';
+	    }
+	    show_cms_window("login_form");
 	} else {
-	    wants_cms = true;
-	    document.getElementById("login_form").style.visibility = 'visible';
+	    var jump_to = path;
+	    jump_to = jump_to.replace(/[&#].*/, "");
+	    document.jump_to = jump_to;
 	}
-	show_cms_window("login_form");
     }
 
-    if (document.location.href.indexOf("jumpto=") != -1) {
-	var jump_to = document.location.href.replace(/.*jumpto=/, "");
-	jump_to = jump_to.replace(/[&#].*/, "");
-	document.jump_to = jump_to;
-    }
+    debug('init - path is ', path);
 
     buttons = document.getElementById("directory").getElementsByTagName('img');
     button_links = document.getElementById("directory").getElementsByTagName('a');

Modified: branches/trunk-reorg/projects/quickhoney/website/static/styles.css
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/static/styles.css	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/static/styles.css	Fri Feb  1 07:01:51 2008
@@ -69,10 +69,10 @@
 #debugger {
 	visibility: hidden;
 	position: absolute;
-	left: 0px;
-	top: 36px;
-	width: 0px;
-	height: 0px;
+	left: 1px;
+	top: 1px;
+	width: 1px;
+	height: 1px;
 }
 
 .debugger {

Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	Fri Feb  1 07:01:51 2008
@@ -15,22 +15,22 @@
 
 	<body id="quickhoney">
 
-		<a onclick="show_page('quickhoney')" href="#">
+		<a onclick="show_page('quickhoney')" href="#quickhoney">
 			<img alt="quickhoney" class="menu" id="m_quickhoney" src="/image/quickhoney" />
 		</a>
-		<a onclick="show_page('pixel')" href="#">
+		<a onclick="show_page('pixel')" href="#pixel">
 			<img alt="pixel" class="menu" id="m_pixel" src="/image/pixel" />
 		</a>
-		<a onclick="show_page('vector')" href="#">
+		<a onclick="show_page('vector')" href="#vector">
 			<img alt="vector" class="menu" id="m_vector" src="/image/vector" />
 		</a>
-		<a onclick="show_page('photo')" href="#">
+		<a onclick="show_page('photo')" href="#photo">
 			<img alt="photo" class="menu" id="m_photo" src="/image/photo" />
 		</a>
-		<a onclick="show_page('clients')" href="#">
+		<a onclick="show_page('clients')" href="#clients">
 			<img alt="clients" class="menu" id="m_clients" src="/image/clients" />
 		</a>
-		<a onclick="show_page('contact')" href="#">
+		<a onclick="show_page('contact')" href="#contact">
 			<img alt="contact" class="menu" id="m_contact" src="/image/contact" />
 		</a>
 
@@ -81,7 +81,7 @@
 				</span>
 	
 				<span id="results_navbar" class="text">
-					<span id="back_to_results"><a onclick="back_to_results()" href="#">back to results</a></span>
+					<span id="back_to_results"><a id="back_to_results_link" onclick="back_to_results()" href="#">back to results</a></span>
 					<span id="result_image_count"> <!-- may not be empty -->
 					</span>
 				</span>
@@ -95,7 +95,7 @@
 			</div>
 	
 			<div id="clients">
-				<a href="#" onclick="return nice_jobs();">
+				<a href="#clients/nicejobs" onclick="return nice_jobs();">
 					<img id="jobs-banner" src="/random-image/button/jobs" border="0" />
 				</a>
 				<img id="clients-type" src="/image/type-niceclients" />


From hhubner at common-lisp.net  Sat Feb  2 22:54:17 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat,  2 Feb 2008 17:54:17 -0500 (EST)
Subject: [bknr-cvs] r2438 - in branches/trunk-reorg: bknr/datastore/src
	bknr/datastore/src/utils bknr/datastore/src/xml-impex
	bknr/web/src bknr/web/src/web projects/bos/worldpay-test
	projects/eboy/src projects/gpn projects/lisp-ecoop/src
	projects/quickhoney/src projects/quickhoney/website/templates
	projects/saugnapf/src thirdparty/cl+ssl
Message-ID: <20080202225417.9E690461E3@common-lisp.net>

Author: hhubner
Date: Sat Feb  2 17:54:13 2008
New Revision: 2438

Added:
   branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
      - copied, changed from r2434, branches/trunk-reorg/bknr/web/src/web/templates.lisp
Removed:
   branches/trunk-reorg/bknr/web/src/web/templates.lisp
Modified:
   branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd
   branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
   branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp
   branches/trunk-reorg/bknr/web/src/bknr-web.asd
   branches/trunk-reorg/bknr/web/src/packages.lisp
   branches/trunk-reorg/bknr/web/src/web/tags.lisp
   branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp
   branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp
   branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp
   branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp
   branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp
   branches/trunk-reorg/projects/eboy/src/item-handlers.lisp
   branches/trunk-reorg/projects/gpn/gpn-tags.lisp
   branches/trunk-reorg/projects/gpn/import-handler.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd
   branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
   branches/trunk-reorg/projects/quickhoney/src/tags.lisp
   branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
   branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml
   branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
   branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp
   branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp
   branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp
Log:
Fix templater to work with current CXML.
Began porting lisp-ecoop over to the new framework.


Modified: branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd	(original)
+++ branches/trunk-reorg/bknr/datastore/src/bknr-utils.asd	Sat Feb  2 17:54:13 2008
@@ -35,5 +35,6 @@
 					       (:file "capability" :depends-on ("utils"))
 					       (:file "make-fdf-file" :depends-on ("utils"))
 					       (:file "date-calc")
+					       (:file "parse-time")
 					       (:file "acl-mp-compat" :depends-on ("package"))))))
 

Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	Sat Feb  2 17:54:13 2008
@@ -30,6 +30,7 @@
 	   #:month-num-days
 
 	   #:hostname
+           #:parse-time
 
 	   ;; filesystem functions
 	   #:copy-stream

Added: branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/bknr/datastore/src/utils/parse-time.lisp	Sat Feb  2 17:54:13 2008
@@ -0,0 +1,635 @@
+(in-package :bknr.utils)
+
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;; It was subsequently borrowed and modified slightly by Daniel
+;;; Barlow <dan at telent.net> to become part of the net-telent-date
+;;; package.  Daniel, Tue May 22 05:45:27 BST 2001
+
+;;; **********************************************************************
+
+;;; Parsing routines for time and date strings. PARSE-TIME returns the
+;;; universal time integer for the time and/or date given in the string.
+
+;;; Written by Jim Healy, June 1987.
+
+;;; **********************************************************************
+
+(defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
+(defvar time-dividers '(#\: #\.))
+(defvar date-dividers '(#\\ #\/ #\-))
+
+(defvar *error-on-mismatch* nil
+  "If t, an error will be signalled if parse-time is unable
+   to determine the time/date format of the string.")
+
+;;; Set up hash tables for month, weekday, zone, and special strings.
+;;; Provides quick, easy access to associated information for these items.
+
+;;; Hashlist takes an association list and hashes each pair into the
+;;; specified tables using the car of the pair as the key and the cdr as
+;;; the data object.
+
+(defmacro hashlist (list table)
+  `(dolist (item ,list)
+     (setf (gethash (car item) ,table) (cdr item))))
+
+(defparameter weekday-table-size 23)
+(defparameter month-table-size 31)
+(defparameter zone-table-size 11)
+(defparameter special-table-size 11)
+
+(defvar *weekday-strings* (make-hash-table :test #'equal
+					 :size weekday-table-size))
+
+(defvar *month-strings* (make-hash-table :test #'equal
+				       :size month-table-size))
+
+(defvar *zone-strings* (make-hash-table :test #'equal
+				      :size zone-table-size))
+
+(defvar *special-strings* (make-hash-table :test #'equal
+					 :size special-table-size))
+

+;;; Load-time creation of the hash tables.
+
+(hashlist '(("monday" . 0)    ("mon" . 0)
+	    ("tuesday" . 1)   ("tues" . 1)   ("tue" . 1)
+	    ("wednesday" . 2) ("wednes" . 2) ("wed" . 2)
+	    ("thursday" . 3)  ("thurs" . 3)  ("thu" . 3)
+	    ("friday" . 4)    ("fri" . 4)
+	    ("saturday" . 5)  ("sat" . 5)
+	    ("sunday" . 6)    ("sun" . 6))
+	  *weekday-strings*)
+
+(hashlist '(("january" . 1)   ("jan" . 1)
+	    ("february" . 2)  ("feb" . 2)
+	    ("march" . 3)     ("mar" . 3)
+	    ("april" . 4)     ("apr" . 4)
+	    ("may" . 5)       ("june" . 6)
+	    ("jun" . 6)       ("july" . 7)
+	    ("jul" . 7)	      ("august" . 8)
+	    ("aug" . 8)       ("september" . 9)
+	    ("sept" . 9)      ("sep" . 9)
+	    ("october" . 10)  ("oct" . 10)
+	    ("november" . 11) ("nov" . 11)
+	    ("december" . 12) ("dec" . 12))
+	  *month-strings*)
+
+(hashlist '(("gmt" . 0) ("est" . 5)
+	    ("edt" . 4) ("cst" . 6)
+	    ("cdt" . 5) ("mst" . 7)
+	    ("mdt" . 6)	("pst" . 8)
+	    ("pdt" . 7)) 
+	  *zone-strings*)
+
+(hashlist '(("yesterday" . yesterday)  ("today" . today)
+	    ("tomorrow" . tomorrow)   ("now" . now))
+	  *special-strings*)
+

+;;; Time/date format patterns are specified as lists of symbols repre-
+;;; senting the elements.  Optional elements can be specified by
+;;; enclosing them in parentheses.  Note that the order in which the
+;;; patterns are specified below determines the order of search.
+
+;;; Choices of pattern symbols are: second, minute, hour, day, month,
+;;; year, time-divider, date-divider, am-pm, zone, izone, weekday,
+;;; noon-midn, and any special symbol.
+
+(defparameter *default-date-time-patterns*
+  '( 
+     ;; Date formats.
+    ((weekday) month (date-divider) day (date-divider) year (noon-midn))
+    ((weekday) day (date-divider) month (date-divider) year (noon-midn))
+    ((weekday) month (date-divider) day (noon-midn))
+    (year (date-divider) month (date-divider) day (noon-midn))
+    (month (date-divider) year (noon-midn))
+    (year (date-divider) month (noon-midn))
+
+    ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
+    ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
+    ((noon-midn) (weekday) month (date-divider) day)
+    ((noon-midn) year (date-divider) month (date-divider) day)
+    ((noon-midn) month (date-divider) year)
+    ((noon-midn) year (date-divider) month)
+
+     ;; Time formats.
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) 
+	  (date-divider) (zone))
+    (noon-midn)
+    (hour (noon-midn))
+
+     ;; Time/date combined formats.
+    ((weekday) month (date-divider) day (date-divider) year
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    ((weekday) day (date-divider) month (date-divider) year
+	 hour (time-divider) (minute) (time-divider) (secondp)
+	 (am-pm) (date-divider) (zone))
+    ((weekday) month (date-divider) day
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    (year (date-divider) month (date-divider) day
+	  hour (time-divider) (minute) (time-divider) (secondp)
+	  (am-pm) (date-divider) (zone))
+    (month (date-divider) year
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    (year (date-divider) month
+	  hour (time-divider) (minute) (time-divider) (secondp)
+	  (am-pm) (date-divider) (zone))
+
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) month (date-divider)
+	  day (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) day (date-divider)
+	  month (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) month (date-divider)
+	  day)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) year (date-divider) month
+	  (date-divider) day)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) month (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) year (date-divider) month)
+
+     ;; Weird, non-standard formats.
+    (weekday month day hour (time-divider) minute (time-divider)
+	     secondp (am-pm)
+	     (zone) year)
+    ((weekday) day (date-divider) month (date-divider) year hour
+     (time-divider) minute (time-divider) (secondp) (am-pm)
+     (date-divider) (zone))
+    ((weekday) month (date-divider) day (date-divider) year hour
+     (time-divider) minute (time-divider) (secondp) (am-pm)
+     (date-divider) (zone))
+
+    ;; Special-string formats.
+    (now (yesterday))
+    ((yesterday) now)
+    (now (today))
+    ((today) now)
+    (now (tomorrow))
+    ((tomorrow) now)
+    (yesterday (noon-midn))
+    ((noon-midn) yesterday)
+    (today (noon-midn))
+    ((noon-midn) today)
+    (tomorrow (noon-midn))
+    ((noon-midn) tomorrow)
+))
+
+;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C.
+(defparameter *http-date-time-patterns*
+  '( 
+     ;; RFC1123/RFC822 and RFC850.
+    ((weekday) day (date-divider) month (date-divider) year
+     hour time-divider minute (time-divider) (secondp) izone)
+    ((weekday) day (date-divider) month (date-divider) year
+     hour time-divider minute (time-divider) (secondp) (zone))
+
+     ;; ANSI-C.
+    ((weekday) month day
+     hour time-divider minute (time-divider) (secondp) year)))
+
+

+;;; The decoded-time structure holds the time/date values which are
+;;; eventually passed to 'encode-universal-time' after parsing.
+
+;;; Note: Currently nothing is done with the day of the week.  It might
+;;; be appropriate to add a function to see if it matches the date.
+
+(defstruct decoded-time
+  (second 0    :type integer)    ; Value between 0 and 59.
+  (minute 0    :type integer)    ; Value between 0 and 59.
+  (hour   0    :type integer)    ; Value between 0 and 23.
+  (day    1    :type integer)    ; Value between 1 and 31.
+  (month  1    :type integer)    ; Value between 1 and 12.
+  (year   1900 :type integer)    ; Value above 1899 or between 0 and 99.
+  (zone   0    :type rational)   ; Value between -24 and 24 inclusive.
+  (dotw   0    :type integer))   ; Value between 0 and 6.
+
+;;; Make-default-time returns a decoded-time structure with the default
+;;; time values already set.  The default time is currently 00:00 on
+;;; the current day, current month, current year, and current time-zone.
+
+(defun make-default-time (def-sec def-min def-hour def-day
+			   def-mon def-year def-zone def-dotw)
+  (let ((default-time (make-decoded-time)))
+    (multiple-value-bind (sec min hour day mon year dotw dst zone)
+			 (get-decoded-time)
+      (declare (ignore dst))
+      (if def-sec
+	  (if (eq def-sec :current)
+	      (setf (decoded-time-second default-time) sec)
+	      (setf (decoded-time-second default-time) def-sec))
+	  (setf (decoded-time-second default-time) 0))
+      (if def-min
+	  (if (eq def-min :current)
+	      (setf (decoded-time-minute default-time) min)
+	      (setf (decoded-time-minute default-time) def-min))
+	  (setf (decoded-time-minute default-time) 0))
+      (if def-hour
+	  (if (eq def-hour :current)
+	      (setf (decoded-time-hour default-time) hour)
+	      (setf (decoded-time-hour default-time) def-hour))
+	  (setf (decoded-time-hour default-time) 0))
+      (if def-day
+	  (if (eq def-day :current)
+	      (setf (decoded-time-day default-time) day)
+	      (setf (decoded-time-day default-time) def-day))
+	  (setf (decoded-time-day default-time) day))
+      (if def-mon
+	  (if (eq def-mon :current)
+	      (setf (decoded-time-month default-time) mon)
+	      (setf (decoded-time-month default-time) def-mon))
+	  (setf (decoded-time-month default-time) mon))
+      (if def-year
+	  (if (eq def-year :current)
+	      (setf (decoded-time-year default-time) year)
+	      (setf (decoded-time-year default-time) def-year))
+	  (setf (decoded-time-year default-time) year))
+      (if def-zone
+	  (if (eq def-zone :current)
+	      (setf (decoded-time-zone default-time) zone)
+	      (setf (decoded-time-zone default-time) def-zone))
+	  (setf (decoded-time-zone default-time) zone))
+      (if def-dotw
+	  (if (eq def-dotw :current)
+	      (setf (decoded-time-dotw default-time) dotw)
+	      (setf (decoded-time-dotw default-time) def-dotw))
+	  (setf (decoded-time-dotw default-time) dotw))
+      default-time)))
+
+;;; Converts the values in the decoded-time structure to universal time
+;;; by calling encode-universal-time.
+;;; If zone is in numerical form, tweeks it appropriately.
+
+(defun convert-to-unitime (parsed-values)
+  (let ((zone (decoded-time-zone parsed-values)))
+    (encode-universal-time (decoded-time-second parsed-values)
+			   (decoded-time-minute parsed-values)
+			   (decoded-time-hour parsed-values)
+			   (decoded-time-day parsed-values)
+			   (decoded-time-month parsed-values)
+			   (decoded-time-year parsed-values)
+			   (if (or (> zone 24) (< zone -24))
+			       (let ((new-zone (/ zone 100)))
+				 (cond ((minusp new-zone) (- new-zone))
+				       ((plusp new-zone) (- 24 new-zone))
+				       ;; must be zero (GMT)
+				       (t new-zone)))
+			       zone))))
+
+;;; Sets the current values for the time and/or date parts of the 
+;;; decoded time structure.
+
+(defun set-current-value (values-structure &key (time nil) (date nil)
+						(zone nil))
+  (multiple-value-bind (sec min hour day mon year dotw dst tz)
+      (get-decoded-time)
+    (declare (ignore dst))
+    (when time
+      (setf (decoded-time-second values-structure) sec)
+      (setf (decoded-time-minute values-structure) min)
+      (setf (decoded-time-hour values-structure) hour))
+    (when date
+      (setf (decoded-time-day values-structure) day)
+      (setf (decoded-time-month values-structure) mon)
+      (setf (decoded-time-year values-structure) year)
+      (setf (decoded-time-dotw values-structure) dotw))
+    (when zone
+      (setf (decoded-time-zone values-structure) tz))))
+

+;;; Special function definitions.  To define a special substring, add
+;;; a dotted pair consisting of the substring and a symbol in the
+;;; *special-strings* hashlist statement above.  Then define a function
+;;; here which takes one argument- the decoded time structure- and
+;;; sets the values of the structure to whatever is necessary.  Also,
+;;; add a some patterns to the patterns list using whatever combinations
+;;; of special and pre-existing symbols desired.
+
+(defun yesterday (parsed-values)
+  (set-current-value parsed-values :date t :zone t)
+  (setf (decoded-time-day parsed-values)
+	(1- (decoded-time-day parsed-values))))
+
+(defun today (parsed-values)
+  (set-current-value parsed-values :date t :zone t))
+
+(defun tomorrow (parsed-values)
+  (set-current-value parsed-values :date t :zone t)
+  (setf (decoded-time-day parsed-values)
+	(1+ (decoded-time-day parsed-values))))
+
+(defun now (parsed-values)
+  (set-current-value parsed-values :time t))
+

+;;; Predicates for symbols.  Each symbol has a corresponding function
+;;; defined here which is applied to a part of the datum to see if
+;;; it matches the qualifications.
+
+(defun am-pm (string)
+  (and (simple-string-p string)
+       (cond ((string= string "am") 'am)
+	     ((string= string "pm") 'pm)
+	     (t nil))))
+
+(defun noon-midn (string)
+  (and (simple-string-p string)
+       (cond ((string= string "noon") 'noon)
+	     ((string= string "midnight") 'midn)
+	     (t nil))))
+
+(defun weekday (string)
+  (and (simple-string-p string) (gethash string *weekday-strings*)))
+
+(defun month (thing)
+  (or (and (simple-string-p thing) (gethash thing *month-strings*))
+      (and (integerp thing) (<= 1 thing 12))))
+
+(defun zone (thing)
+  (or (and (simple-string-p thing) (gethash thing *zone-strings*))
+      (if (integerp thing)
+	  (let ((zone (/ thing 100)))
+	    (and (integerp zone) (<= -24 zone 24))))))
+
+;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
+(defun izone (thing)
+  (if (integerp thing)
+      (multiple-value-bind (hours mins)
+	  (truncate thing 100)
+	(and (<= -24 hours 24) (<= -59 mins 59)))))
+
+(defun special-string-p (string)
+  (and (simple-string-p string) (gethash string *special-strings*)))
+
+(defun secondp (number)
+  (and (integerp number) (<= 0 number 59)))
+
+(defun minute (number)
+  (and (integerp number) (<= 0 number 59)))
+
+(defun hour (number)
+  (and (integerp number) (<= 0 number 23)))
+
+(defun day (number)
+  (and (integerp number) (<= 1 number 31)))
+
+(defun year (number)
+  (and (integerp number)
+       (or (<= 0 number 99)
+	   (<= 1900 number))))
+
+(defun time-divider (character)
+  (and (characterp character)
+       (member character time-dividers :test #'char=)))
+
+(defun date-divider (character)
+  (and (characterp character)
+       (member character date-dividers :test #'char=)))
+

+;;; Match-substring takes a string argument and tries to match it with
+;;; the strings in one of the four hash tables: *weekday-strings*, *month-
+;;; strings*, *zone-strings*, *special-strings*.  It returns a specific
+;;; keyword and/or the object it finds in the hash table.  If no match
+;;; is made then it immediately signals an error.
+
+(defun match-substring (substring)
+  (let ((substring (nstring-downcase substring)))
+    (or (let ((test-value (month substring)))
+	  (if test-value (cons 'month test-value)))
+	(let ((test-value (weekday substring)))
+	  (if test-value (cons 'weekday test-value)))
+	(let ((test-value (am-pm substring)))
+	  (if test-value (cons 'am-pm test-value)))
+	(let ((test-value (noon-midn substring)))
+	  (if test-value (cons 'noon-midn test-value)))
+	(let ((test-value (zone substring)))
+	  (if test-value (cons 'zone test-value)))
+	(let ((test-value (special-string-p substring)))
+	  (if test-value  (cons 'special test-value)))
+	(if *error-on-mismatch*
+	    (error "\"~A\" is not a recognized word or abbreviation."
+		   substring)
+	    (return-from match-substring nil)))))
+

+;;; Decompose-string takes the time/date string and decomposes it into a
+;;; list of alphabetic substrings, numbers, and special divider characters.
+;;; It matches whatever strings it can and replaces them with a dotted pair
+;;; containing a symbol and value.
+
+(defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
+  (do ((string-index start)
+       (next-negative nil)
+       (parts-list nil))
+      ((eq string-index end) (nreverse parts-list))
+    (let ((next-char (char string string-index))
+	  (prev-char (if (= string-index start)
+			 nil
+			 (char string (1- string-index)))))
+      (cond ((alpha-char-p next-char)
+	     ;; Alphabetic character - scan to the end of the substring.
+	     (do ((scan-index (1+ string-index) (1+ scan-index)))
+		 ((or (eq scan-index end)
+		      (not (alpha-char-p (char string scan-index))))
+		  (let ((match-symbol (match-substring
+				       (subseq string string-index scan-index))))
+		    (if match-symbol
+			(push match-symbol parts-list)
+			(return-from decompose-string nil)))
+		  (setf string-index scan-index))))
+	    ((digit-char-p next-char radix)
+	     ;; Numeric digit - convert digit-string to a decimal value.
+	     (do ((scan-index string-index (1+ scan-index))
+		  (numeric-value 0 (+ (* numeric-value radix)
+				      (digit-char-p (char string scan-index) radix))))
+		 ((or (eq scan-index end)
+		      (not (digit-char-p (char string scan-index) radix)))
+		  ;; If next-negative is t, set the numeric value to it's
+		  ;; opposite and reset next-negative to nil.
+		  (when next-negative
+		    (setf next-negative nil)
+		    (setf numeric-value (- numeric-value)))
+		  (push numeric-value parts-list)
+		  (setf string-index scan-index))))
+	    ((and (char= next-char #\-)
+		  (or (not prev-char)
+		      (member prev-char whitespace-chars :test #'char=)))
+	     ;; If we see a minus sign before a number, but not after one,
+	     ;; it is not a date divider, but a negative offset from GMT, so
+	     ;; set next-negative to t and continue.
+	     (setf next-negative t)
+	     (incf string-index))	     
+	    ((member next-char time-dividers :test #'char=)
+ 	     ;; Time-divider - add it to the parts-list with symbol.
+	     (push (cons 'time-divider next-char) parts-list)
+	     (incf string-index))
+	    ((member next-char date-dividers :test #'char=)
+	     ;; Date-divider - add it to the parts-list with symbol.
+	     (push (cons 'date-divider next-char) parts-list)
+	     (incf string-index))
+	    ((member next-char whitespace-chars :test #'char=)
+	     ;; Whitespace character - ignore it completely.
+	     (incf string-index))
+	    ((char= next-char #\()
+	     ;; Parenthesized string - scan to the end and ignore it.
+	     (do ((scan-index string-index (1+ scan-index)))
+		 ((or (eq scan-index end)
+		      (char= (char string scan-index) #\)))
+ 		  (setf string-index (1+ scan-index)))))
+	    (t
+	     ;; Unrecognized character - barf voraciously.
+	     (if *error-on-mismatch*
+		 (error
+		  'simple-error
+		  :format-control "Can't parse time/date string.~%>>> ~A~
+				   ~%~VT^-- Bogus character encountered here."
+		  :format-arguments (list string (+ string-index 4)))
+		 (return-from decompose-string nil)))))))
+

+;;; Match-pattern-element tries to match a pattern element with a datum
+;;; element and returns the symbol associated with the datum element if
+;;; successful.  Otherwise nil is returned.
+
+(defun match-pattern-element (pattern-element datum-element)
+  (cond ((listp datum-element)
+	 (let ((datum-type (if (eq (car datum-element) 'special)
+			       (cdr datum-element)
+			       (car datum-element))))
+	   (if (eq datum-type pattern-element) datum-element)))
+	((funcall pattern-element datum-element)
+	 (cons pattern-element datum-element))
+	(t nil)))
+
+;;; Match-pattern matches a pattern against a datum, returning the
+;;; pattern if successful and nil otherwise.
+
+(defun match-pattern (pattern datum datum-length)
+  (if (>= (length pattern) datum-length)
+      (let ((form-list nil))
+	(do ((pattern pattern (cdr pattern))
+	     (datum datum (cdr datum)))
+	    ((or (null pattern) (null datum))
+	     (cond ((and (null pattern) (null datum))
+		    (nreverse form-list))
+		   ((null pattern) nil)
+		   ((null datum) (dolist (element pattern
+						  (nreverse form-list))
+				   (if (not (listp element))
+				       (return nil))))))
+	  (let* ((pattern-element (car pattern))
+		 (datum-element (car datum))
+		 (optional (listp pattern-element))
+		 (matching (match-pattern-element (if optional
+						      (car pattern-element)
+						      pattern-element)
+						  datum-element)))
+	    (cond (matching (let ((form-type (car matching)))
+			      (unless (or (eq form-type 'time-divider)
+					  (eq form-type 'date-divider))
+				(push matching form-list))))
+		  (optional (push datum-element datum))
+		  (t (return-from match-pattern nil))))))))
+

+;;; Deal-with-noon-midn sets the decoded-time values to either noon
+;;; or midnight depending on the argument form-value.  Form-value
+;;; can be either 'noon or 'midn.
+
+(defun deal-with-noon-midn (form-value parsed-values)
+  (cond ((eq form-value 'noon)
+	 (setf (decoded-time-hour parsed-values) 12))
+	((eq form-value 'midn)
+	 (setf (decoded-time-hour parsed-values) 0))
+	(t (error "Unrecognized symbol: ~A" form-value)))
+  (setf (decoded-time-minute parsed-values) 0)
+  (setf (decoded-time-second parsed-values) 0))
+
+;;; Deal-with-am-pm sets the decoded-time values to be in the am
+;;; or pm depending on the argument form-value.  Form-value can
+;;; be either 'am or 'pm.
+
+(defun deal-with-am-pm (form-value parsed-values)
+  (let ((hour (decoded-time-hour parsed-values)))
+    (cond ((eq form-value 'am)
+	   (cond ((eq hour 12)
+		  (setf (decoded-time-hour parsed-values) 0))
+		 ((not (<= 0 hour 12))
+		  (if *error-on-mismatch*
+		      (error "~D is not an AM hour, dummy." hour)))))
+	  ((eq form-value 'pm)
+	   (if (<= 0 hour 11)
+	       (setf (decoded-time-hour parsed-values)
+		     (mod (+ hour 12) 24))))
+	  (t (error "~A isn't AM/PM - this shouldn't happen." form-value)))))
+
+;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
+(defun deal-with-izone (form-value parsed-values)
+  (multiple-value-bind (hours mins)
+      (truncate form-value 100)
+    (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60))))))
+
+;;; Set-time-values uses the association list of symbols and values
+;;; to set the time in the decoded-time structure.
+
+(defun set-time-values (string-form parsed-values)
+  (dolist (form-part string-form t)
+    (let ((form-type (car form-part))
+	  (form-value (cdr form-part)))
+      (case form-type
+	(secondp (setf (decoded-time-second parsed-values) form-value))
+	(minute (setf (decoded-time-minute parsed-values) form-value))
+	(hour (setf (decoded-time-hour parsed-values) form-value))
+	(day (setf (decoded-time-day parsed-values) form-value))
+	(month (setf (decoded-time-month parsed-values) form-value))
+	(year (setf (decoded-time-year parsed-values) form-value))
+	(zone (setf (decoded-time-zone parsed-values) form-value))
+	(izone (deal-with-izone form-value parsed-values))
+	(weekday (setf (decoded-time-dotw parsed-values) form-value))
+	(am-pm (deal-with-am-pm form-value parsed-values))
+	(noon-midn (deal-with-noon-midn form-value parsed-values))
+	(special (funcall form-value parsed-values))
+	(t (error "Unrecognized symbol in form list: ~A." form-type))))))
+

+(defun parse-time (time-string &key (start 0) (end (length time-string))
+			       (error-on-mismatch nil)
+			       (patterns *default-date-time-patterns*)
+			       (default-seconds nil) (default-minutes nil)
+			       (default-hours nil) (default-day nil)
+			       (default-month nil) (default-year nil)
+			       (default-zone nil) (default-weekday nil))
+  "Tries very hard to make sense out of the argument time-string and
+   returns a single integer representing the universal time if
+   successful.  If not, it returns nil.  If the :error-on-mismatch
+   keyword is true, parse-time will signal an error instead of
+   returning nil.  Default values for each part of the time/date
+   can be specified by the appropriate :default- keyword.  These
+   keywords can be given a numeric value or the keyword :current
+   to set them to the current value.  The default-default values
+   are 00:00:00 on the current date, current time-zone."
+  (setq *error-on-mismatch* error-on-mismatch)
+  (let* ((string-parts (decompose-string time-string :start start :end end))
+	 (parts-length (length string-parts))
+	 (string-form (dolist (pattern patterns)
+			(let ((match-result (match-pattern pattern
+							   string-parts
+							   parts-length)))
+			  (if match-result (return match-result))))))
+    (if string-form
+	(let ((parsed-values (make-default-time default-seconds default-minutes
+						default-hours default-day
+						default-month default-year
+						default-zone default-weekday)))
+	  (set-time-values string-form parsed-values)
+	  (convert-to-unitime parsed-values))
+	(if *error-on-mismatch*
+	  (error "\"~A\" is not a recognized time/date format." time-string)
+	  nil))))
+
+

Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-class.lisp	Sat Feb  2 17:54:13 2008
@@ -158,6 +158,8 @@
 				     direct-slots))
 	 (xml-direct (first xml-directs)))
 
+    ;; Commented out this check because I could not determine what it does and it warned me.
+    #+(or)
     (when (> (length xml-directs) 1)
       (dolist (slot-def (class-slots (class-of (first xml-directs))))
         (unless (apply #'equal (mapcar #'(lambda (slot) (slot-value slot (slot-definition-name slot-def))) xml-directs))

Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd
==============================================================================
--- branches/trunk-reorg/bknr/web/src/bknr-web.asd	(original)
+++ branches/trunk-reorg/bknr/web/src/bknr-web.asd	Sat Feb  2 17:54:13 2008
@@ -94,7 +94,7 @@
 								 "sessions"
 								 "site"))
 
-					     (:file "templates"
+					     (:file "template-handler"
 						    :depends-on ("handlers"))
 					     (:file "rss-handlers"
 						    :depends-on ("handlers"))
@@ -106,7 +106,7 @@
 
 					     (:file "tags"
 						    :depends-on ("handlers"
-								 "templates"
+								 "template-handler"
 								 "site"
 								 "web-utils")))
 			  :depends-on ("sysclasses" "packages" "rss"))

Modified: branches/trunk-reorg/bknr/web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/packages.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/packages.lisp	Sat Feb  2 17:54:13 2008
@@ -270,6 +270,7 @@
 	   #:find-template-pathname
 	   #:initial-template-environment
 	   #:with-tag-expanders
+	   #:emit-tag-children
 
 	   #:*html-variables*
            #:*template-dtd-catalog*

Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/tags.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/tags.lisp	Sat Feb  2 17:54:13 2008
@@ -18,7 +18,8 @@
     (emit-template-node toplevel)))
 
 (define-bknr-tag tag-body ()
-  (mapc #'emit-template-node *toplevel-children*))
+  (let ((*tag-children* *toplevel-children*))
+    (emit-tag-children)))
 
 (define-bknr-tag redirect-request (&key target)
   (redirect target))

Copied: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp (from r2434, branches/trunk-reorg/bknr/web/src/web/templates.lisp)
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/templates.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Sat Feb  2 17:54:13 2008
@@ -6,16 +6,19 @@
 
 (defvar *template-expander*)
 (defvar *template-env*)
-(defvar *template-dtd-catalog* `(;; libxml standard
-                                 "/etc/xml/catalog"
-                                 ;; FreeBSD
-                                 "/usr/local/share/xml/catalog.ports"))
+(defparameter *template-dtd-catalog* `(;; libxml standard
+				       "/etc/xml/catalog"
+				       ;; FreeBSD
+				       "/usr/local/share/xml/catalog.ports"
+				       "/usr/local/share/xml/catalog"))
 
-#+cmu
 (eval-when (:load-toplevel :execute)
   (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG")))
     (when env-catalog
-      (pushnew env-catalog *template-dtd-catalog* :test #'equal))))
+      (pushnew env-catalog *template-dtd-catalog* :test #'equal)))
+  (setf cxml:*catalog* (cxml:make-catalog (remove-if-not #'probe-file *template-dtd-catalog*))
+	cxml:*dtd-cache* (cxml:make-dtd-cache)
+	cxml:*cache-all-dtds* t))
 
 ;; user-error is supposed to be raised when an error is provoked by
 ;; the user (i.e. by supplying invalid form data).
@@ -37,10 +40,15 @@
 (defclass template-expander ()
   ((command-packages :initarg :command-packages
 		     :initform nil
-		     :reader template-expander-command-packages)))
+		     :reader template-expander-command-packages)
+   (destination :initarg :destination
+		:reader template-expander-destination)
+   (cached-templates :initform (make-hash-table :test 'equal)
+                     :accessor template-expander-cached-templates)))
 
 (defmethod find-tag-function ((expander template-expander) name ns)
-  (let ((package-name (cdr (assoc (make-keyword-from-string ns) (template-expander-command-packages expander))))
+  (let ((package-name (cdr (find ns (template-expander-command-packages expander)
+				 :test #'equal :key #'car)))
 	(function-name (string-upcase name)))
     (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*)
 				   (error "can't find package ~A in tag function registry" package-name)))
@@ -100,23 +108,6 @@
 	       (t (format nil "~A" val))))))
       string))
 
-(defun emit-template (expander stream node env)
-  (let* ((*template-expander* expander)
-         (*template-env* env)
-         (sink (cxml:make-character-stream-sink stream :canonical nil))
-         (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod)))
-    (if (node-attribute node "suppress-xml-headers")
-	(emit-template-node node)
-	(progn
-	  (sax:start-document *html-sink*)
-	  (sax:start-dtd *html-sink*
-			 "html"
-			 "-//W3C//DTD XHTML 1.0 Transitional//EN"
-			 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
-	  (sax:end-dtd *html-sink*)
-	  (emit-template-node node)))
-    (sax:end-document *html-sink*)))
-
 (defun xmls-attributes-to-sax (fn attrs)
   (mapcar (lambda (a)
             (destructuring-bind (name value) a
@@ -131,55 +122,109 @@
 				      :specified-p t))))
 	  attrs))
 
-(defun emit-template-node (node)
+(defun parse-template (template-pathname)
+  (let ((sax:*include-xmlns-attributes* t))
+    (cxml:parse-file (namestring (probe-file template-pathname))
+		     (cxml-xmls:make-xmls-builder)
+                     :validate nil)))
+
+(defvar *tag-children*)
+
+(defun emit-tag-children ()
+  "Function to be called by application defined tags to emit their children."
+  (mapc (curry #'emit-template-node *template-expander*) *tag-children*))
+
+(defun emit-template-node (expander node)
   (if (stringp node)
       (sax:characters *html-sink* (expand-variables node))
       (let* ((name (node-name node))
              (ns (node-ns node))
              (children (node-children node))
              (attrs (cxml-xmls:node-attrs node)))
-        ;; XML-technisch waere es korrekter, nicht auf das Praefix zu gucken,
-        ;; sondern auf die Namespace-URI.
         (cond
-          ((and ns
-		(not (find #\: ns)))
-           (apply (find-tag-function *template-expander* name ns)
-		  (append (loop for (key name) in (remove-if #'(lambda (attr) (scan "^xmlns" (car attr))) attrs)
-				collect (make-keyword-from-string key)
-				collect (expand-variables name))
-			  (when children
-			    (list :children children)))))
+          ((find ns (template-expander-command-packages expander)
+		 :test #'equal :key #'car)
+	   (let ((*tag-children* children))
+	     (apply (find-tag-function expander name ns)
+		    (append (loop for (key name) in attrs
+				  collect (make-keyword-from-string key)
+				  collect (expand-variables name))))))
           (t
            (sax:start-element *html-sink* nil nil name
                               (xmls-attributes-to-sax #'expand-variables attrs))
            (dolist (child children)
-             (emit-template-node child))
+             (emit-template-node expander child))
            (sax:end-element *html-sink* nil nil name))))))
 
+(defun emit-parsed-template (expander toplevel)
+  "Emit the given XMLS compatible structure as XML to *HTML-SINK*."
+  ;; In order to generate xmlns attributes, we use the internal
+  ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function.  This may need to
+  ;; be revised with newer cxml releases.
+  (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)
+		     (cxml-xmls::compute-attributes/lnames toplevel t))
+  (let ((*template-expander* expander))
+    (mapc (curry #'emit-template-node expander) (node-children toplevel)))
+  (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)))
+
+(defun find-template (dir components)
+  (if (null components)
+      nil
+      (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components)))
+				       dir)))
+	(when (probe-file next-dir)
+	  (let ((result (multiple-value-list (find-template next-dir (cdr components)))))
+	    (when (car result)
+	      (return-from find-template (values-list result)))))
+	(let ((file (merge-pathnames (make-pathname :type "xml"
+						    :name (first components))
+				     dir)))
+	  (when (probe-file file)
+	    (values file (cdr components)))))))
+
+(defmethod find-template-pathname ((expander template-expander) template-name)
+  (let ((components (remove "" (split "/" template-name) :test #'equal)))
+    (multiple-value-bind (pathname ret-components)
+	(find-template (template-expander-destination expander) components)
+      (unless pathname
+	(template-not-found template-name))
+      (values pathname
+	      ret-components
+	      (with-output-to-string (s)
+		(dolist (component (subseq components 0 (- (length components)
+							   (length ret-components))))
+		  (write-char #\/ s)
+		  (write-string component s)))))))
+
+(defun get-cached-template (pathname expander)
+  (let* ((table (template-expander-cached-templates expander))
+         (namestring (namestring pathname))
+         (cache-entry (gethash namestring table))
+         (current-write-date (file-write-date namestring)))
+    (unless (and cache-entry (eql (car cache-entry) current-write-date))
+      (setf cache-entry
+            (cons current-write-date (parse-template pathname)))
+      (setf (gethash namestring table) cache-entry))
+    (cdr cache-entry)))
+
+(defun emit-template (expander stream node env)
+  (let* ((*template-env* env)
+         (*html-sink* (cxml:make-character-stream-sink stream :canonical nil)))
+    (if (node-attribute node "suppress-xml-headers")
+	(emit-parsed-template expander node)
+	(progn
+	  (sax:start-document *html-sink*)
+	  (sax:start-dtd *html-sink*
+			 "html"
+			 "-//W3C//DTD XHTML 1.0 Transitional//EN"
+			 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
+	  (sax:end-dtd *html-sink*)
+	  (emit-parsed-template expander node)))
+    (sax:end-document *html-sink*)))
 ;; template handler
 
 (defclass template-handler (prefix-handler template-expander)
-  ((destination :initarg :destination
-		:reader template-handler-destination)
-   (cached-templates :initform (make-hash-table :test 'equal)
-                     :accessor template-handler-cached-templates)
-   (dtd-cache :initform (cxml:make-dtd-cache)
-              :reader template-handler-dtd-cache)
-   (catalog :initform (cxml:make-catalog *template-dtd-catalog*)
-            :reader template-handler-catalog)))
-
-(defconstant +max-template-expansions-per-request+ 100
-  "Maximum number of template expansions in one template request (circular dependency safeguard")
-
-(defun parse-template (handler template-pathname)
-  (let ((cxml:*dtd-cache* (template-handler-dtd-cache handler))
-        (cxml:*cache-all-dtds* t)
-        (cxml:*catalog* (template-handler-catalog handler))
-        (sax:*include-xmlns-attributes* t))
-    (cxml:parse-file (namestring (probe-file template-pathname))
-		     (cxml:make-recoder (cxml-xmls:make-xmls-builder)
-                                        #'cxml::rod-to-utf8-string)
-                     :validate nil)))
+  ())
 
 (defmethod expand-template ((handler template-handler)
 			    template-name &key env)
@@ -216,46 +261,6 @@
 			   env)))
         (template-not-found template-pathname))))
 
-(defun find-template (dir components)
-  (if (null components)
-      nil
-      (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components)))
-				       dir)))
-	(when (probe-file next-dir)
-	  (let ((result (multiple-value-list (find-template next-dir (cdr components)))))
-	    (when (car result)
-	      (return-from find-template (values-list result)))))
-	(let ((file (merge-pathnames (make-pathname :type "xml"
-						    :name (first components))
-				     dir)))
-	  (when (probe-file file)
-	    (values file (cdr components)))))))
-
-(defmethod find-template-pathname ((handler template-handler) template-name)
-  (let ((components (remove "" (split "/" template-name) :test #'equal)))
-    (multiple-value-bind (pathname ret-components)
-	(find-template (template-handler-destination handler) components)
-      (unless pathname
-	(template-not-found template-name))
-      (values pathname
-	      ret-components
-	      (with-output-to-string (s)
-		(dolist (component (subseq components 0 (- (length components)
-							   (length ret-components))))
-		  (write-char #\/ s)
-		  (write-string component s)))))))
-
-(defun get-cached-template (pathname handler)
-  (let* ((table (template-handler-cached-templates handler))
-         (namestring (namestring pathname))
-         (cache-entry (gethash namestring table))
-         (current-write-date (file-write-date namestring)))
-    (unless (and cache-entry (eql (car cache-entry) current-write-date))
-      (setf cache-entry
-            (cons current-write-date (parse-template handler pathname)))
-      (setf (gethash namestring table) cache-entry))
-    (cdr cache-entry)))
-
 (defun send-error-response (handler message &key (response-code +http-internal-server-error+))
   (with-http-response (:content-type "text/html; charset=UTF-8"
 				     :response response-code)

Modified: branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/worldpay-test/boi-handlers.lisp	Sat Feb  2 17:54:13 2008
@@ -31,7 +31,7 @@
   ())
 
 (defmethod authorized-p ((handler boi-handler))
-  (let ((user (bknr-request-user)))
+  (let ((user (bknr-session-user)))
     (or (admin-p user)
 	(user-has-flag user :boi))))
 
@@ -91,7 +91,7 @@
 	(with-transaction (:contract-paid)
 	  (contract-set-paidp contract (format nil "~A: manually set paid by ~A"
 					       (format-date-time)
-					       (user-login (bknr-request-user))))
+					       (user-login (bknr-session-user))))
 	  (when name
 	    (setf (user-full-name (contract-sponsor contract)) name))))
       (with-xml-response ()

Modified: branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/worldpay-test/sponsor-handlers.lisp	Sat Feb  2 17:54:13 2008
@@ -96,7 +96,7 @@
 	   (contract (make-contract sponsor (parse-integer numsqm)
 				    :paidp (format nil "~A: manually created by ~A"
 						   (format-date-time (get-universal-time))
-						   (user-login (bknr-request-user)))
+						   (user-login (bknr-session-user)))
 				    :date (date-to-universal date))))
       (contract-issue-cert contract name :address address :language language)
       (mail-backoffice-sponsor-data contract)
@@ -223,7 +223,7 @@
 	    (html (:h2 "Completing square meter sale"))
 	    (sponsor-set-country (contract-sponsor contract) country)
 	    (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A"
-						 (format-date-time) (user-login (bknr-request-user))))
+						 (format-date-time) (user-login (bknr-session-user))))
 	    (when email
 	      (html (:p "Sending instruction email to " (:princ-safe email)))
 	      (mail-instructions-to-sponsor contract email))))
@@ -243,8 +243,8 @@
 		     (sponsor-id-or-x
 		      (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor))
 		     (t
-		      (when (eq (find-class 'sponsor) (class-of (bknr-request-user)))
-			(bknr-request-user))))))
+		      (when (eq (find-class 'sponsor) (class-of (bknr-session-user)))
+			(bknr-session-user))))))
       (with-http-response (:content-type "text/html; charset=UTF-8")
 	(with-http-body ()
 	  (let ((*standard-output* *html-stream*))
@@ -265,7 +265,7 @@
       (with-http-body ()
 	(format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%"
 		(cond
-		  ((eq (find-class 'sponsor) (class-of (bknr-request-user)))
+		  ((eq (find-class 'sponsor) (class-of (bknr-session-user)))
 		   "logged-in")
 		  (__sponsorid
 		   "login-failed")

Modified: branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp	(original)
+++ branches/trunk-reorg/projects/bos/worldpay-test/tags.lisp	Sat Feb  2 17:54:13 2008
@@ -24,7 +24,7 @@
 (define-bknr-tag worldpay-receipt ()
   (emit-without-quoting "<WPDISPLAY ITEM=banner>"))
 
-(define-bknr-tag process-payment (&key children)
+(define-bknr-tag process-payment ()
   (with-template-vars (cartId transId email country)
     (let* ((contract (get-contract (parse-integer cartId)))
 	   (sponsor (contract-sponsor contract)))
@@ -34,7 +34,7 @@
       (contract-set-paidp contract (format nil "~A: paid via worldpay" (format-date-time)))
       (setf (get-template-var :master-code) (sponsor-master-code sponsor))
       (setf (get-template-var :sponsor-id) (sponsor-id sponsor))))
-  (mapc #'emit-template-node children))
+  (emit-tag-children))
 
 (define-bknr-tag generate-cert ()
   (with-template-vars (gift email name address)
@@ -106,7 +106,7 @@
 			  (if donationcert-yearly "1" "0")
 			  (if gift "1" "0")
 			  (when *worldpay-test-mode* "&testMode=100"))))))
-    (mapc #'emit-template-node children)))
+    (emit-tag-children)))
 
 (define-bknr-tag mail-transfer ()
   (with-query-params ((get-template-var :request)
@@ -126,16 +126,16 @@
 			   :language (session-variable :language))
       (mail-manual-sponsor-data (get-template-var :request)))))
 
-(define-bknr-tag when-certificate (&key children)
+(define-bknr-tag when-certificate ()
   (let ((sponsor (bknr-request-user (get-template-var :request))))
     (when (some #'contract-pdf-pathname (sponsor-contracts sponsor))
-      (mapc #'emit-template-node children))))
+      (emit-tag-children))))
 
-(define-bknr-tag send-info-request (&key children email)
+(define-bknr-tag send-info-request (&key email)
   (mail-info-request email)
-  (mapc #'emit-template-node children))
+  (emit-tag-children))
 
-(define-bknr-tag save-profile (&key children)
+(define-bknr-tag save-profile ()
   (let ((sponsor (bknr-request-user (get-template-var :request))))
     (with-template-vars (email name password infotext anonymize)
       (when anonymize
@@ -144,7 +144,7 @@
 			    'info-text nil
 			    'email nil))
       (when name
-	(change-slot-values sponsor 'full-name name))
+	(change-sLot-values sponsor 'full-name name))
       (when email
 	(change-slot-values sponsor 'bknr.web::email email))
       (when password
@@ -160,9 +160,9 @@
     (setf (get-template-var :numsqm)
 	  (format nil "~D"
 		  (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))
-  (mapc #'emit-template-node children))
+  (emit-tag-children))
 
-(define-bknr-tag admin-login-page (&key children)
+(define-bknr-tag admin-login-page ()
   (if (admin-p (bknr-request-user (get-template-var :request)))
       (html (:head ((:meta :http-equiv "refresh" :content "0; url=/admin"))))
-      (mapc #'emit-template-node children)))
\ No newline at end of file
+      (emit-tag-children)))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp	(original)
+++ branches/trunk-reorg/projects/bos/worldpay-test/web-utils.lisp	Sat Feb  2 17:54:13 2008
@@ -27,8 +27,8 @@
 	((:p :class "footer")
 	 "local time is " (:princ-safe (format-date-time))
 	 " - "
-	 (if (bknr-request-user)
-	     (html "logged in as " (html-link (bknr-request-user)))
+	 (if (bknr-session-user)
+	     (html "logged in as " (html-link (bknr-session-user)))
 	     (html "not logged in"))
 	 " - current content language is "
 	(cmslink "change-language"

Modified: branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp	(original)
+++ branches/trunk-reorg/projects/bos/worldpay-test/worldpay-test.lisp	Sat Feb  2 17:54:13 2008
@@ -112,7 +112,7 @@
 
 (defmethod handle-object ((handler certificate-handler) contract)
   (unless contract
-    (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user)))))
+    (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-session-user)))))
   (redirect (format nil "/certificates/~D.pdf" (store-object-id contract))))
 
 (defclass statistics-handler (admin-only-handler prefix-handler)

Modified: branches/trunk-reorg/projects/eboy/src/item-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/eboy/src/item-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/eboy/src/item-handlers.lisp	Sat Feb  2 17:54:13 2008
@@ -77,7 +77,7 @@
                                          :confirm "Really delete item?")))))))
 
 (defmethod authorized-p ((handler edit-item-handler))
-  (admin-p (bknr-request-user)))
+  (admin-p (bknr-session-user)))
 
 (defmethod handle-object-form ((handler edit-item-handler)
 			       action item)

Modified: branches/trunk-reorg/projects/gpn/gpn-tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/gpn/gpn-tags.lisp	(original)
+++ branches/trunk-reorg/projects/gpn/gpn-tags.lisp	Sat Feb  2 17:54:13 2008
@@ -32,14 +32,14 @@
 				 ((:a :class "headlink" :href (second button))
 				  (:princ-safe (first button))))))
 		      (html (:td))))
-		(if (eql (find-user "anonymous") (bknr-request-user))
+		(if (eql (find-user "anonymous") (bknr-session-user))
 		  (html ((:td :class "headbar")
 			 ((:a :class "headlogin" :href "/login") "LOGIN")))
 		  (html ((:td :class "headbar")
 			 ((:a :class "headlogin" :href (format nil "/gpn-user/~a"
-							       (user-login (bknr-request-user))))
+							       (user-login (bknr-session-user))))
 			  "HOME"))
-			(when (admin-p (bknr-request-user))
+			(when (admin-p (bknr-session-user))
 			  (html ((:td :class "headbar")
 				 ((:a :class "headlogin" :href "/admin") "ADMIN"))))
 			((:td :class "headbar")
@@ -71,7 +71,7 @@
 		      (html "ANONYMOUS")) ", "
 		  (:princ-safe (format-date-time (article-time item)
 						 :show-weekday t))
-		  (when (equal (article-author item) (bknr-request-user))
+		  (when (equal (article-author item) (bknr-session-user))
 		    (html ((:a :href (format nil "/edit-article/~A" (store-object-id item))) " (edit)")))
 		  ))))
 	(html ((:a :class "rss" :href (format nil "~a/~a" (handler-url :blog-rss)
@@ -154,7 +154,7 @@
 		 (when email
 		   (html ((:div :class "email")
 			  "EMAIL: " (:princ-safe (string-upcase (user-email user))))))))
-	  (when (string-equal (user-login user) (user-login (bknr-request-user)))
+	  (when (string-equal (user-login user) (user-login (bknr-session-user)))
 	    (html ((:div :class "user-edit")
 		   ((:p :class "news")
 		    "Zum Importieren von Bildern zuerst die Bilder auf ftp://fiep/ hochladen,
@@ -278,11 +278,11 @@
 
 (define-bknr-tag logged-in ()
   (html ((:div :class "logged-in") "logged in as "
-	 (if (string-equal (user-login (bknr-request-user)) "anonymous")
+	 (if (string-equal (user-login (bknr-session-user)) "anonymous")
 	     (html "anonymous")
 	     (html ((:a :style "color:#cc3333;"
-			:href (format nil "/gpn-user/~a" (user-login (bknr-request-user))))
-		    (:princ-safe (user-login (bknr-request-user)))))))))
+			:href (format nil "/gpn-user/~a" (user-login (bknr-session-user))))
+		    (:princ-safe (user-login (bknr-session-user)))))))))
 
 (define-bknr-tag gpn-fahrplan (&key location)
   (let ((events (sort (remove-if #'(lambda (event) (< (zeitplan-event-end-time event) (get-universal-time)))
@@ -414,5 +414,5 @@
 		      (html "ANONYMOUS")) ", "
 		  (:princ-safe (format-date-time (article-time article)
 						 :show-weekday t))
-		  (when (equal (article-author article) (bknr-request-user))
+		  (when (equal (article-author article) (bknr-session-user))
 		    (html ((:a :href (format nil "/edit-article/~A" (store-object-id article))) " (edit)"))))))))))

Modified: branches/trunk-reorg/projects/gpn/import-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/gpn/import-handler.lisp	(original)
+++ branches/trunk-reorg/projects/gpn/import-handler.lisp	Sat Feb  2 17:54:13 2008
@@ -6,7 +6,7 @@
   ())
 
 (defmethod import-handler-import-pathname ((handler gpn-import-handler))
-  (let* ((user (bknr-request-user))
+  (let* ((user (bknr-session-user))
 	 (spool-dir (merge-pathnames (make-pathname :directory
 						    (list :relative (user-login user)
 							  "images"))
@@ -34,7 +34,7 @@
   (let* ((keywords (keywords-from-query-param-list (query-param-list "keyword")))
 	 (spool-dir (import-handler-import-pathname handler)))
     (import-directory spool-dir
-		      :user (bknr-request-user)
+		      :user (bknr-session-user)
 		      :keywords (when (admin-p *user*) keywords)
 		      :spool (import-handler-spool-dir handler)
 		      :keywords-from-dir (if (admin-p *user*)

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp	Sat Feb  2 17:54:13 2008
@@ -7,7 +7,7 @@
   (when (probe-file "site.lisp")
     (load "site.lisp")))
 
-(defparameter *root-directory* #p"home:bknr-svn/projects/lisp-ecoop/")
+(defparameter *root-directory* (merge-pathnames #P"../" *load-pathname*))
 
 (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*))
 

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/handlers.lisp	Sat Feb  2 17:54:13 2008
@@ -5,8 +5,8 @@
 (defun format-object-id (format object &rest args)
   (apply #'format nil format (store-object-id object) args))
 
-(defmacro with-lisp-ecoop-page ((req title) &body body)
-  `(with-bknr-page (,req :title ,title)
+(defmacro with-lisp-ecoop-page ((title) &body body)
+  `(with-bknr-page (:title ,title)
      , at body))
 
 (defclass edit-participant-handler (edit-object-handler)
@@ -14,7 +14,7 @@
   (:default-initargs :class 'participant :query-function #'find-user))
 
 (defmethod handle-object-form ((handler edit-participant-handler) (action (eql nil)) (participant participant))
-  (with-lisp-ecoop-page (req #?"Edit participant $((user-login participant))")
+  (with-lisp-ecoop-page (#?"Edit participant $((user-login participant))")
     ((:form :method "post" :enctype "multipart/form-data")
      ((:table :border "1")
       (:tr (:th "Login")
@@ -29,7 +29,7 @@
 
 (defmethod handle-object-form ((handler edit-participant-handler) (action (eql :reset-password)) (participant participant))
   (participant-reset-password participant)
-  (with-lisp-ecoop-page (req "Password reset")
+  (with-lisp-ecoop-page ("Password reset")
     "The participant's password has been reset and sent by mail"))
 
 (defclass pdf-handler (object-handler)
@@ -39,7 +39,7 @@
 (defmethod handle-object ((handler pdf-handler) (document document))
   (let ((pdf (file-contents (blob-pathname document))))
     (with-http-response (:content-type "application/pdf")
-      (setf (request-reply-content-length) (length pdf))
+      (setf (content-length) (length pdf))
       (with-http-body (:external-format '(unsigned-byte 8))
 	(write-sequence pdf *html-stream*)))))
 
@@ -49,7 +49,7 @@
 (defmethod handle ((handler make-submission-handler))
   (with-query-params (type title abstract)
     (let ((submission (make-object (if (string-equal type "paper") 'paper 'breakout-group-proposal) :title title :abstract abstract)))
-      (with-lisp-ecoop-page (req #?"Submission created")
+      (with-lisp-ecoop-page (#?"Submission created")
         (html ((:script :type "text/javascript")
                (:princ-safe #?"
 if (window.opener) {
@@ -80,7 +80,9 @@
                  (let ((document (make-object 'document :info info :submission submission)))
                    (blob-from-file document file-name)
                    (redirect (format-object-id "/upload/~A?success=1" submission)))
-                 (redirect (format-object-id "/upload/~A?failure=~A" submission (uriencode-string "Uploaded file does not appear to be a PDF file")))))))))
+                 (redirect (format-object-id "/upload/~A?failure=~A"
+					     submission
+					     (url-encode "Uploaded file does not appear to be a PDF file")))))))))
     (:get
      (redirect (format-object-id "/upload/~A" submission)))))
 
@@ -97,7 +99,7 @@
   ())
 
 (defmethod handle ((handler page-handler))
-  (with-lisp-ecoop-page (req "LISP-ECOOP Administration")
+  (with-lisp-ecoop-page ("LISP-ECOOP Administration")
     "Please choose an administrative task from the menu"))
 
 (define-bknr-webserver-module participants

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp	Sat Feb  2 17:54:13 2008
@@ -13,6 +13,9 @@
     (make-user "admin" :password "wispleb" :full-name "Administrator" :flags '(:admin))
     (import-image "bknr-logo.png" :keywords '(:banner :bknr)))
 
+  #+(or)
   (bknr.cron:start-cron)
   
-  (publish-lisp-ecoop))
+  (publish-lisp-ecoop)
+
+  (start-webserver))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/lisp-ecoop.asd	Sat Feb  2 17:54:13 2008
@@ -18,20 +18,17 @@
 
   :depends-on (:bknr-datastore
                :bknr-web
+	       :closer-mop
+	       :cl-smtp
                :cxml)
 
   :components ((:file "packages")
 	       (:file "config" :depends-on ("packages"))
 	       (:file "macros" :depends-on ("config"))
-               #+(or)
 	       (:file "schedule" :depends-on ("macros"))
-               #+(or)
 	       (:file "participant" :depends-on ("macros" "schedule"))
-               #+(or)
 	       (:file "mail" :depends-on ("participant"))
-               #+(or)
 	       (:file "tags" :depends-on ("participant"))
-               #+(or)
 	       (:file "handlers" :depends-on ("participant"))
-	       (:file "webserver" :depends-on (#+(or) "handlers"))
+	       (:file "webserver" :depends-on ("handlers"))
 	       (:file "init" :depends-on ("webserver"))))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/load.lisp	Sat Feb  2 17:54:13 2008
@@ -3,7 +3,8 @@
 (asdf:oos 'asdf:load-op :lisp-ecoop)
 (asdf:oos 'asdf:load-op :swank)
 
-(swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t)
+(swank::create-server :port 4005)
 (lisp-ecoop::startup)
 
+#+cmu
 (mp::startup-idle-and-top-level-loops)

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/macros.lisp	Sat Feb  2 17:54:13 2008
@@ -29,13 +29,13 @@
 		  access slot class)))
       (cons name rest))))
 
-(defmacro define-lisp-ecoop-class (class (&rest superclasses) slots &rest class-options)
+(defmacro define-lisp-ecoop-class (class-name (&rest superclasses) slots &rest class-options)
   (let ((superclasses (or superclasses '(store-object)))
-	(slots (mapcar #'(lambda (slot) (compute-slot class slot))
+	(slots (mapcar #'(lambda (slot) (compute-slot class-name slot))
 		       slots)))
     ;; the eval-when is there to create the index access functions at compile time
     `(eval-when (:compile-toplevel :load-toplevel :execute)
-      (defclass ,class ,superclasses
+      (defclass ,class-name ,superclasses
 	((bknr.datastore::id :attribute t)
          , at slots)
 	(:metaclass persistent-xml-class)

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/packages.lisp	Sat Feb  2 17:54:13 2008
@@ -77,5 +77,4 @@
 	:xhtml-generator
 	:lisp-ecoop.config
 	:lisp-ecoop)
-  (:shadowing-import-from :cl-interpol #:quote-meta-chars)
-  (:export #:hello))
\ No newline at end of file
+  (:shadowing-import-from :cl-interpol #:quote-meta-chars))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp	Sat Feb  2 17:54:13 2008
@@ -16,7 +16,7 @@
     (with-slots (documents) submission
       (setf documents (remove document documents)))))
 
-(define-lisp-ecoop-class submission ()
+y(define-lisp-ecoop-class submission ()
   ((title :update :documentation "Title of the submission" :initform nil :attribute t)
    (abstract :update :documentation "Abstract or short description" :initform nil :element t)
    (submitters :update :documentation "List of participants who submitted this" :initform nil :element t :containment :+)
@@ -38,8 +38,8 @@
   "Generic submission")
 
 (defun submission-edit-permitted-p (submission)
-  (or (admin-p (bknr-request-user))
-      (find (bknr-request-user) (submission-submitters submission))))
+  (or (admin-p (bknr-session-user))
+      (find (bknr-session-user) (submission-submitters submission))))
 
 (defmethod submission-add-submitter ((submission submission) submitter)
   (pushnew submitter (submission-submitters submission))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/schedule.lisp	Sat Feb  2 17:54:13 2008
@@ -83,7 +83,7 @@
     ("/schedule" schedule-handler)
   ("/edit-timeslot" edit-timeslot-handler))
 
-(defun show-day-schedule (&key day children)
+(defun show-day-schedule (&key day)
   (let* ((begin (parse-time-spec day))
 	 (end (+ begin (* 24 60 60))))
     (labels ((timeslot-wanted (timeslot)
@@ -93,15 +93,15 @@
 			      #'< :key #'timeslot-begin-time))
 	(with-tag-expanders
 	    ((time ()
-		   (if (admin-p (bknr-request-user))
+		   (if (admin-p (bknr-session-user))
 		       (html ((:a :href #?"/edit-timeslot/$((store-object-id timeslot))")
 			      (:princ-safe (timeslot-time-string timeslot))))
 		       (html (:princ-safe (timeslot-time-string timeslot)))))
 	     (content ()
 		      (print-object-as-html (timeslot-content timeslot))))
-	  (mapc #'emit-template-node children))))))
+	  (emit-tag-children))))))
 
 (in-package :lisp-ecoop.tags)
 
-(define-bknr-tag show-day-schedule (&key day children)
-  (lisp-ecoop::show-day-schedule :day day :children children))
+(define-bknr-tag show-day-schedule (&key day)
+  (lisp-ecoop::show-day-schedule :day day))

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp	Sat Feb  2 17:54:13 2008
@@ -3,7 +3,7 @@
 (enable-interpol-syntax)
 
 (defun object-to-template-vars (object)
-  (dolist (slot-name (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))
+  (dolist (slot-name (mapcar #'closer-mop:slot-definition-name (closer-mop:class-slots (class-of object))))
     (when (and (slot-boundp object slot-name)
 	       (slot-value object slot-name))
       (setf (get-template-var (make-keyword-from-string (symbol-name slot-name)))
@@ -20,16 +20,16 @@
 	(if (parse-integer key :junk-allowed t)
 	    (find-store-object (parse-integer key :junk-allowed t))
 	    (find-user key))
-	(bknr-request-user))))
+	(bknr-session-user))))
 
-(define-bknr-tag profile-editor (&key children)
-  (when (anonymous-p (bknr-request-user))
+(define-bknr-tag profile-editor ()
+  (when (anonymous-p (bknr-session-user))
     (warn "User not logged in")
     (html (:h2 "Please log in to edit the profile"))
     (return-from profile-editor))
   (let ((participant (participant-from-request)))
-    (unless (or (admin-p (bknr-request-user))
-		(eq participant (bknr-request-user)))
+    (unless (or (admin-p (bknr-session-user))
+		(eq participant (bknr-session-user)))
       (html (:h2 "can't edit this profile"))
       (return-from profile-editor))
     (when (eq :post (request-method))
@@ -91,7 +91,7 @@
 	    (setf (participant-text participant) text)))))
     (object-to-template-vars participant)
     (let ((*participant* participant))
-      (mapc #'emit-template-node children))))
+      (emit-tag-children))))
 
 (defun document-file-info (document)
   (with-open-file (document-file (blob-pathname document))
@@ -104,7 +104,7 @@
 (defun submission-from-request ()
   (find-store-object (parse-integer (get-template-var :*path-arg*))))
 
-(define-bknr-tag submission-editor (&key children)
+(define-bknr-tag submission-editor ()
   (let ((submission (submission-from-request)))
     (unless submission
       (html (:h2 "Invalid submission ID"))
@@ -143,10 +143,10 @@
 	    (setf (submission-abstract submission) abstract)))))
     (object-to-template-vars submission)
     (let ((*submission* submission))
-      (mapc #'emit-template-node children))))
+      (emit-tag-children))))
 
-(define-bknr-tag add-participant (&key children)
-  (unless (admin-p (bknr-request-user))
+(define-bknr-tag add-participant ()
+  (unless (admin-p (bknr-session-user))
     (html "You must be logged in as adminstrator to create new participants")
     (return-from add-participant))
   (with-query-params (action)
@@ -159,7 +159,7 @@
         (make-participant login :full-name full-name :email email :text text :submission submission)
         (html
          (:princ-safe #?"The participant $(login) has been created in the database and a welcome mail has been sent.")))))
-  (mapc #'emit-template-node children))
+  (emit-tag-children))
 
 (define-bknr-tag submission-option-list ()
   (dolist (submission (sort (copy-list (class-instances 'submission))
@@ -193,14 +193,14 @@
                  (:ul
                   (dolist (participant (set-difference (class-instances 'participant) submitters))
                     (html (:li ((:a :href (format nil "~A?add-submitter-id=~A"
-						  (puri:uri-path (request-uri))
+						  (script-name)
 						  (store-object-id participant)))
                                 (:princ-safe (user-full-name participant)))))))))
           (remove-submitter
            (html (:strong "Remove Submitter")
                  (:ul
                   (dolist (participant submitters)
-                    (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (puri:uri-path (request-uri)) (store-object-id participant)))
+                    (html (:li ((:a :href (format nil "~A?remove-submitter-id=~A" (script-name) (store-object-id participant)))
                                 (:princ-safe (user-full-name participant))))))))))))))
 
 (define-bknr-tag submission-uploader ()
@@ -252,27 +252,27 @@
 	  (html ((:img :src (format-object-id "/image/~A/cell" image)))))
 	(:span ((:a :href (format-object-id "/profile/~A" participant))
 		(:princ-safe (user-full-name participant)))
-	       (when (or (eq participant (bknr-request-user))
-			 (admin-p (bknr-request-user)))
+	       (when (or (eq participant (bknr-session-user))
+			 (admin-p (bknr-session-user)))
 		 (html " " ((:a :href (format-object-id "/edit-profile/~A" participant)) "[Edit]")))))))))
 
-(define-bknr-tag participants-only (&key children error)
-  (if (participant-p (bknr-request-user))
-      (mapc #'emit-template-node children)
+(define-bknr-tag participants-only (&key error)
+  (if (participant-p (bknr-session-user))
+      (emit-tag-children)
       (when error
 	(html (:princ-safe error)))))
 
-(define-bknr-tag admin-only (&key children error)
-  (if (admin-p (bknr-request-user))
-      (mapc #'emit-template-node children)
+(define-bknr-tag admin-only (&key error)
+  (if (admin-p (bknr-session-user))
+      (emit-tag-children)
       (when error
 	(html (:princ-safe error)))))
 
-(define-bknr-tag profile (&key children)
+(define-bknr-tag profile ()
   (let* ((participant (participant-from-request)))
     (object-to-template-vars participant)
     (let ((*participant* participant))
-      (mapc #'emit-template-node children))))
+      (emit-tag-children))))
 
 (define-bknr-tag participant-picture-image (&key (width 20) (height 20))
   (when (participant-picture *participant*)
@@ -287,7 +287,7 @@
       (html "[no submission]")))
 
 (define-bknr-tag login-widget ()
-  (let ((user (bknr-request-user)))
+  (let ((user (bknr-session-user)))
     (cond
       ((anonymous-p user)
        (html ((:form :method "post")
@@ -300,15 +300,15 @@
               ((:button :type "submit" :name "action" :value "login") "login"))))
       (t
        (html ((:form :method "post" :action (website-make-path *website* "logout"))
-              ((:input :type "hidden" :name "url" :value (puri:uri-path (request-uri))))
+              ((:input :type "hidden" :name "url" :value (script-name)))
 	      (:div "Logged in as " :br
 		    ((:a :href (format-object-id "/edit-profile/~A" user))
 		     (:princ-safe (user-full-name user))))
 	      (:div ((:button :type "submit" :name "action" :value "logout") "logout"))))))))
 
-(define-bknr-tag admin-only (&key children)
-  (when (admin-p (bknr-request-user))
-    (mapc #'emit-template-node children)))
+(define-bknr-tag admin-only ()
+  (when (admin-p (bknr-session-user))
+    (emit-tag-children)))
 
 (defun parse-duration (string)
   (ignore-errors
@@ -318,7 +318,7 @@
 (define-bknr-tag schedule-submission ()
   (when (eq :post (request-method))
     (with-query-params (date time duration submission freetext)
-      (let ((start (ext:parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone
+      (let ((start (parse-time (format nil "~A ~A" date time) :default-zone -2)) ; XXX hardcoded time zone
 	    (duration (parse-duration duration))
 	    (submission (ignore-errors (store-object-with-id (parse-integer submission :junk-allowed t)))))
 	(cond
@@ -380,17 +380,17 @@
       (html (:li ((:a :href (format-object-id "/pdf/~A" document) :target "_new")
                   (:princ-safe (document-info document)) " " (:princ-safe (document-file-info document)))))))))
 
-(define-bknr-tag load-argument-object (&key children)
+(define-bknr-tag load-argument-object ()
   (let* ((object (object-from-request)))
     (object-to-template-vars object)
     (setf (get-template-var :object-id) (store-object-id object))
-    (mapc #'emit-template-node children)))
+    (emit-tag-children)))
 
-(define-bknr-tag page (&key children name)
+(define-bknr-tag page (&key name)
   (setf (get-template-var :title) name)
   (setf (get-template-var :base) (website-base-href *website*))
   (let* ((expander bknr.web::*template-expander*)
          (pathname (find-template-pathname expander "toplevel"))
          (toplevel (bknr.web::get-cached-template pathname expander))
-         (bknr.web::*toplevel-children* children))
+         (bknr.web::*toplevel-children* bknr.web::*tag-children*))
     (emit-template-node toplevel)))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp	Sat Feb  2 17:54:13 2008
@@ -9,8 +9,7 @@
 (defun make-daily-statistics ()
   (bknr.stats::make-yesterdays-stats :delete-events t :remove-referer-hosts '("lisp-ecoop.bknr.net")))
 
-#+(or)
-(defun publish-lisp-ecoop (&key (port *webserver-port*) (listeners 20) (base-href *base-path*))
+(defun publish-lisp-ecoop (&key (base-href *base-path*))
 
   (unless (bknr.cron:cron-job-with-name "daily webserver statistics")
     (bknr.cron:make-cron-job "daily webserver statistics" 'make-daily-statistics
@@ -23,24 +22,23 @@
                  :template-command-packages '((:lisp-ecoop . :lisp-ecoop.tags)
                                               (:bknr . :bknr.web)
                                               (:menu . :bknr.site-menu))
-		 :handler-definitions `(("/" redirect-handler
+		 :handler-definitions `(user images
+					#+(or) stats
+					#+(or) mailinglist
+					#+(or) mailinglist-registration
+					participants schedule
+					("/" redirect-handler
 					 :to "home")
 					("/static" directory-handler
-					 :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*))))
-		 :modules '(user images stats mailinglist mailinglist-registration participants schedule)
-
+					 :destination ,(probe-file (merge-pathnames #p"static/" *website-directory*))))
 		 :admin-navigation nil
 
 		 :authorizer (make-instance 'bknr-authorizer)
 		 :style-sheet-urls (list (format nil "~Astatic/styles.css" base-href))
-		 :javascript-urls (list (format nil "~Astatic/javascript.js" base-href)))
-
-  (start :port port :listeners listeners))
+		 :javascript-urls (list (format nil "~Astatic/javascript.js" base-href))))
 
 (defun start-webserver (&key (port 9000))
   (when (and (boundp '*server*) *server*)
     (stop-server *server*))
-  (setq *dispatch-table*
-	(list 'dispatch-easy-handlers
-	      (create-folder-dispatcher-and-handler "/" *website-directory*)))
+  (publish-lisp-ecoop)
   (setq *server* (start-server :port port)))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp	Sat Feb  2 17:54:13 2008
@@ -1,4 +1,7 @@
 (in-package :quickhoney.tags)
 
-(define-bknr-tag version-and-last-change ()
-  (html "v1.0 | updated " (:princ-safe (string-downcase (substitute #\Space #\- (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil))))))
\ No newline at end of file
+(define-bknr-tag version-and-last-change (&rest args)
+  (format *debug-io* "hello world: ~A~%" args)
+  (html "v1.1 | updated " (:princ-safe (string-downcase
+					(substitute #\Space #\-
+						    (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil))))))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp	Sat Feb  2 17:54:13 2008
@@ -42,8 +42,8 @@
 					 :content-type "application/x-icon")
 					("/" template-handler
 					 :destination ,(namestring (merge-pathnames "templates/" *website-directory*))
-					 :command-packages ((:quickhoney . :quickhoney.tags)
-							    (:bknr . :bknr.web))))
+					 :command-packages (("http://quickhoney.com/" . :quickhoney.tags)
+							    ("http://bknr.net/" . :bknr.web))))
 		 :admin-navigation '(("user" . "/user/")
 				     ("images" . "/edit-images")
 				     ("import" . "/import")

Modified: branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/templates/frontpage.xml	Sat Feb  2 17:54:13 2008
@@ -8,8 +8,7 @@
   >
 	<head>
 		<link rel="stylesheet" href="/static/styles.css" />
-		<link rel="alternate" type="application/rss+xml" title="RSS Feed"
-		      href="http://quickhoney.com/rss/quickhoney" />
+		<link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/quickhoney" />
 		<script src="/static/javascript.js" type="text/javascript"><!-- x -->	
 		</script> 
 		<title>QuickHoney - Nana Rausch + Peter Stemmler</title>

Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	Sat Feb  2 17:54:13 2008
@@ -3,8 +3,8 @@
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html
   xmlns="http://www.w3.org/1999/xhtml"
-  xmlns:bknr="http://bknr.net"
-  xmlns:quickhoney="http://quickhoney.com"
+  xmlns:bknr="http://bknr.net/"
+  xmlns:quickhoney="http://quickhoney.com/"
   >
 	<head>
 		<link rel="stylesheet" href="/static/styles.css" />
@@ -35,7 +35,7 @@
 		</a>
 
 		<p id="path" class="text"> </p>
-		<p id="version" class="text"><quickhoney:version-and-last-change /></p>
+		<p id="version" class="text"><quickhoney:version-and-last-change foo="1" bar="2" /></p>
 
 		<div id="elements">
 			<div id="quickhoney">

Modified: branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp
==============================================================================
--- branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp	(original)
+++ branches/trunk-reorg/projects/saugnapf/src/saugnapf.lisp	Sat Feb  2 17:54:13 2008
@@ -35,7 +35,7 @@
 
 (defmethod authorized-p ((handler saugnapf-track-handler))
   (let* ((track (object-handler-get-object handler))
-	 (user (bknr-request-user))
+	 (user (bknr-session-user))
 	 (action (query-param "action"))
 	 (action-keyword (when action (make-keyword-from-string action))))
     (cond ((anonymous-p user) nil)
@@ -82,7 +82,7 @@
 			      :artist artist
 			      :description description
 			      :url url
-			      :submitter (bknr-request-user)
+			      :submitter (bknr-session-user)
 			      :date (get-universal-time))))
       (redirect (edit-object-url track)))))
 

Modified: branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp	(original)
+++ branches/trunk-reorg/thirdparty/cl+ssl/ffi.lisp	Sat Feb  2 17:54:13 2008
@@ -244,5 +244,6 @@
 (defun reload ()
   (cffi:load-foreign-library 'libssl)
   (cffi:load-foreign-library 'libeay32)
+  (cffi:load-foreign-library 'libcrypto)
   (setf *ssl-global-context* nil)
   (setf *ssl-global-method* nil))

Modified: branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp	(original)
+++ branches/trunk-reorg/thirdparty/cl+ssl/reload.lisp	Sat Feb  2 17:54:13 2008
@@ -27,3 +27,8 @@
   (:windows "libeay32.dll"))
 
 (cffi:use-foreign-library libeay32)
+
+(cffi:define-foreign-library libcrypto
+  #+freebsd (:unix "libcrypto.so"))
+
+(cffi:use-foreign-library libcrypto)
\ No newline at end of file


From hhubner at common-lisp.net  Sat Feb  2 23:30:01 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat,  2 Feb 2008 18:30:01 -0500 (EST)
Subject: [bknr-cvs] r2439 - in branches/trunk-reorg: bknr/web/src
	projects/quickhoney/src
Message-ID: <20080202233001.5720569155@common-lisp.net>

Author: hhubner
Date: Sat Feb  2 18:30:00 2008
New Revision: 2439

Modified:
   branches/trunk-reorg/bknr/web/src/bknr-web.asd
   branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
Log:
Commit smaller fixes before trying a merge from the bos branch


Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd
==============================================================================
--- branches/trunk-reorg/bknr/web/src/bknr-web.asd	(original)
+++ branches/trunk-reorg/bknr/web/src/bknr-web.asd	Sat Feb  2 18:30:00 2008
@@ -22,7 +22,6 @@
     :depends-on (:cl-interpol
 		 :cl-ppcre
 		 :cl-gd
-		 :kmrcl
 		 :alexandria
 		 :md5
 		 :cxml

Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp	Sat Feb  2 18:30:00 2008
@@ -39,7 +39,7 @@
 		       (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler))))
 	#'< :key #'blob-timestamp))
 
-(defmethod image-to-javascript ((image quickhoney-image) &optional stream)
+(defmethod image-to-javascript ((image quickhoney-image))
   (format nil " new parent.ServerImage(~S, ~D, ~S, ~D, ~D, ~S)"
 	  (store-image-name image)
 	  (store-object-id image)


From hhubner at common-lisp.net  Sat Feb  2 23:40:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat,  2 Feb 2008 18:40:28 -0500 (EST)
Subject: [bknr-cvs] r2440 - branches/trunk-reorg/projects/bos
Message-ID: <20080202234028.82597691CB@common-lisp.net>

Author: hhubner
Date: Sat Feb  2 18:40:28 2008
New Revision: 2440

Removed:
   branches/trunk-reorg/projects/bos/
Log:
remove bos projects to do a full fetch from the branch


From hhubner at common-lisp.net  Sat Feb  2 23:43:53 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat,  2 Feb 2008 18:43:53 -0500 (EST)
Subject: [bknr-cvs] r2441 - branches/trunk-reorg/projects/bos
Message-ID: <20080202234353.9C24E69156@common-lisp.net>

Author: hhubner
Date: Sat Feb  2 18:43:53 2008
New Revision: 2441

Added:
   branches/trunk-reorg/projects/bos/
      - copied from r2440, branches/bos/projects/bos/
Log:
copied over bos project from bos branch


From hhubner at common-lisp.net  Tue Feb  5 20:59:13 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Tue,  5 Feb 2008 15:59:13 -0500 (EST)
Subject: [bknr-cvs] r2442 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080205205913.95BF53C0D0@common-lisp.net>

Author: hhubner
Date: Tue Feb  5 15:59:12 2008
New Revision: 2442

Modified:
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
Log:
Dummy commit to check whether update mechanics work.


Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Tue Feb  5 15:59:12 2008
@@ -14,7 +14,7 @@
   <html
    xmlns="http://www.w3.org/1999/xhtml">
    <head>
-    <title>LISP-ECOOP07 - $(title)</title>
+    <title>European Lisp Workshop 2008 - $(title)</title>
     <link rel="stylesheet" type="text/css" href="../static/styles.css" />
     <script src="../static/javascript.js" language="javascript" type="text/javascript"> </script>
    </head>
@@ -62,4 +62,4 @@
  </div>
  </xsl:template>
 
-</xsl:stylesheet>
\ No newline at end of file
+</xsl:stylesheet>


From hhubner at common-lisp.net  Tue Feb  5 21:04:48 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Tue,  5 Feb 2008 16:04:48 -0500 (EST)
Subject: [bknr-cvs] r2443 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080205210448.D8B934D042@common-lisp.net>

Author: hhubner
Date: Tue Feb  5 16:04:47 2008
New Revision: 2443

Modified:
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
Log:
another test checkin

Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Tue Feb  5 16:04:47 2008
@@ -1,6 +1,6 @@
 <?xml version="1.0" encoding="iso-8859-1" ?>
 <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"
- 		xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+ 		xmlns:lisp-ecoop="http://elw.bknr.net/">
 
  <xsl:param name="mode">xml</xsl:param>
 
@@ -21,7 +21,7 @@
    <body>
     <div id="banner">
      <div id="title">4th European Lisp Workshop</div>
-     <div id="subtitle">Co-located with <a href="http://2007.ecoop.org/" target="_new">ECOOP 2007</a><br />July 30 - Berlin - Germany</div>
+     <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 30 - Berlin - Germany</div>
      <div id="logo">
       <a href="http://bknr.net/" target="_new">
        <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" />


From hhubner at common-lisp.net  Tue Feb  5 21:15:54 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Tue,  5 Feb 2008 16:15:54 -0500 (EST)
Subject: [bknr-cvs] r2444 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080205211554.A6C32702FE@common-lisp.net>

Author: hhubner
Date: Tue Feb  5 16:15:52 2008
New Revision: 2444

Modified:
   trunk/projects/lisp-ecoop/website/templates/add-participant.xml
   trunk/projects/lisp-ecoop/website/templates/contact.xml
   trunk/projects/lisp-ecoop/website/templates/create-submission.xml
   trunk/projects/lisp-ecoop/website/templates/edit-profile.xml
   trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml
   trunk/projects/lisp-ecoop/website/templates/edit-submission.xml
   trunk/projects/lisp-ecoop/website/templates/groups.xml
   trunk/projects/lisp-ecoop/website/templates/guidelines.xml
   trunk/projects/lisp-ecoop/website/templates/home.xml
   trunk/projects/lisp-ecoop/website/templates/login.xml
   trunk/projects/lisp-ecoop/website/templates/news.xml
   trunk/projects/lisp-ecoop/website/templates/papers.xml
   trunk/projects/lisp-ecoop/website/templates/people.xml
   trunk/projects/lisp-ecoop/website/templates/profile.xml
   trunk/projects/lisp-ecoop/website/templates/programme.xml
   trunk/projects/lisp-ecoop/website/templates/registration.xml
   trunk/projects/lisp-ecoop/website/templates/schedule.xml
   trunk/projects/lisp-ecoop/website/templates/submission.xml
   trunk/projects/lisp-ecoop/website/templates/submissions.xml
   trunk/projects/lisp-ecoop/website/templates/toplevel.xml
   trunk/projects/lisp-ecoop/website/templates/upload.xml
   trunk/projects/lisp-ecoop/website/templates/user-error.xml
Log:
change namespace url to what we use now

Modified: trunk/projects/lisp-ecoop/website/templates/add-participant.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/add-participant.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/add-participant.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="login"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
  <h1>Add Participant</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/contact.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/contact.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/contact.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="contact"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Organizing Committee</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/create-submission.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/create-submission.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/create-submission.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
  <head>
   <title>Create submission</title>
   <link rel="stylesheet" type="text/css" href="/static/document-utils.css" />

Modified: trunk/projects/lisp-ecoop/website/templates/edit-profile.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/edit-profile.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/edit-profile.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <lisp-ecoop:page name="edit profile"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Participant Profile Editor</h1>
 <p>

Modified: trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/edit-submission-submitters.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
  <head>
   <title>Edit Submitter List</title>
  </head>

Modified: trunk/projects/lisp-ecoop/website/templates/edit-submission.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/edit-submission.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/edit-submission.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <lisp-ecoop:page name="edit submission"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Submission Editor</h1>
 <p>

Modified: trunk/projects/lisp-ecoop/website/templates/groups.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/groups.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/groups.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="groups"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Breakout Groups</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/guidelines.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/guidelines.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/guidelines.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="guidelines"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Submission Guidelines</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/home.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/home.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/home.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="home"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>4th European Lisp Workshop</h1>
 
@@ -12,7 +12,7 @@
 <h2>Important News</h2>
 <ul>
 <li>The workshop programme is now online.</li>
-<li><a href="http://lisp-ecoop07.bknr.net/profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
+<li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
 </ul>
 
 <h2>Important Dates</h2>

Modified: trunk/projects/lisp-ecoop/website/templates/login.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/login.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/login.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="login"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
  <h1>Login</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/news.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/news.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/news.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="news"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>News</h1>
 
@@ -14,7 +14,7 @@
 <h3>May 17, 2007</h3>
 
 <ul>
-<li><a href="http://lisp-ecoop07.bknr.net/profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
+<li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
 <li>The submission deadline for papers, essays and breakout group proposals has been extended to May 31.</li>
 </ul>
 

Modified: trunk/projects/lisp-ecoop/website/templates/papers.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/papers.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/papers.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="papers"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Papers</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/people.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/people.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/people.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="people"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>People</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/profile.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/profile.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/profile.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <lisp-ecoop:page name="participant profile"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <lisp-ecoop:profile>
   <h1>Participant Profile</h1>

Modified: trunk/projects/lisp-ecoop/website/templates/programme.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/programme.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/programme.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="programme"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Workshop Programme</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/registration.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/registration.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/registration.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="registration"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Registration</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/schedule.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/schedule.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/schedule.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="schedule"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
   <lisp-ecoop:admin-only>
     <lisp-ecoop:schedule-submission />

Modified: trunk/projects/lisp-ecoop/website/templates/submission.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/submission.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/submission.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <lisp-ecoop:page name="submission"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <lisp-ecoop:load-argument-object>
   <h1>$(title)</h1>

Modified: trunk/projects/lisp-ecoop/website/templates/submissions.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/submissions.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/submissions.xml	Tue Feb  5 16:15:52 2008
@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <?xml-stylesheet type="text/xsl" href="lisp-ecoop.xsl" ?>
 <lisp-ecoop:page name="submissions"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
 
 <h1>Submissions</h1>
 

Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/toplevel.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml	Tue Feb  5 16:15:52 2008
@@ -3,7 +3,7 @@
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html
   xmlns="http://www.w3.org/1999/xhtml"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"
+  xmlns:lisp-ecoop="http://elw.bknr.net/"
   xmlns:bknr="http://bknr.net"
   xmlns:menu="http://bknr.net/menu"
   >

Modified: trunk/projects/lisp-ecoop/website/templates/upload.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/upload.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/upload.xml	Tue Feb  5 16:15:52 2008
@@ -2,7 +2,7 @@
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 <html
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net">
+  xmlns:lisp-ecoop="http://elw.bknr.net/">
  <head>
   <title>Upload document</title>
   <link rel="stylesheet" type="text/css" href="/static/document-utils.css" />

Modified: trunk/projects/lisp-ecoop/website/templates/user-error.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/user-error.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/user-error.xml	Tue Feb  5 16:15:52 2008
@@ -4,7 +4,7 @@
 <html
   xmlns="http://www.w3.org/1999/xhtml"
   xmlns:bknr="http://bknr.net"
-  xmlns:lisp-ecoop="http://lisp-ecoop07.bknr.net"
+  xmlns:lisp-ecoop="http://elw.bknr.net/"
   xmlns:menu="http://bknr.net/menu"
   >
  <head>


From dverna at common-lisp.net  Wed Feb  6 11:29:31 2008
From: dverna at common-lisp.net (dverna at common-lisp.net)
Date: Wed,  6 Feb 2008 06:29:31 -0500 (EST)
Subject: [bknr-cvs] r2445 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080206112931.E318B49024@common-lisp.net>

Author: dverna
Date: Wed Feb  6 06:29:25 2008
New Revision: 2445

Modified:
   trunk/projects/lisp-ecoop/website/templates/contact.xml
   trunk/projects/lisp-ecoop/website/templates/home.xml
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
   trunk/projects/lisp-ecoop/website/templates/news.xml
   trunk/projects/lisp-ecoop/website/templates/people.xml
   trunk/projects/lisp-ecoop/website/templates/programme.xml
   trunk/projects/lisp-ecoop/website/templates/submissions.xml
   trunk/projects/lisp-ecoop/website/templates/toplevel.xml
Log:
First shot at the 2008 website

Modified: trunk/projects/lisp-ecoop/website/templates/contact.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/contact.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/contact.xml	Wed Feb  6 06:29:25 2008
@@ -9,27 +9,35 @@
 
 <ul>
 
-<li>Pascal Costanza, <a
-href="http://p-cos.net">http://p-cos.net</a>,
-Vrije Universiteit Brussel, Belgium (contact organizer)</li>
-
-<li>Theo D'Hondt, <a
-href="http://prog.vub.ac.be/~tjdhondt">http://prog.vub.ac.be/~tjdhondt</a>,
-Vrije Universiteit Brussel, Belgium</li>
+<li>
+Didier Verna,
+<a href="http://www.lrde.epita.fr/~didier">
+http://www.lrde.epita.fr/~didier
+</a>,
+EPITA Research and Development Laboratory, Paris, France (contact organizer)
+</li>
+<li>
+Charlotte Herzeel, Programming Technology Lab, Vrije Universiteit, Brussel,
+Belgium
+</li>
+<li>
+Christophe Rhodes,
+<a href="http://www.doc.gold.ac.uk/~mas01cr/">
+http://www.doc.gold.ac.uk/~mas01cr/
+</a>,
+Goldsmiths College, University of London, United Kingdom
+</li>
 
 <li>Hans H?bner, Software Developer, Berlin, Germany</li>
 
-<li>Arthur Lemmens, Independent Consultant, Amsterdam, The
-Netherlands</li>
-
-<li>Christophe Rhodes, <a
-href="http://www.doc.gold.ac.uk/~mas01cr/">http://www.doc.gold.ac.uk/~mas01cr/</a>,
-Goldsmiths College, University of London, United Kingdom</li>
 
 </ul>
 
  <h1>Contact</h1>
- <p>Workshop related: <a href="mailto:pc at p-cos.net">Pascal Costanza</a></p>
+ <p>
+    Workshop related:
+    <a href="mailto:didier at lrde.epita.fr">Didier Verna</a>
+ </p>
  <p>Website related: <a href="mailto:hans at bknr.net">Hans H?bner</a></p>
 
 </lisp-ecoop:page>

Modified: trunk/projects/lisp-ecoop/website/templates/home.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/home.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/home.xml	Wed Feb  6 06:29:25 2008
@@ -3,71 +3,86 @@
 <lisp-ecoop:page name="home"
   xmlns:lisp-ecoop="http://elw.bknr.net/">
 
-<h1>4th European Lisp Workshop</h1>
+<h1>5th European Lisp Workshop</h1>
 
-<p>July 30 - Berlin, Germany - co-located with ECOOP 2007</p>
+<p>July 07 - Paphos-Cyprus - co-located with ECOOP 2008</p>
 
-<p>Supported by <a href="http://clozure.com/" target="_new">Clozure Associates</a></p>
+<p>
+<!-- Supported by <a href="http://clozure.com/" target="_new">Clozure
+     Associates</a> -->
+</p>
 
+<!--
 <h2>Important News</h2>
 <ul>
 <li>The workshop programme is now online.</li>
-<li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
+<li>
+<a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be
+giving a keynote presentation about <a
+href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game
+AI to Massively Parallel Architectures using Collaborative Diffusion</a>.
+</li>
 </ul>
+-->
 
 <h2>Important Dates</h2>
 <ul>
-<li>Submission deadline: <b>May 31, 2007</b></li>
-<li>Notification of acceptance: <b>June 8, 2007</b></li>
-<li>ECOOP early registration deadline: <b>June 15, 2007</b></li>
+<li>Submission deadline: <b>May 18, 2008</b></li>
+<li>Notification of acceptance: <b>June 08, 2008</b></li>
+<li>ECOOP early registration deadline: <b>June 15, 2008</b></li>
 </ul>
 
 <h2>Overview</h2>
 
 <blockquote>
-...Please don't assume Lisp is only useful for Animation and Graphics,
-AI, Bioinformatics, B2B and E-Commerce, Data Mining, EDA/Semiconductor
+...Please don't assume Lisp is only useful for Animation and Graphics, AI,
+Bioinformatics, B2B and E-Commerce, Data Mining, EDA/Semiconductor
 applications, Expert Systems, Finance, Intelligent Agents, Knowledge
 Management, Mechanical CAD, Modeling and Simulation, Natural Language,
-Optimization, Research, Risk Analysis, Scheduling, Telecom, and Web
-Authoring just because these are the only things they happened to
-list.  -- Kent Pitman
+Optimization, Research, Risk Analysis, Scheduling, Telecom, and Web Authoring
+just because these are the only things they happened to list. -- Kent Pitman
 </blockquote>
 
-<p>Lisp is one of the oldest computer languages still in use today. In
-the decades of its existence, Lisp has been a fruitful basis for
-language design experiments as well as the preferred implementation
-language for applications in diverse fields.</p>
-
-<p>The structure of Lisp makes it easy to extend the language or even to
-implement entirely new dialects without starting from scratch. Common
-Lisp, with the Common Lisp Object System (CLOS), was the first
-object-oriented programming language to receive an ANSI standard and
-retains the most complete and advanced object system of any
-programming language, while influencing many other object-oriented
-programming languages that followed.</p>
-
-<p>It is clear that Lisp is gaining momentum: there is a
-steadily growing interest in Lisp itself, with numerous user groups
-in existence worldwide, and in Lisp's metaprogramming notions
-which are being transferred to other languages, as
-for example in Aspect-Oriented Programming, support for
-Domain-Specific Languages, and so on.</p>
-
-<p>This workshop will address the near-future role of Lisp-based
-languages in research, industry and education. We solicit
-papers and suggestions for breakout groups that discuss the
-opportunities Lisp provides to capture and enhance the possibilities
-in software engineering. We want to promote lively discussion
-between researchers proposing new approaches and practitioners
-reporting on their experience with the strengths and limitations of
-current Lisp technologies.</p>
-
-<p>The workshop will have two components; there will
-be formally-presented talks, and breakout groups
-discussing or working on particular topics.  Additionally, there
-will be opportunities for short, informal talks and demonstrations on
-experience reports, underappreciated results, software under
-development, or other topics of interest.</p>
+<p>
+Lisp is one of the oldest computer languages still in use today. In the
+decades of its existence, Lisp has been a fruitful basis for language design
+experiments as well as the preferred implementation language for applications
+in diverse fields.
+</p>
+
+<p>
+The structure of Lisp makes it easy to extend the language or even to
+implement entirely new dialects without starting from scratch. Common Lisp,
+with the Common Lisp Object System (CLOS), was the first object-oriented
+programming language to receive an ANSI standard and retains the most complete
+and advanced object system of any programming language, while influencing many
+other object-oriented programming languages that followed.
+</p>
+
+<p>
+It is clear that Lisp is gaining momentum: there is a steadily growing
+interest in Lisp itself, with numerous user groups in existence worldwide, and
+in Lisp's metaprogramming notions which are being transferred to other
+languages, as for example in Aspect-Oriented Programming, support for
+Domain-Specific Languages, and so on.
+</p>
+
+<p>
+This workshop will address the near-future role of Lisp-based languages in
+research, industry and education. We solicit papers and suggestions for
+breakout groups that discuss the opportunities Lisp provides to capture and
+enhance the possibilities in software engineering. We want to promote lively
+discussion between researchers proposing new approaches and practitioners
+reporting on their experience with the strengths and limitations of current
+Lisp technologies.
+</p>
+
+<p>
+The workshop will have two components; there will be formally-presented talks,
+and breakout groups discussing or working on particular topics. Additionally,
+there will be opportunities for short, informal talks and demonstrations on
+experience reports, underappreciated results, software under development, or
+other topics of interest.
+</p>
 
 </lisp-ecoop:page>

Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Wed Feb  6 06:29:25 2008
@@ -20,8 +20,8 @@
    </head>
    <body>
     <div id="banner">
-     <div id="title">4th European Lisp Workshop</div>
-     <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 30 - Berlin - Germany</div>
+     <div id="title">5th European Lisp Workshop</div>
+     <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div>
      <div id="logo">
       <a href="http://bknr.net/" target="_new">
        <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" />

Modified: trunk/projects/lisp-ecoop/website/templates/news.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/news.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/news.xml	Wed Feb  6 06:29:25 2008
@@ -5,6 +5,7 @@
 
 <h1>News</h1>
 
+<!--
 <h3>July 4, 2007</h3>
 
 <ul>
@@ -17,8 +18,9 @@
 <li><a href="http://elw.bknr.net//profile/5802">Alexander Repenning</a> will be giving a keynote presentation about <a href="http://lisp-ecoop07.bknr.net/submission/5881">Antiobjects: Mapping Game AI to Massively Parallel Architectures using Collaborative Diffusion</a>.</li>
 <li>The submission deadline for papers, essays and breakout group proposals has been extended to May 31.</li>
 </ul>
+-->
 
-<h3>March 30, 2007</h3>
+<h3>February 06, 2008</h3>
 
 <ul>
 <li>Launched the workshop website.</li>

Modified: trunk/projects/lisp-ecoop/website/templates/people.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/people.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/people.xml	Wed Feb  6 06:29:25 2008
@@ -5,8 +5,10 @@
 
 <h1>People</h1>
 
-<p>The following people have registered to the workshop.  Please click
-on a person's name to get further information</p>
+<p>
+The following people have registered to the workshop. Please click on a
+person's name to get further information.
+</p>
 
  <lisp-ecoop:participant-list />
 

Modified: trunk/projects/lisp-ecoop/website/templates/programme.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/programme.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/programme.xml	Wed Feb  6 06:29:25 2008
@@ -5,6 +5,9 @@
 
 <h1>Workshop Programme</h1>
 
+The programme will be available by the end of June.
+
+<!--
 <h3>9:00 - 10:30</h3>
 
 <ul>
@@ -43,7 +46,7 @@
 <ul>
   <li>Coffee break</li>
 </ul>
-  
+
 <h3>16:00 - 18:00</h3>
 
 <ul>
@@ -51,5 +54,6 @@
   <li>Pascal Costanza, Robert Hirschfeld, "Recent Developments in ContextL and Context-oriented Programming"</li>
   <li>Wrap Up</li>
 </ul>
+-->
 
 </lisp-ecoop:page>

Modified: trunk/projects/lisp-ecoop/website/templates/submissions.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/submissions.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/submissions.xml	Wed Feb  6 06:29:25 2008
@@ -5,7 +5,9 @@
 
 <h1>Submissions</h1>
 
-<p>We have accepted the following submissions.</p>
+<!-- <p>We have accepted the following submissions.</p> -->
+
+The list of accepted submissions will be available by the end of June.
 
 <h2>Papers</h2>
 <lisp-ecoop:submission-list type="paper"/>

Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/toplevel.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml	Wed Feb  6 06:29:25 2008
@@ -8,43 +8,43 @@
   xmlns:menu="http://bknr.net/menu"
   >
   <head>
-    <title>LISP-ECOOP07 - $(title)</title>
+    <title>LISP-ECOOP08 - $(title)</title>
     <link rel="stylesheet" type="text/css" href="$(base)static/styles.css" />
     <script src="$(base)static/javascript.js" language="javascript" type="text/javascript"> </script>
   </head>
 
   <body>
     <div id="banner">
-      <div id="title">4th European Lisp Workshop</div>
-      <div id="subtitle">Co-located with <a href="http://2007.ecoop.org/" target="_new">ECOOP 2007</a><br />July 30 - Berlin - Germany</div>
+      <div id="title">5th European Lisp Workshop</div>
+      <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div>
       <div id="logo">
-        <a href="http://bknr.net/" target="_new">
+	<a href="http://bknr.net/" target="_new">
 	  <img width="57" height="20" alt="BKNR Logo" src="$(base)image/bknr-logo/thumbnail,,57,20" border="0" />
 	</a>
       </div>
     </div>
     <div id="body">
       <div id="system-column">
-        <menu:site-menu config="menu.xml"
-	                menu-name="main"
+	<menu:site-menu config="menu.xml"
+			menu-name="main"
 			container-class="site-menu"
-	                active-class="site-menu-active"
-		        inactive-class="site-menu-inactive" />
-        <lisp-ecoop:admin-only>
-         <menu:site-menu config="admin-menu.xml"
-                         menu-name="admin"
-                         title="Admin"
+			active-class="site-menu-active"
+			inactive-class="site-menu-inactive" />
+	<lisp-ecoop:admin-only>
+	 <menu:site-menu config="admin-menu.xml"
+			 menu-name="admin"
+			 title="Admin"
 			 container-class="site-menu"
-	                 active-class="site-menu-active"
-		         inactive-class="site-menu-inactive" />
-        </lisp-ecoop:admin-only>
-        <div id="login">
-          <lisp-ecoop:login-widget />
-        </div>
+			 active-class="site-menu-active"
+			 inactive-class="site-menu-inactive" />
+	</lisp-ecoop:admin-only>
+	<div id="login">
+	  <lisp-ecoop:login-widget />
+	</div>
       </div>
       <div id="content">
-        <bknr:tag-body />
-        <hr class="content-rule"/>
+	<bknr:tag-body />
+	<hr class="content-rule"/>
       </div>
     </div>
   </body>


From hhubner at common-lisp.net  Wed Feb  6 11:37:35 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed,  6 Feb 2008 06:37:35 -0500 (EST)
Subject: [bknr-cvs] r2446 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080206113735.CB1617323A@common-lisp.net>

Author: hhubner
Date: Wed Feb  6 06:37:33 2008
New Revision: 2446

Modified:
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
Log:
Change path to logo.


Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Wed Feb  6 06:37:33 2008
@@ -24,7 +24,7 @@
      <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div>
      <div id="logo">
       <a href="http://bknr.net/" target="_new">
-       <img width="57" height="20" alt="BKNR Logo" src="/image/bknr-logo/thumbnail,,57,20" border="0" />
+       <img width="57" height="20" alt="BKNR Logo" src="/static/bknr-logo.png" border="0" />
       </a>
      </div>
     </div>


From hhubner at common-lisp.net  Wed Feb  6 12:08:45 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed,  6 Feb 2008 07:08:45 -0500 (EST)
Subject: [bknr-cvs] r2447 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080206120845.C2A9C340A4@common-lisp.net>

Author: hhubner
Date: Wed Feb  6 07:08:44 2008
New Revision: 2447

Modified:
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
   trunk/projects/lisp-ecoop/website/templates/toplevel.xml
Log:
Add Google Analytics tracking to site.


Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Wed Feb  6 07:08:44 2008
@@ -38,6 +38,15 @@
       <xsl:copy-of select="." />
      </div>
     </div>
+<script type="text/javascript">
+var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
+document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
+</script>
+<script type="text/javascript">
+var pageTracker = _gat._getTracker("UA-3432041-2");
+pageTracker._initData();
+pageTracker._trackPageview();
+</script>
    </body>
   </html>
  </xsl:template>

Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/toplevel.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml	Wed Feb  6 07:08:44 2008
@@ -47,5 +47,14 @@
 	<hr class="content-rule"/>
       </div>
     </div>
+<script type="text/javascript">
+var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
+document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
+</script>
+<script type="text/javascript">
+var pageTracker = _gat._getTracker("UA-3432041-2");
+pageTracker._initData();
+pageTracker._trackPageview();
+</script>
   </body>
 </html>


From hhubner at common-lisp.net  Wed Feb  6 13:55:34 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed,  6 Feb 2008 08:55:34 -0500 (EST)
Subject: [bknr-cvs] r2448 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080206135534.88E017A029@common-lisp.net>

Author: hhubner
Date: Wed Feb  6 08:55:33 2008
New Revision: 2448

Modified:
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
   trunk/projects/lisp-ecoop/website/templates/toplevel.xml
Log:
Add link to top-level ELW directory


Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Wed Feb  6 08:55:33 2008
@@ -33,6 +33,11 @@
       <xsl:call-template name="menu">
        <xsl:with-param name="current" select="@name"/>
       </xsl:call-template>
+      <div class="site-menu">
+       <div class="site-menu-inactive">
+        <a href="/">ELW Home</a>
+       </div>
+      </div>
      </div>
      <div id="content">
       <xsl:copy-of select="." />

Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/toplevel.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml	Wed Feb  6 08:55:33 2008
@@ -41,6 +41,11 @@
 	<div id="login">
 	  <lisp-ecoop:login-widget />
 	</div>
+        <div class="site-menu">
+          <div class="site-menu-inactive">
+            <a href="/">ELW Home</a>
+          </div>
+        </div>
       </div>
       <div id="content">
 	<bknr:tag-body />


From hhubner at common-lisp.net  Thu Feb  7 08:16:34 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu,  7 Feb 2008 03:16:34 -0500 (EST)
Subject: [bknr-cvs] r2449 - in branches/trunk-reorg/thirdparty:
	hunchentoot-0.14.7 hunchentoot-0.15.0 hunchentoot-0.15.0/doc
	hunchentoot-0.15.0/test
Message-ID: <20080207081634.ED7591203D@common-lisp.net>

Author: hhubner
Date: Thu Feb  7 03:16:29 2008
New Revision: 2449

Added:
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/hunchentoot.gif   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/favicon.ico   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/fz.jpg   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp   (contents, props changed)
Removed:
   branches/trunk-reorg/thirdparty/hunchentoot-0.14.7/
Log:
update hunchentoot

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,281 @@
+Version 0.15.0
+2007-12-29
+Added support for CLISP (thanks to Anton Vodonosov)
+
+Version 0.14.7
+2007-11-15
+Replace ENOUGH-NAMESTRING with ENOUGH-URL (patch by Kilian Sprotte and Hans H?bner)
+
+Version 0.14.6
+2007-11-08
+Fix compilation order (thanks to Tiarnan O'Corrain and Chris Dean)
+
+Version 0.14.5
+2007-10-21
+Robustified MAKE-SOCKET-STREAM against potential leak (thanks to Alain Picard)
+Replaced #-FOO #-FOO constructs for OpenMCL (patch by Michael Weber)
+Updated tutorial links
+
+Version 0.14.4
+2007-10-20
+Made log stream shared on OpenMCL (thanks to Gary Byers)	
+
+Version 0.14.3
+2007-10-07
+Enabled GET-GID-FROM-NAME for newer versions of SBCL (patch by Cyrus Harmon)
+
+Version 0.14.2
+2007-09-26
+Better handling of PORT parameter in REDIRECT (thanks to Vladimir Sedach)	
+
+Version 0.14.1
+2007-09-24
+Fixed bug where you couldn't set "Server" header (caught by Ralf Mattes)
+Documentation clarification for HEADER-OUR function	
+
+Version 0.14.0
+2007-09-18
+Added support for "HttpOnly" cookie attribute
+
+Version 0.13.0
+2007-09-14
+Added *METHODS-FOR-POST-PARAMETERS* (suggested by Jonathon McKitrick)
+
+Version 0.12.1
+2007-09-13
+Better support for WITH-TIMEOUT on SBCL/Win32 (thanks to Anton Vodonosov)	
+	
+Version 0.12.0
+2007-09-07
+Now uses bound for flexi stream returned by RAW-POST-DATA
+Needs FLEXI-STREAMS 0.12.0 or higher	
+
+Version 0.11.2
+2007-09-05
+Fixed typo in docs
+Added declaration in server.lisp to appease SBCL
+
+Version 0.11.1
+2007-05-25
+Fixes for OpenMCL (thanks to Lennart Staflin and Tiarnan O'Corrain)
+	
+Version 0.11.0
+2007-05-25
+Added server names and coupled them with easy handlers (suggested by Mac Chan)
+Exported SESSION-COOKIE-VALUE instead of SESSION-STRING (suggested by Slava Akhmechet)
+Documentation fixes (thanks to Victor Kryukov and Igor Plekhov)
+
+Version 0.10.0
+2007-05-12
+Made MAYBE-INVOKE-DEBUGGER a generic function and exported it (suggested by Vladimir Sedach)
+
+Version 0.9.3
+2007-05-08
+Fixed CREATE-FOLDER-DISPATCHER-AND-HANDLER in the presence of URL-encoded URLs (bug caught by Nicolas Lamirault)
+
+Version 0.9.2
+2007-05-01
+Made DEF-HTTP-RETURN-CODE more flexible (suggested by Jong-won Choi)
+
+Version 0.9.1
+2007-04-29
+Added PORT parameter to REDIRECT (suggested by Cyrus Harmon)
+Exported REMOVE-SESSION (suggested by Vamsee Kanakala)	
+
+Version 0.9.0
+2007-04-19
+Added socket timeouts for AllegroCL
+Catch IO timeout conditions for AllegroCL, SBCL and CMUCL (suggested by Red Daly and others)
+Added per-server dispatch tables (suggested by Robert Synnott and Andrei Stebakov)
+
+Version 0.8.6
+2007-04-18
+USE the CL package explicitly when defining HUNCHENTOOT-MP (bug report by Joel Boehland)
+
+Version 0.8.5
+2007-04-10
+Correct behaviour for "100 Continue" responses
+
+Version 0.8.4
+2007-04-09
+Cleanup
+
+Version 0.8.3
+2007-04-07
+Don't use chunked encoding for empty (NIL) bodies
+
+Version 0.8.2
+2007-04-05
+Really exported REASON-PHRASE this time (and also *CURRENT-PROCESS*)
+
+Version 0.8.1
+2007-04-04
+Added HUNCHENTOOT-MP package (suggested by Cyrus Harmon)
+Only invoke MARK-AND-SWEEP for 32-bit versions of LW (thanks to Chris Dean)
+Exported REASON-PHRASE
+
+Version 0.8.0
+2007-03-31
+Added *APPROVED-RETURN-CODES*, *HEADER-STREAM*, and +HTTP-FAILED-DEPENDENCY+
+Exported MIME-TYPE and SSL-P
+Some minor changes
+
+Version 0.7.3
+2007-03-28
+Added +HTTP-MULTI-STATUS+
+
+Version 0.7.2
+2007-03-09
+Fix test suite to properly handle non-base characters in LW (bug caught by Jong-won Choi)
+
+Version 0.7.1
+2007-03-09
+Fixed last change (thanks to Marko Kocic)
+
+Version 0.7.0
+2007-03-09
+Development port (no threads) to SBCL/Win32 (patch by Marko Kocic)
+Support for compilation without SSL	
+
+Version 0.6.2
+2007-02-22
+Don't use NSTRING-UPCASE for outgoing headers (bug caught by Saurabh Nanda)
+Changed ProxyPass example in docs from /lisp to /hunchentoot	
+
+Version 0.6.1
+2007-01-24
+Reset to "faithful" external format on each iteration (bug caught by Viljo Marrandi and Ury Marshak)
+
+Version 0.6.0
+2007-01-23
+Accept chunked transfer encoding for mod_lisp request bodies (thanks to Hugh Winkler's mod_lisp additions)
+Robustify against erroneous form-data submissions (caught by Ury Marshak)
+
+Version 0.5.1
+2007-01-18
+Even more flexible behaviour of RAW-POST-DATA
+
+Version 0.5.0
+2007-01-17
+More flexible behaviour of RAW-POST-DATA
+Robustified PARSE-CONTENT-TYPE
+
+Version 0.4.14
+2007-01-17
+More meaningful results for RAW-POST-DATA
+
+Version 0.4.13
+2007-01-14
+Added favicon.ico to example website (thanks to Yoni Rabkin Katzenell, Toby, and Uwe von Loh)
+
+Version 0.4.12
+2006-12-27
+Added Hunchentoot logo by Uwe von Loh
+
+Version 0.4.11
+2006-12-01
+Exported symbols related to session GC (suggested by Nico de Jager)
+
+Version 0.4.10
+2006-11-19
+Added *HANDLE-HTTP-ERRORS-P* (thanks to Marijn Haverbeke)
+Remove duplicate headers when reading from mod_lisp
+
+Version 0.4.9
+2006-11-12
+Fixed HEADER-OUT (thanks to Robert J. Macomber)
+
+Version 0.4.8
+2006-11-06
+Fixed bug in START-OUTPUT which confused mod_lisp
+
+Version 0.4.7
+2006-11-06
+Changed behaviour of REAL-REMOTE-ADDR (as suggested by Robert J. Macomber)
+Fixed COOKIE-OUT (thanks to Robert J. Macomber)	
+
+Version 0.4.6
+2006-11-05
+Don't bind *DISPATCH-TABLE* too early (thanks to Marijn Haverbeke)
+
+Version 0.4.5
+2006-10-25
+Fixed bug in AUTHORIZATION function (reported by Michael J. Forster)
+
+Version 0.4.4
+2006-10-12
+Correct SSL check in REDIRECT function
+LOG-MESSAGE now checks for (BOUNDP '*SERVER*)
+
+Version 0.4.3
+2006-10-11
+OpenMCL fixes (by Ralf Stoye)
+	
+Version 0.4.2
+2006-10-10
+No timeouts for mod_lisp servers (as in Hunchentoot 0.3.x)
+
+Version 0.4.1
+2006-10-10
+Fixed a typo in easy-handlers.lisp (caught by Travis Cross)
+
+Version 0.4.0
+2006-10-10
+Ported to CMUCL, SBCL, OpenMCL, and AllegroCL
+Merged with TBNL	
+Tons of small changes, too many to list them individually	
+
+Version 0.3.2
+2006-09-14
+Uses TBNL's WITH-DEBUGGER now
+
+Version 0.3.1
+2006-09-14
+Added *CATCH-ERRORS-P* (from TBNL)
+
+Version 0.3.0
+2006-09-05
+Accept HTTP requests with chunked transfer encoding
+Use Chunga for chunking
+
+Version 0.2.2
+2006-08-31
+Skip START-OUTPUT advice completely if working for TBNL	
+
+Version 0.2.1
+2006-08-28
+Added write timeouts for LW 5.0
+Updated LW links in documentation	
+
+Version 0.2.0
+2006-08-28
+Serves as infrastructure for TBNL now (to replace KMRCL)
+For HTTP/1.1 only send 'Keep-Alive' headers if explicitly requested	
+
+Version 0.1.5
+2006-08-23
+Connection headers are separated by commas, not semicolons
+
+Version 0.1.4
+2006-08-22
+Refactored streams.lisp to appease LW compiler (thanks to Martin Simmons)
+Changed handling of version string	
+Changed package handling in system definition (thanks to Christophe Rhodes)	
+
+Version 0.1.3
+2006-02-08
+Removed KMRCL workaround
+
+Version 0.1.2
+2006-01-03
+Mention TBNL version number in server name header
+
+Version 0.1.1
+2005-12-31
+Fixed package stuff and HYPERDOC support
+
+Version 0.1.0
+2005-12-31
+Initial public release
+	
+[For earlier changes see the file "CHANGELOG_TBNL" that is included with the release.]

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/CHANGELOG_TBNL	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,340 @@
+Version 0.11.3
+2006-09-30
+Added *FILE-UPLOAD-HOOK* (suggested by Erik Enge)
+Fixed DEFINE-EASY-HANDLER for cases where URI is NIL	
+	
+Version 0.11.2
+2006-09-20
+DEFINE-EASY-HANDLER: fixed and clarified redefinition
+DEFINE-EASY-HANDLER: allow for functions designators as "URIs"
+DEFINE-EASY-HANDLER: take file uploads into account
+Made logging a little bit more robust
+Added mime type for XSL-FO (.fo)
+
+Version 0.11.1
+2006-09-14
+Cleaner implementation of *CATCH-ERRORS-P*
+
+Version 0.11.0
+2006-09-14
+Added *CATCH-ERRORS-P*
+
+Version 0.10.3
+2006-09-05
+Appease SBCL (thanks to Juho Snellman)	
+
+Version 0.10.2
+2006-09-05
+Better reporting of IP addresses and ports if not behind mod_lisp
+Improved logging
+Fixed REAL-REMOTE-ADDR
+Cookies always use UTF-8 encoding (which is opaque to the client anyway)	
+Read request bodies without 'Content-Length' header (for Hunchentoot)
+Removed accented character from test.lisp to appease SBCL (reported by Xristos Kalkanis)
+
+Version 0.10.1
+2006-08-31
+Only LispWorks: Set read timeout to NIL if connected to mod_lisp	
+
+Version 0.10.0
+2006-08-28
+Based LispWorks version of TBNL on Hunchentoot infrastructure
+Added "easy" handlers
+Exported GET-BACKTRACE (suggested by Erik Enge)
+	
+Version 0.9.11
+2006-08-16
+Added note about SBCL problems
+
+Version 0.9.10
+2006-05-24
+Prepare for LW 5.0 release
+
+Version 0.9.9
+2006-05-12
+Workaround for something like "application/x-www-form-urlencoded;charset=UTF-8" (caught by John Bates)
+
+Version 0.9.8
+2006-04-25
+For mod_lisp, Lisp-Content-Length header must be sent after Content-Length header
+
+Version 0.9.7
+2006-02-06
+More robust computation of content length
+
+Version 0.9.6
+2006-01-22
+Added the missing piece (argh!)
+
+Version 0.9.5
+2006-01-22
+Made creation of REQUEST object safer (thanks to Robert J. Macomber)
+Replaced some erroneous DECLAIMs with DECLAREs (thanks to SBCL's style warnings)
+Slight documentation enhancements
+
+Version 0.9.4
+2006-01-03
+Handle "Expect: 100-continue" for non-Apache front-ends
+Re-introduced IGNORE-ERRORS in GET-REQUEST-DATA
+
+Version 0.9.3
+2006-01-01
+Fixed bug in READ-HTTP-REQUEST
+
+Version 0.9.2
+2005-12-31
+Protocol of reply is HTTP/1.1 now
+Made HTTP/0.9 default protocol of request if none was provided
+Some preparations for Hunchentoot
+Various minor changes
+Small fixes in docs
+
+Version 0.9.1
+2005-12-25
+Added missing file mime-types.lisp (thanks to Hilverd Reker)
+
+Version 0.9.0
+2005-12-24
+Experimental support for writing directly to the front-end (see SEND-HEADERS)
+Added HANDLE-STATIC-FILE
+Changed CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER to use new facilities
+Added CREATE-FOLDER-DISPATCHER-AND-HANDLER
+Added link to Travis Cross' message w.r.t. SBCL
+
+Version 0.8.9
+2005-12-16
+Also use :TBNL-BIVALENT-STREAMS if :SB-UNICODE is present
+
+Version 0.8.8
+2005-12-08
+Made RAW-POST-DATA more useful
+Updated docs w.r.t. Araneida (thanks to Alan Shields)
+
+Version 0.8.7
+2005-11-29
+Made "Content-Length" header SETFable
+
+Version 0.8.6
+2005-11-18
+Restored original stream-based code for multipart/form-data parsing (got lost somehow)
+Wrapped REMOTE-ADDR with IGNORE-ERRORS (just in case)
+
+Version 0.8.5
+2005-11-14
+Added generic function DISPATCH-REQUEST (thanks to Jeff Caldwell)
+
+Version 0.8.4
+2005-10-21
+Provide REMOTE-ADDR if connected directly (for LispWorks and AllegroCL)
+Show remote user and address (if available) in non-Apache logs
+Mention Debian package in docs
+
+Version 0.8.3
+2005-10-10
+Alert LW users that a patch for OCTETS-TO-STRINGS is available (thanks to LispWorks support)
+
+Version 0.8.2
+2005-10-06
+Make STRING-TO-OCTETS and OCTETS-TO-STRING safer for LW
+
+Version 0.8.1
+2005-09-29
+Bugfix in CMUCL version of STRING-TO-OCTETS
+
+Version 0.8.0
+2005-09-24
+Added the ability to cope with different external formats (incorporating suggestions from Will Glozer and Ivan Shvedunov)
+Raw post data is now always saved (so *SAVE-RAW-POST-DATA-P* is gone)
+
+Version 0.7.0
+2005-09-17
+Added the ability to store arbitrary data within REQUEST objects (suggested by Zach Beane)
+Fixed handling of *HTTP-ERROR-HANDLER*
+Note: *TBNL-VERSION* was wrong in 0.6.0 and 0.6.1
+
+Version 0.6.1
+2005-09-10
+Robustified socket handling code
+
+Version 0.6.0
+2005-09-08
+Added TBNL-CONTRIB package
+Added contrib directory with first entry (from Alceste Scalas)
+Updated link to Bill Clementson's blog
+Don't redefine what's already there (for LispWorks)
+
+Version 0.5.5
+2005-04-18
+Make RFC 2388 code an external dependency (thanks to Janis Dzerins)
+
+Version 0.5.4
+2005-04-03
+Fixed dumb typo (caught by Bob Hutchison)
+
+Version 0.5.3
+2005-04-03
+Re-introduced automatic front-end selection (originally by Bob Hutchison)
+
+Version 0.5.2
+2005-03-26
+Fixed bug in modlisp.html where *CLOSE-TBNL-STREAM* could be NIL although it should be T
+Set correct content type for 304 replies
+
+Version 0.5.1
+2005-03-17
+Changed default cookie path in START-SESSION (suggested by Stefan Scholl)
+Small bugfixes
+More headers from the Araneida front-end
+Added *SHOW-ACCESS-LOG-MESSAGES*
+Changed "back-end" to "front-end" :)
+
+Version 0.5.0
+2005-03-17
+Initial support for "stand-alone" version (no front-end) (supplied by Bob Hutchison)
+New logging API
+Fixes in START-TBNL/STOP-TBNL
+Documentation enhancements
+
+Version 0.4.1
+2005-03-15
+Fixed some typos, removed unused code
+
+Version 0.4.0
+2005-03-14
+Initial Araneida support (supplied by Bob Hutchison)
+
+Version 0.3.13
+2005-03-12
+Small bugfix in RFC-1123-DATE (thanks to Bob Hutchison and Stefan Scholl)
+
+Version 0.3.12
+2005-03-01
+Added *HTTP-ERROR-HANDLER* (suggested and coded by Stefan Scholl)
+Exported and documented *SESSION-MAX-TIME*
+
+Version 0.3.11
+2005-02-21
+Added ability to access raw post data (suggested and coded by Zach Beane)
+
+Version 0.3.10
+2005-01-24
+Make bivalent streams work with LispWorks 4.4
+UTF-8 demo for LispWorks (thanks to Bob Hutchison)
+
+Version 0.3.9
+2004-12-31
+Re-compute content length after applying MAYBE-REWRITE-URLS-FOR-SESSION (caught by Stefan Scholl)
+
+Version 0.3.8
+2004-12-27
+Don't send body for HEAD requests (needs current mod_lisp version) 
+
+Version 0.3.7
+2004-12-22
+Change #\Del to #\Rubout in QUOTE-STRING (AllegroCL complains, #\Del isn't even semi-standard)
+
+Version 0.3.6
+2004-12-02
+Make REQUIRE-AUTHORIZATION compliant to RFC 2616 (thanks to Stefan Scholl)
+
+Version 0.3.5
+2004-12-01
+Several small doc fixes (thanks to Stefan Scholl)
+Catch requests like "GET http://server/foo.html HTTP/1.0" (suggested by Stefan Scholl)
+
+Version 0.3.4
+2004-11-29
+Added backtrace code for OpenMCL (provided by Tiarn?n ? Corr?in)
+
+Version 0.3.3
+2004-11-22
+Cleaner handling of macro variables
+
+Version 0.3.2
+2004-11-11
+Updated docs for mod_lisp2
+
+Version 0.3.1
+2004-11-09
+Slight changes to support Chris Hanson's mod_lisp2
+Changed GET-BACKTRACE for newer SBCL versions (thanks to Nikodemus Siivola)
+
+Version 0.3.0
+2004-11-09
+Initial support for multipart/form-data (thanks to Michael Weber and Janis Dzerins)
+Fixed bug in CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (caught by Bill Clementson)
+
+Version 0.2.12
+2004-10-15
+Exported and documented DO-SESSIONS
+
+Version 0.2.11
+2004-09-02
+FORM-URL-ENCODED-LIST-TO-ALIST now decodes names and values
+
+Version 0.2.10
+2004-08-28
+Allow non-strings to be cookie values (bug caught by Zach Beane)
+
+Version 0.2.9
+2004-08-11
+Consistent usage of RFC-1123-DATE (provided by Stefan Scholl)
+Added all missing http headers from RFC 2616 (provided by Stefan Scholl)
+Added support for mod_lisp version strings (see <http://common-lisp.net/pipermail/mod-lisp-devel/2004-August/000019.html>)
+Don't always add session IDs when redirecting
+
+Version 0.2.8
+2004-07-24
+Fixed typo in html.lisp and improved docs (both caught by Stefan Scholl)
+
+Version 0.2.7
+2004-07-24
+Add missing exports and docs
+
+Version 0.2.6
+2004-07-24
+Make CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER thread-safe (caught by Jeff Caldwell)
+Added support for 'If-Modified-Since' request headers (provided by Stefan Scholl)
+
+Version 0.2.5
+2004-07-21
+Added CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER (provided by Stefan Scholl)
+Improved test suite
+
+Version 0.2.4
+2004-07-19
+New variable *CONTENT-TYPES-FOR-URL-REWRITE* (suggested by Stefan Scholl)
+Updated index.html regarding new version of mod_lisp
+
+Version 0.2.3
+2004-06-12
+Bugfix for FORM-URL-ENCODED-LIST-TO-ALIST (bug caught by Jong-won Choi)
+
+Version 0.2.2
+2004-06-10
+Bugfix for SESSION-GC and RESET-SESSIONS (bug introduced in 0.2.0)
+
+Version 0.2.1
+2004-06-10
+Only create backtrace if needed (speeds up AllegroCL considerably)
+
+Version 0.2.0
+2004-06-07
+Added SESSION-STRING and *SESSION-REMOVAL-HOOK*
+Added GET-BACKTRACE for AllegroCL
+
+Version 0.1.2
+2004-05-12
+Removed some more typos in docs (thanks to Karl A. Krueger)
+Changed BASE64 to CL-BASE64 in .asd file (thanks to Frank Sonnemans and Nicolas Lamirault)
+
+Version 0.1.1
+2004-05-08
+Removed some old files from Jeff's port
+Fixed a couple of typos in docs
+
+Version 0.1.0
+2004-05-07
+First public release
+Original code by Edi Weitz
+Initial doc strings, port to KMRCL, logging code and various other improvements by Jeff Caldwell

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/README	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,2 @@
+Complete documentation for Hunchentoot including details about how to
+install it can be found in the 'doc' directory.

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/conditions.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,60 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/conditions.lisp,v 1.1 2007/11/08 20:07:58 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defvar *catch-errors-p* t
+  "Whether Hunchentoot should catch and log errors \(or rather
+invoke the debugger).")
+
+(defgeneric maybe-invoke-debugger (condition)
+  (:documentation "This generic function is called whenever a
+condition CONDITION is signaled in Hunchentoot.  You might want to
+specialize it on specific condition classes for debugging purposes.")
+  (:method (condition)
+   "The default method invokes the debugger with CONDITION if
+*CATCH-ERRORS-P* is NIL."
+   (unless *catch-errors-p*
+     (invoke-debugger condition))))
+
+(defmacro with-debugger (&body body)
+  "Executes BODY and invokes the debugger if an error is signaled and
+*CATCH-ERRORS-P* is NIL."
+  `(handler-bind ((error #'maybe-invoke-debugger))
+     , at body))
+
+(defmacro ignore-errors (&body body)
+  "Like CL:IGNORE-ERRORS, but observes *CATCH-ERRORS-P*."
+  `(cl:ignore-errors (with-debugger , at body)))
+       
+(defmacro handler-case (expression &rest clauses)
+  "Like CL:HANDLER-CASE, but observes *CATCH-ERRORS-P*."
+  `(cl:handler-case (with-debugger ,expression)
+     , at clauses))
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/cookie.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,121 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/cookie.lisp,v 1.7 2007/09/18 14:23:23 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defclass cookie ()
+  ((name :initarg :name
+         :reader cookie-name
+         :type string
+         :documentation "The name of the cookie - a string.")
+   (value :initarg :value
+          :accessor cookie-value
+          :initform ""
+          :documentation "The value of the cookie. Will be URL-encoded
+when sent to the browser.")
+   (expires :initarg :expires
+            :initform nil
+            :accessor cookie-expires
+            :documentation "The time \(a universal time) when the
+cookie expires \(or NIL).")
+   (path :initarg :path
+         :initform nil
+         :accessor cookie-path
+         :documentation "The path this cookie is valid for \(or NIL).")
+   (domain :initarg :domain
+           :initform nil
+           :accessor cookie-domain
+           :documentation "The domain this cookie is valid for \(or NIL).")
+   (secure :initarg :secure
+           :initform nil
+           :accessor cookie-secure
+           :documentation "A generalized boolean denoting whether this
+cookie is a secure cookie.")
+   (http-only :initarg :http-only
+              :initform nil
+              :accessor cookie-http-only
+              :documentation "A generalized boolean denoting whether
+this cookie is a `HttpOnly' cookie.
+
+This is a Microsoft extension that has been implemented in Firefox as
+well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>."))
+  (:documentation "Each COOKIE objects describes one outgoing cookie."))
+
+(defmethod initialize-instance :around ((cookie cookie) &rest init-args)
+  "Ensure COOKIE has a correct slot-value for NAME."
+  (let ((name (getf init-args :name)))
+    (unless (http-token-p name)
+      (error "~S is not a legal name for a cookie." name)))
+  (call-next-method))
+
+(defun set-cookie* (cookie &optional (reply *reply*))
+  "Adds the COOKIE object COOKIE to the outgoing cookies of the
+REPLY object REPLY. If a cookie with the same name
+\(case-sensitive) already exists, it is replaced."
+  (let* ((name (cookie-name cookie))
+         (place (assoc name (cookies-out reply) :test #'string=)))
+    (cond
+      (place
+        (setf (cdr place) cookie))
+      (t
+        (push (cons name cookie) (cookies-out reply))
+        cookie))))
+
+(defun set-cookie (name &key (value "") expires path domain secure http-only (reply *reply*))
+  "Creates a cookie object from the parameters provided and adds
+it to the outgoing cookies of the REPLY object REPLY. If a cookie
+with the name NAME \(case-sensitive) already exists, it is
+replaced."
+  (set-cookie* (make-instance 'cookie
+                              :name name
+                              :value value
+                              :expires expires
+                              :path path
+                              :domain domain
+                              :secure secure
+                              :http-only http-only)
+               reply))
+
+(defun cookie-date (universal-time)
+  "Converts UNIVERSAL-TIME to cookie date format."
+  (and universal-time
+       (rfc-1123-date universal-time)))
+
+(defmethod stringify-cookie ((cookie cookie))
+  "Converts the COOKIE object COOKIE to a string suitable for a
+'Set-Cookie' header to be sent to the client."
+  (format nil
+          "~A=~A~:[~;~:*; expires=~A~]~:[~;~:*; path=~A~]~:[~;~:*; domain=~A~]~:[~;; secure~]~:[~;; HttpOnly~]"
+          (cookie-name cookie)
+          (url-encode (format nil "~A" (cookie-value cookie)) +utf-8+)
+          (cookie-date (cookie-expires cookie))
+          (cookie-path cookie)
+          (cookie-domain cookie)
+          (cookie-secure cookie)
+          (cookie-http-only cookie)))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/LICENSE.txt	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,9 @@
+The Hunchentoot logo (the file `hunchentoot.gif' in this directory)
+was created by Uwe von Loh and is available from his website at
+
+  http://www.htg1.de/hunchentoot/hunchentoot.html
+
+It is licensed under a `Creative Commons Attribution-Share Alike 2.0
+Germany License', see
+
+  http://creativecommons.org/licenses/by-sa/2.0/de/

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/hunchentoot.gif
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/doc/index.html	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,2623 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html> 
+
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+  <title>HUNCHENTOOT - The Common Lisp web server formerly known as TBNL</title>
+  <style type="text/css">
+  pre { padding:5px; background-color:#e0e0e0 }
+  h3, h4 { text-decoration: underline; }
+  a { text-decoration: none; padding: 1px 2px 1px 2px; }
+  a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+  a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } 
+  a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+  a.none { text-decoration: none; padding: 0; }
+  a.none:visited { text-decoration: none; padding: 0; } 
+  a.none:hover { text-decoration: none; border: none; padding: 0; } 
+  a.none:focus { text-decoration: none; border: none; padding: 0; } 
+  a.noborder { text-decoration: none; padding: 0; } 
+  a.noborder:visited { text-decoration: none; padding: 0; } 
+  a.noborder:hover { text-decoration: none; border: none; padding: 0; } 
+  a.noborder:focus { text-decoration: none; border: none; padding: 0; }  
+  pre.none { padding:5px; background-color:#ffffff }
+  </style>
+  <meta name="description" content="A fully-featured web server written in Common Lisp offering things like HTTP/1.1 chunking, persistent connections, and SSL.
+Includes a framework for building dynamic websites interactively.">
+</head>
+
+<body bgcolor=white>
+
+<h2><a href="http://www.htg1.de/hunchentoot/hunchentoot.html"
+title="Click here for the Hunchentoot logo"
+class=noborder><img align=top width=93 height=45 border=0
+src="hunchentoot.gif"></a> HUNCHENTOOT - The Common Lisp web server
+formerly known as TBNL</h2>
+
+<blockquote>
+<br>&nbsp;<br><h3><a name=abstract class=none>Abstract</a></h3>
+
+Hunchentoot is a web server written in Common Lisp and at the same
+time a toolkit for building dynamic websites.  As a
+stand-alone web server, Hunchentoot is capable of HTTP/1.1 chunking
+(both directions), persistent connections (keep-alive), and SSL, but
+it can also sit behind the
+popular <a href='http://httpd.apache.org/'>Apache</a> using
+Marc
+Battyani's <a
+href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a>.
+
+<p>
+
+Hunchentoot provides facilities like automatic session handling (with
+and without cookies), logging (to Apache's log files or to a file in
+the file system), customizable error handling, and easy access to GET
+and POST parameters sent by the client. It does <em>not</em> include
+functionality to programmatically generate HTML output. For this task
+you can use any library you like, e.g. (shameless
+self-plug) <a href="http://weitz.de/cl-who/">CL-WHO</a>
+or <a href="http://weitz.de/html-template/">HTML-TEMPLATE</a>.
+
+<p>
+
+Hunchentoot talks with its front-end or with the client over TCP/IP
+sockets and uses multiprocessing to handle several requests at the
+same time.  Therefore, it cannot be implemented completely
+in <a
+href="http://www.lispworks.com/documentation/HyperSpec/Front/index.htm">portable
+Common Lisp</a>.  It currently works with
+<a href="http://www.lispworks.com/">LispWorks</a> (which is the main development and testing platform),
+<a href="http://www.cons.org/cmucl/">CMUCL</a> (with MP
+support), <a href="http://sbcl.sourceforge.net/">SBCL</a> (with
+Unicode and <a href="http://abstractstuff.livejournal.com/26811.html">thread</a> <a href="http://common-lisp.net/pipermail/tbnl-devel/2006-November/000780.html">support</a>),
+<a href="http://openmcl.clozure.com/">OpenMCL</a>,
+and <a href="http://www.franz.com/products/allegrocl/">Allegro Common
+Lisp</a>.  (Note: You can use Hunchentoot with <a href="http://clisp.cons.org">CLISP</a> 
+or with a version of SBCL without threads, for example on Windows, 
+but this is not recommended except for development purposes.)  Porting to other
+CL implementations shouldn't be too hard, see the files <code>port-xxx.lisp</code>
+and <code>unix-xxx.lisp</code> which comprise all the
+implementation-specific code.
+
+<p>
+
+Hunchentoot comes with a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+<p>
+
+Hunchentoot is for example used by <a href="http://clutu.com/">clutu</a>, <a href="http://twitterbuzz.com/">TwitterBuzz</a>,
+<a href="http://www.jalat.com/">Jalat</a>, <a href="http://heikestephan.de/">Heike Stephan</a>,
+<a href="http://www.memetrics.com/">xOs</a>,
+and <a href="http://syseng.nist.gov/moss">the</a> <a href="http://syseng.nist.gov/se-interop">NIST</a>.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/hunchentoot.tar.gz">http://weitz.de/files/hunchentoot.tar.gz</a>.
+</blockquote>
+
+<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+  <li><a href="#install">Download and installation</a>
+  <ol>
+    <li><a href='#proxy'>Hunchentoot behind a proxy</a>
+    <li><a href='#mod_lisp'>Hunchentoot behind mod_lisp</a>
+  </ol>
+  <li><a href="#mail">Support and mailing lists</a>
+  <li><a href="#example">Examples, tutorials, add-ons</a>
+  <li><a href="#reference">Function and variable reference</a>
+  <ol>
+    <li><a href='#servers'>Servers</a>
+    <li><a href='#handlers'>Handlers</a>
+    <li><a href='#requests'>Requests</a>
+    <li><a href='#replies'>Replies</a>
+    <li><a href='#cookies'>Cookies</a>
+    <li><a href='#sessions'>Sessions</a>
+    <li><a href='#log'>Logging and error handling</a>
+    <li><a href='#debug'>Debugging Hunchentoot applications</a>
+    <li><a href='#misc'>Miscellaneous</a>
+  </ol>
+  <li><a href="#ht-mp">The HUNCHENTOOT-MP package</a>
+  <li><a href="#performance">Performance</a>
+  <li><a href="#history">History</a>
+  <li><a href="#index">Symbol index</a>
+  <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+<br>&nbsp;<br><h3><a name="install" class=none>Download and installation</a></h3>
+
+Hunchentoot depends on a couple of other Lisp libraries which you'll need
+to install first:
+<ul>
+      <li>Pierre R. Mai's <a href='http://www.cliki.net/md5'>MD5</a>,
+
+      <li>Kevin Rosenberg's <a href='http://www.cliki.net/cl-base64'>CL-BASE64</a>,
+
+      <li>Janis Dzerins' <a href='http://common-lisp.net/project/rfc2388/'>RFC2388</a>,
+
+      <li>David Lichteblau's <a href='http://common-lisp.net/project/cl-plus-ssl/'>CL+SSL</a> (unless you're using LispWorks),
+
+      <li><a href='http://www.cliki.net/ACL-COMPAT'>ACL-COMPAT</a> (for OpenMCL only),
+
+      <li>and my own <a href='http://weitz.de/flexi-streams/'>FLEXI-STREAMS</a> (0.12.0 or higher), <a href='http://weitz.de/chunga/'>Chunga</a>, <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a>, and <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a> (plus <a href="http://weitz.de/cl-who/">CL-WHO</a> for the <a href="#example">example code</a>). 
+</ul>
+Make sure to use the <em>newest</em> versions of all of these libraries (which might themselves depend on other libraries)!
+Note: You can compile Hunchentoot without SSL support - and thus without the need to have CL+SSL - if you add <code>:HUNCHENTOOT-NO-SSL</code> to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_featur.htm"><code>*FEATURES*</code></a> <em>before</em> you compile it.
+<p>
+The preferred method to compile and load Hunchentoot is via <a href="http://www.cliki.net/asdf">ASDF</a>.
+<p>
+Hunchentoot together with this documentation can be downloaded
+from <a
+href="http://weitz.de/files/hunchentoot.tar.gz">http://weitz.de/files/hunchentoot.tar.gz</a>. The
+current version is 0.15.0.  There's also a port
+for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo
+Linux</a> thanks to Matthew Kennedy.
+<p>
+A <a href="http://www.selenic.com/mercurial/wiki/">Mercurial</a>
+repository of older versions is available
+at <a
+href="http://arcanes.fr.eu.org/~pierre/2007/02/weitz/">http://arcanes.fr.eu.org/~pierre/2007/02/weitz/</a>
+thanks to Pierre Thierry.
+<p>
+Lu&iacute;s Oliveira maintains a <a href="http://darcs.net/">darcs</a>
+repository of Hunchentoot
+at <a
+href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>.
+
+<h4><a name="proxy" class=none>Hunchentoot behind a proxy</a></h4>
+
+If you're feeling unsecure about exposing Hunchentoot to the wild,
+wild Internet or if your Lisp web application is part of a larger
+website, you can hide it behind
+a <a href="http://en.wikipedia.org/wiki/Proxy_server">proxy
+server</a>.  One approach that I have used several times is to employ
+Apache's <a
+href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html">mod_proxy</a>
+module with a configuration that looks like this:
+<pre>
+<a href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html#proxypass" class=noborder>ProxyPass</a> /hunchentoot http://127.0.0.1:3000/hunchentoot
+<a href="http://httpd.apache.org/docs/2.0/mod/mod_proxy.html#proxypassreverse" class=noborder>ProxyPassReverse</a> /hunchentoot http://127.0.0.1:3000/hunchentoot
+</pre>
+This will tunnel all requests where the URI path begins with <code>"/hunchentoot"</code> to a (Hunchentoot) server listening on port&nbsp;3000 on the same machine.
+<p>
+Of course, there are <a href="http://www.red-bean.com/pipermail/lispweb/2006-October/001342.html">several other</a> (more lightweight) web proxies that
+you could use instead of Apache.
+
+<h4><a name="mod_lisp" class=none>Hunchentoot behind mod_lisp</a></h4>
+
+You can also couple Hunchentoot more tightly with Apache
+using <a
+href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a>.
+In this case, Apache will not send proxy requests to Hunchentoot, but
+communicate with it directly using a simple, line-based protocol.  The
+downside of this approach is that it makes debugging harder.  (Also,
+with mod_lisp,
+you <a
+href="http://common-lisp.net/pipermail/mod-lisp-devel/2006-October/000098.html">can't
+accept request bodies that use chunked encoding</a>.  With the usual
+web browsers, this shouldn't be a problem, though.)
+<p>
+For this setup you need two things:
+
+<ul>
+  <li>The <a href='http://httpd.apache.org/'>Apache web server</a>. You can use either 1.3.x or 2.x. It is recommend that you use or build an Apache with <a href='http://httpd.apache.org/docs/dso.html'>DSO support</a>.
+
+  <li>The <a
+href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp</a>
+Apache module by Marc Battyani. It is beyond the scope of this document to explain the
+details of how to install mod_lisp, but if your Apache has DSO support,
+it should suffice to issue a command like
+
+<pre>
+apxs -c -i -a mod_lisp.c
+</pre>
+
+as root (and afterwards restart Apache).
+<p>
+The newest version of mod_lisp is available from <a
+href="http://www.fractalconcept.com:8000/public/open-source/mod_lisp/">http://www.fractalconcept.com:8000/public/open-source/mod_lisp/</a>. For Apache&nbsp;1.3.x you
+must use mod_lisp.c, for Apache&nbsp;2.x you must use mod_lisp2.c, which is a reimplementation of Marc's mod_lisp by Chris Hanson.
+<p>
+You can get pre-compiled modules for the Win32 version of Apache&nbsp;2 (but probably not the latest version) from <a href="http://www.fractalconcept.com:8000/public/open-source/mod_lisp/windows/">http://www.fractalconcept.com:8000/public/open-source/mod_lisp/windows/</a>. Put the file into Apache's <code>modules</code> folder and add the line
+<pre>
+LoadModule lisp_module modules/mod_lisp2.so
+</pre>
+to your <code>httpd.conf</code> file.
+
+</ul>
+
+Then you will have to configure Apache and mod_lisp to make them aware
+of Hunchentoot. First, in your Apache configuration file (usually
+called <code>httpd.conf</code>) add these lines
+
+<pre>
+<a name='LispServer' class=noborder>LispServer</a> 127.0.0.1 3000 &quot;foo&quot;
+
+&lt;Location /hunchentoot&gt;
+  SetHandler lisp-handler
+&lt;/Location&gt;
+</pre>
+
+and afterwards restart Apache. This informs mod_lisp that there's a
+Lisp listening on port&nbsp;3000 and named
+&quot;foo&quot; - you can of course use any other name or port or
+even put Hunchentoot on another physical machine. (In the latter case you'll
+have to replace <code>127.0.0.1</code> with the FQDN or IP address of
+this machine.)
+<p>
+The <code>Location/SetHandler</code> part means that every URL which
+starts with <code>/hunchentoot</code> will be handled by mod_lisp (and thus
+Hunchentoot) on this server. (Again, you can of course use other locations. See the
+Apache documentation for things like <em>virtual hosts</em> or
+directives like <code>LocationMatch</code>.)
+
+<p>
+
+To interface a Hunchentoot server with mod_lisp, you must start it
+with the <code>:MOD-LISP-P</code> keyword parameter
+of <a href="#start-server"><code>START-SERVER</code></a> set to a true
+value.
+
+<br>&nbsp;<br><h3><a name="mail" class=none>Support and mailing lists</a></h3>
+
+For questions, bug reports, feature requests, improvements, or patches
+please use
+the <a
+href="http://common-lisp.net/mailman/listinfo/tbnl-devel">tbnl-devel
+mailing list</a>. If you want to be notified about future releases
+subscribe to
+the <a
+href="http://common-lisp.net/mailman/listinfo/tbnl-announce">tbnl-announce
+mailing list</a>. These mailing lists were made available thanks to
+the services of <a href="http://common-lisp.net/">common-lisp.net</a>.
+You can <b>search</b> the devel mailing
+list <a
+href="http://google.com/coop/cse?cx=002927904911724867201%3A0l5rif_cxj0">here</a>
+(thanks to Tiarn?n ? Corr?in).
+<p>
+If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
+
+<br>&nbsp;<br><h3><a name="example" class=none>Examples, tutorials, add-ons</a></h3>
+
+Hunchentoot comes with an example website which you can use to see if
+it works and which should also demonstrate a couple of the things you
+can do with Hunchentoot.  Use it as a kind of "Hello World" code to
+get yourself started.
+<p>
+To run the example, 
+enter the following code into your listener:
+<pre>
+(<a class=noborder href="http://common-lisp.net/~mmommer/asdf-howto.shtml#sec11">asdf:oos</a> 'asdf:load-op :hunchentoot-test)
+(hunchentoot:<a class=noborder href="#start-server">start-server</a> :port 4242)
+</pre>
+You should now be able to point your browser
+at <code>http://localhost:4242/hunchentoot/test</code> and see
+something.
+<p>
+Here are some tutorials done by others:
+<ul>
+<li>Two <a href="http://myblog.rsynnott.com/2007/09/getting-started-with-hunchento.html">getting</a> <a href="http://myblog.rsynnott.com/2007/10/doing-more-with-hunchentoot-cl-server.html">started</a> articles by Robert Synnott.
+<li><a href="http://www.newartisans.com/blog_files/common.lisp.with.apache.php">Running Common Lisp behind Apache</a> by John Wiegley.
+<li>A <a href="http://www.lispcast.com/index.php/2007/10/lispcast-writing-a-simple-reddit-clone-in-common-lisp/">"LispCast"</a> by Eric Normand about writing a <a href="http://reddit.com/">Reddit</a> clone using Hunchentoot.  Apparently the first part of a <a href="http://bc.tech.coop/blog/071028.html">series</a>.
+<li>A <a
+href="http://www.jalat.com/blogs/lisp?id=3">tutorial</a> for (an older version of) Hunchentoot by Asbj&oslash;rn Bj&oslash;rnstad.
+<li>A <a href="http://www.frank-buss.de/lisp/tbnl.html">TBNL
+tutorial</a> from Frank Buss.  (Hunchentoot is not <a href="http://weitz.de/tbnl/">TBNL</a>, but the two
+are similar enough to make the tutorial worthwhile.)
+<li>
+For Win32, Bill Clementson
+<a
+href="http://bc.tech.coop/blog/041105.html">explains</a> how to set up Hunchentoot's predecessor <a href="http://weitz.de/tbnl/">TBNL</a> with
+Apache/mod_lisp.  See also <a href="http://bc.tech.coop/blog/061013.html">http://bc.tech.coop/blog/061013.html</a>.
+</ul>
+Check the dates of these tutorials.  Some of them might not be a
+perfect fit with the latest release of Hunchentoot.  Also, the fact
+that these tutorials are listed here doesn't necessarily mean that I
+endorse them or think that they show idiomatic Lisp code.  You'll have
+to decide yourself if they're helpful to you or not.
+</p>
+<p>
+Here is some software which extends Hunchentoot or is based on it:
+<ul>
+<li><a href="http://common-lisp.net/project/cl-weblocks/">Weblocks</a>
+by Slava Akhmechet is a "continuations-based web framework" which is
+based on Hunchentoot.
+<li><a href="http://85.65.214.241/misc/ht-ajax.html">HT-AJAX</a> is
+an <a
+href="http://en.wikipedia.org/wiki/Ajax_%28programming%29">Ajax</a>
+framework for Hunchentoot by Ury Marshak.
+<li>Mac
+Chan <a
+href="http://common-lisp.net/pipermail/tbnl-devel/2007-May/001324.html">has
+ported <a href="http://lemonodor.com/">John
+Wiseman</a>'s <a
+href="http://www.lemonodor.com/archives/000128.html">Lisp Server
+Pages</a> to Hunchentoot.
+<li><a
+href="http://site.znain.com/dl/lisp/hunchentoot-dir-lister/">hunchentoot-dir-lister</a>
+is a directory listing addition for Hunchentoot by Dimitre Liotev.
+<li>Cyrus
+Harmon's <a
+href="http://cyrusharmon.org/blog/display?id=64">nuclblog</a> is a
+<a href="http://en.wikipedia.org/wiki/Blog">blog</a> engine which uses Hunchentoot.
+<li><a href="http://weitz.de/cl-webdav/">CL-WEBDAV</a> is a <a href="http://webdav.org/">WebDAV</a> server based on Hunchentoot.
+</ul>
+
+<br>&nbsp;<br><h3><a class=none name="reference">Function and variable reference</a></h3>
+
+<h4><a class=none name="servers">Servers</a></h4>
+
+If you want Hunchentoot to actually do something, you have
+to <a href="#start-server">start</a> a server.  You can also run
+several servers in one image, each one listening to a different port.
+
+<p><br>[Function]
+<br><a class=none name="start-server"><b>start-server</b> <i><tt>&amp;key</tt> port address name dispatch-table mod-lisp-p use-apache-log-p input-chunking-p read-timeout write-timeout setuid setgid ssl-certificate-file ssl-privatekey-file ssl-privatekey-password</i> =&gt; <i>server</i></a>
+
+<blockquote><br> Starts a Hunchentoot server instance and returns it.
+<code><i>port</i></code> ist the port the server will be listening on
+- the default is 80 (or 443 if SSL information is provided).
+If <code><i>address</i></code> is a string denoting an IP address,
+then the server only receives connections for that address.  This must
+be one of the addresses associated with the machine and allowed values
+are host names such as <a class=none href="http://www.zappa.com/"><code>"www.zappa.com"</code></a> and address
+strings such as <a class=none href="http://72.3.247.29/"><code>"72.3.247.29"</code></a>.
+If <code><i>address</i></code> is <code>NIL</code>, then the server
+will receive connections to all IP addresses on the machine.  This is
+the default.
+<p>
+<code><i>dispatch-table</i></code> can either be
+a <a href="#*dispatch-table*">dispatch table</a> which is to be used
+by this server or <code>NIL</code> which means that at request
+time <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a>
+will be called to retrieve a dispatch table.
+<p>
+<code><i>name</i></code> should be a symbol which can be used to name
+the server.  This name can utilized when
+defining <a href="#define-easy-handler">easy handlers</a>.  The
+default name is an uninterned symbol as returned
+by <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_gensym.htm"><code>GENSYM</code></a>.
+<p>
+If <code><i>mod-lisp-p</i></code> is true (the default
+is <code>NIL</code>), the server will act as a back-end
+for <a href="#mod_lisp">mod_lisp</a>, otherwise it will be a
+stand-alone web server.  If <code><i>use-apache-log-p</i></code> is
+true (which is the default), log messages will be written to the
+Apache log file - this parameter has no effect
+if <code><i>mod-lisp-p</i></code> is NIL.
+<p>
+If <code><i>input-chunking-p</i></code> is true (which is the
+default), the server will accept request bodies without
+a <code>Content-Length</code> header if the client uses chunked
+transfer encoding.  If you want to use this feature behind mod_lisp,
+you should make sure that your combination of Apache and
+mod_lisp <a
+href="http://common-lisp.net/pipermail/mod-lisp-devel/2006-December/000104.html">can
+cope with that</a>.
+<p>
+<code><i>read-timeout</i></code> is the read timeout (in seconds) for
+the socket stream used by the server - the default value
+is <a
+href="#*default-read-timeout*"><code>*DEFAULT-READ-TIMEOUT*</code></a>.
+This parameter is ignored on OpenMCL. <code><i>write-timeout</i></code> is the write timeout (in
+seconds) for the socket stream used by the server - the default value
+is <a
+href="#*default-write-timeout*"><code>*DEFAULT-WRITE-TIMEOUT*</code></a>.
+This parameter is ignored on all implementations except for
+LispWorks&nbsp;5.0 or higher and AllegroCL.  You can use <code>NIL</code> in both
+cases to denote that you don't want a timeout.
+If <code><i>mod-lisp-p</i></code> is true, the timeouts are always set
+to <code>NIL</code>.
+<p>
+On Unix you can use <code><i>setuid</i></code>
+and <code><i>setgid</i></code> to change the UID and GID of the
+process directly after the server has been started.  (You might want
+to do this if you're using a privileged port like 80.)  <code><i>setuid</i></code> and
+<code><i>setgid</i></code> can be integers (the actual IDs) or strings
+(for the user and group name respectively).
+<p>
+If you want your server to use SSL, you must provide the pathname
+designator(s) <code><i>ssl-certificate-file</i></code> for the certificate file and
+optionally <code><i>ssl-privatekey-file</i></code> for the private key file, both files
+must be in PEM format.  If you only provide the value for
+<code><i>ssl-certificate-file</i></code> it is assumed that both the
+certificate and the private key are in one file.  If your private key
+needs a password you can provide it through
+the <code><i>ssl-privatekey-password</i></code> keyword argument.  If
+you <em>don't</em> use LispWorks, the private key must not be
+associated with a password, and the certificate and the private key
+must be in separate files.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="stop-server"><b>stop-server</b> <i>server</i> =&gt; |</a>
+
+<blockquote><br>
+Stops a server started with <a href="#start-server"><code>START-SERVER</code></a>.  <code><i>server</i></code> must be an object as returned by <a href="#start-server"><code>START-SERVER</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*server*"><b>*server*</b></a>
+
+<blockquote><br>
+During the execution of <a href="#handlers">dispatch functions and handlers</a> this variable
+is bound to the server object (as returned by <a href="#start-server"><code>START-SERVER</code></a>) which processes the request.
+</blockquote>
+
+<p><br>[Readers]
+<br><a class=none name="server-local-port"><b>server-local-port</b> <i>server</i> =&gt; <i>port</i></a>
+<br><a class=none name="server-address"><b>server-address</b> <i>server</i> =&gt; <i>address</i></a>
+
+<blockquote><br>
+These methods can be used to query a Hunchentoot server object.  The values correspond to the <code><i>port</i></code> and <code><i>address</i></code> parameters of <a href="#start-server"><code>START-SERVER</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="server-dispatch-table"><b>server-dispatch-table</b> <i>server</i> =&gt; <i>dispatch-table</i>
+<br><tt>(setf (</tt><b>server-dispatch-table</b> <i>server</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br> These methods can be used to get and set
+the <a href="#*dispatch-table*">dispatch table</a> of a Hunchentoot
+server object.  The value corresponds to
+the <code><i>dispatch-table</i></code> parameter
+of <a href="#start-server"><code>START-SERVER</code></a> and can be
+changed at runtime.  It can be set to NIL which means that the server
+doesn't have its own dispatch table
+and <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a> should be
+called instead.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="server-name"><b>server-name</b> <i>server</i> =&gt; <i>name</i>
+<br><tt>(setf (</tt><b>server-name</b> <i>server</i>) <i>new-value</i><tt>)</tt></a>
+<blockquote><br> These methods can be used to get and set the name of a server
+which must be a symbol.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-read-timeout*"><b>*default-read-timeout*</b></a>
+
+<blockquote><br> The default value for the <code><i>read-timeout</i></code> keyword
+argument to <a href="#start-server"><code>START-SERVER</code></a>.  The initial value is 20 (seconds).
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-write-timeout*"><b>*default-write-timeout*</b></a>
+
+<blockquote><br> The default value for the <code><i>write-timeout</i></code> keyword
+argument to <a href="#start-server"><code>START-SERVER</code></a>.  The initial value is 20 (seconds).
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*cleanup-interval*"><b>*cleanup-interval*</b></a>
+
+<blockquote><br>
+Should be <code>NIL</code> or a positive integer.  The system calls
+<a href="#*cleanup-function*"><code>*CLEANUP-FUNCTION*</code></a> whenever <a href="#*cleanup-interval*"><code>*CLEANUP-INTERVAL*</code></a> new worker threads have
+been created unless the value is <code>NIL</code>. The initial value is&nbsp;100.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*cleanup-function*"><b>*cleanup-function*</b></a>
+
+<blockquote><br>
+The function (with no arguments) which is called if <a href="#*cleanup-interval*"><code>*CLEANUP-INTERVAL*</code></a> is not <code>NIL</code>.
+The initial value is a function which calls
+<code>(<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-166.htm">HCL</a>:<a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-212.htm"><code>MARK-AND-SWEEP</code></a>&nbsp;2)</code> on LispWorks and does nothing on other Lisps.
+<p>
+On LispWorks this is necessary because each <em>worker</em> (which is
+created to handle an incoming http request and which dies afterwards
+unless the connection is persistent) is a Lisp process and LispWorks
+creates processes in generation&nbsp;2.
+<p>
+Note that you can also set this value to <code>NIL</code> and tune
+LispWork's GC yourself, using for
+example <a
+href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-180.htm"><code>COLLECT-GENERATION-2</code></a>.
+</blockquote>
+
+<h4><a class=none name="handlers">Handlers</a></h4>
+
+Hunchentoot handles each incoming request dynamically depending on the
+contents of a global <em>dispatch table</em>. The details can be found
+below. (See the file <code>test/test.lisp</code> for examples.)
+
+<p><br>[Special variable]
+<br><a class=none name="*dispatch-table*"><b>*dispatch-table*</b></a>
+
+<blockquote><br>
+
+The return value of the initial value of <a href="#*meta-dispatcher*"><code>*META-DISPATCHER*</code></a>.
+<p>
+This is a list of <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
+designators</a> for <em>dispatch functions</em> each of which should
+be a function of one argument which accepts a <a
+href='#requests'><code>REQUEST</code></a> object and, depending on
+this object, should either return a <em>handler</em> to handle the
+request or <code>NIL</code> which means that the next dispatcher will
+be queried. A <em>handler</em> is a designator for a function with no
+arguments which usually returns a string or an array of octets to be sent to the client as
+the body of the http reply. (Note that if you use symbols as function
+designators, you can redefine your handler functions without the need
+to change the dispatch functions.)  See <a href='#replies'>the section
+about replies</a> for more about what handlers can do.
+<p>
+The dispatchers in a dispatch table are tried in turn
+until one of them returns a handler. If this doesn't happen, Hunchentoot will
+return a 404 status code (Not Found) to the client.
+<p>
+The initial value of <code>*DISPATCH-TABLE*</code> is a list which
+just contains the symbol <a
+href='#default-dispatcher'><code>DEFAULT-DISPATCHER</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="default-dispatcher"><b>default-dispatcher</b> <i>request</i> =&gt; <i>handler</i></a>
+
+<blockquote><br>
+
+This is a function which will always unconditionally return the value of <a
+href='#*default-handler*'><code>*DEFAULT-HANDLER*</code></a>. It is intended to be the last element of <a
+href='#*dispatch-table*'><code>*DISPATCH-TABLE*</code></a>.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-handler*"><b>*default-handler*</b></a>
+
+<blockquote><br>
+
+This variable holds the handler which is always returned by <a
+href='#default-dispatcher'><code>DEFAULT-DISPATCHER</code></a>. The
+default value is a function which unconditonally shows a short Hunchentoot
+info page.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*meta-dispatcher*"><b>*meta-dispatcher*</b></a>
+
+<blockquote><br> The value of this variable should be a function of
+one argument.  It is called with the current Hunchentoot server
+instance (unless the server has <a href="#server-dispatch-table">its
+own dispatch table</a>) and must return a dispatch table suitable for
+Hunchentoot.  The initial value is a function which always
+unconditionally returns
+<a href="#*dispatch-table*"><code>*DISPATCH-TABLE*</code></a>.
+<p>
+This can obviously be used to assign different dispatch tables to
+different servers (and is useless if you only have one server).
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-prefix-dispatcher"><b>create-prefix-dispatcher</b> <i>prefix handler</i> =&gt; <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that returns <code><i>handler</i></code> whenever the path part of the request URI starts with the string <code><i>prefix</i></code>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-regex-dispatcher"><b>create-regex-dispatcher</b> <i>regex handler</i> =&gt; <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that returns <code><i>handler</i></code> whenever the path part of the request URI matches the <a href='http://weitz.de/cl-ppcre/'>CL-PPCRE</a> regular expression <code><i>regex</i></code> (which can be a string, an s-expression, or a scanner).
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="handle-static-file"><b>handle-static-file</b> <i>path <tt>&amp;optional</tt> content-type</i> =&gt; <i>nil</i></a>
+
+<blockquote><br>
+Sends the file denote by the pathname designator
+<code><i>path</i></code> with content type
+<code><i>content-type</i></code> to the client.  Sets the necessary handlers.  In particular the function employs
+<a href="#handle-if-modified-since"><code>HANDLE-IF-MODIFIED-SINCE</code></a>.
+<p>
+If <code><i>content-type</i></code> is <code>NIL</code> the function
+tries to determine the correct content type from the file's suffix or
+falls back to <code>"application/octet-stream"</code> as a last resort.
+<p>
+Note that this function
+calls <a href="#send-headers"><code>SEND-HEADERS</code></a>
+internally, so after you've called it, the headers are sent and the
+return value of your handler is ignored.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-static-file-dispatcher-and-handler"><b>create-static-file-dispatcher-and-handler</b> <i>uri path <tt>&amp;optional</tt> content-type</i> =&gt; <i>dispatch-fn</i></a>
+
+<blockquote><br>
+
+A convenience function which will return a dispatcher that dispatches
+to a handler which emits the file denoted by the pathname designator
+<code><i>path</i></code> with content type
+<code><i>content-type</i></code> 
+if the <a href='#script-name'><code>SCRIPT-NAME</code></a> of the
+request matches the string <code><i>uri</i></code>.  Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally.
+<p>
+If <code><i>content-type</i></code> is <code>NIL</code> the function tries to determine the correct content type from the file's suffix
+or falls back to <code>"application/octet-stream"</code> as a last resort.
+<a href='#*default-content-type*'><code>*DEFAULT-CONTENT-TYPE*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="create-folder-dispatcher-and-handler"><b>create-folder-dispatcher-and-handler</b> <i>uri-prefix base-path <tt>&amp;optional</tt> content-type</i> =&gt; <i>dispatch-fn</i></a>
+
+<blockquote><br>
+Creates and returns a dispatch function which will dispatch to a
+handler function which emits the file relative to <code><i>base-path</i></code> that is
+denoted by the URI of the request relative to <code><i>uri-prefix</i></code>.  <code><i>uri-prefix</i></code>
+must be a string ending with a slash, <code><i>base-path</i></code> must be a pathname
+designator for an existing directory.
+Uses <a href="#handle-static-file"><code>HANDLE-STATIC-FILE</code></a> internally.
+<p>
+If <code><i>content-type</i></code> is <em>not</em> <code>NIL</code>,
+it will be used as a the content type for all files in the folder.
+Otherwise (which is the default) the content type of each file will be determined <a href="#handle-static-file">as usual</a>.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="dispatch-request"><b>dispatch-request</b> <i>dispatch-table</i> =&gt; <i>result</i></a>
+
+<blockquote><br>
+This is a generic function so users can customize its behaviour.  Look at the source code for details.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="define-easy-handler"><b>define-easy-handler</b> <i>description lambda-list [[declaration* | documentation]] form*</i></a>
+
+<blockquote><br>
+
+Defines a handler as if
+by <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/m_defun.htm"><code>DEFUN</code></a>
+and optionally registers it with a URI so that it will be found
+by <a
+href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>.
+<p>
+<code><i>description</i></code> is either a symbol <code><i>name</i></code> or a list matching the
+<a href="http://www.lispworks.com/documentation/HyperSpec/Body/03_de.htm">destructuring lambda list</a>
+
+<pre>
+  (name &amp;key uri server-names default-parameter-type default-request-type).
+</pre>
+
+<code><i>lambda-list</i></code> is a list the elements of which are either a symbol
+<code><i>var</i></code> or a list matching the destructuring lambda list
+
+<pre>
+  (var &amp;key real-name parameter-type init-form request-type).
+</pre>
+
+The resulting handler will be a Lisp function with the
+name <code><i>name</i></code> and keyword parameters named by
+the <code><i>var</i></code> symbols.  Each <code><i>var</i></code>
+will be bound to the value of the GET or POST parameter
+called <code><i>real-name</i></code> (a string) before the body of the
+function is executed.  If <code><i>real-name</i></code> is not
+provided, it will be computed by <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stg_up.htm#string-downcase">downcasing</a> the symbol name
+of <code><i>var</i></code>.
+<p>
+If <code><i>uri</i></code> (which is evaluated) is provided, then it must be a string or
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
+designator</a> for a unary function.  In this case,
+the handler will be returned by <a href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>, if <code><i>uri</i></code> is a
+string and the <a href="#script-name">script name</a> of the current request is <code><i>uri</i></code>, or if <code><i>uri</i></code> designates a
+function and applying this function to the <a href="#*request*">current <code>REQUEST</code> object</a>
+returns a true value.
+<p>
+
+<code><i>server-names</i></code> (which is evaluated) can be a list of
+symbols which means that the handler will only be returned
+by <a
+href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>
+in servers which have one of these names
+(see <a
+href="#server-name"><code>SERVER-NAME</code></a>).  <code><i>server-names</i></code>
+can also be the symbol <code>T</code> which means that the handler
+will be returned
+by <a
+href="#dispatch-easy-handlers"><code>DISPATCH-EASY-HANDLERS</code></a>
+in <em>every</em> server.
+<p>
+Whether the GET or POST parameter (or both) will be taken into
+consideration, depends on <code><i>request-type</i></code> which can
+be <code>:GET</code>, <code>:POST</code>, <code>:BOTH</code>, or <code>NIL</code>.  In the last case, the value of
+<code><i>default-request-type</i></code> (the default of which
+is <code>:BOTH</code>) will be used.
+<p>
+The value of <code><i>var</i></code> will usually be a string (unless
+it resulted from a <a href="#upload">file upload</a> in which case it won't be converted at
+all), but if <code><i>parameter-type</i></code> (which is evaluated)
+is provided, the string will be converted to another Lisp type by the
+following rules:
+<p>
+If the corresponding GET or POST parameter wasn't provided by the
+client, <code><i>var</i></code>'s value will be <code>NIL</code>.  If <code><i>parameter-type</i></code> is <code>'STRING</code>,
+<code><i>var</i></code>'s value remains as is.  If <code><i>parameter-type</i></code> is <code>'INTEGER</code> and the
+parameter string consists solely of decimal digits, <code><i>var</i></code>'s value will be
+the corresponding integer, otherwise <code>NIL</code>.  If <code><i>parameter-type</i></code> is
+<code>'KEYWORD</code>, <code><i>var</i></code>'s value will be the
+keyword obtained
+by <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_intern.htm">interning</a>
+the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stg_up.htm#string-upcase">upcased</a> parameter string into
+the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/11_abc.htm">keyword
+package</a>.  If <code><i>parameter-type</i></code>
+is <code>'CHARACTER</code> and the parameter string is of length
+one, <code><i>var</i></code>'s value will be the single character of
+this string, otherwise <code>NIL</code>.
+If <code><i>parameter-type</i></code>
+is <code>'BOOLEAN</code>, <code><i>var</i></code>'s value will always
+be <code>T</code> (unless it is <code>NIL</code> by the first rule
+above, of course).  If <code><i>parameter-type</i></code> is any other
+atom, it is supposed to be
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
+designator</a> for a unary function which will be called to
+convert the string to something else.
+<p>
+Those were the rules for <em>simple</em> parameter types, but
+<code><i>parameter-type</i></code> can also be a list starting with one of the symbols
+<code>LIST</code>, <code>ARRAY</code>, or <code>HASH-TABLE</code>.
+The second value of the list must always be a simple parameter type as
+in the last paragraph - we'll call it the <em>inner type</em> below.
+<p>
+In the case of <code>'LIST</code>, all GET/POST parameters
+called <code><i>real-name</i></code> will be collected, converted to
+the inner type as by the rules above, and assembled into a list which
+will be the value of
+<code><i>var</i></code>.
+<p>
+In the case of <code>'ARRAY</code>, all GET/POST parameters which have
+a name like the result of
+
+<pre>
+  (format nil "~A[~A]" real-name n)
+</pre>
+
+where <code><i>n</i></code> is a non-negative integer, will be
+assembled into an array where the <code><i>n</i></code>th element will
+be set accordingly, after conversion to the inner type.  The array,
+which will become the value of <code><i>var</i></code>, will be big
+enough to hold all matching parameters, but not bigger.  Array
+elements not set as described above will be <code>NIL</code>.  Note
+that <code>VAR</code> will always be bound to an array, which may be
+empty, so it will never be <code>NIL</code>, even if no appropriate
+GET/POST parameters are found.
+<p>
+The full form of a <code>'HASH-TABLE</code> parameter type is
+
+<pre>
+  (hash-table inner-type key-type test-function),
+</pre>
+
+but <code><i>key-type</i></code> and <code><i>test-function</i></code>
+can be left out in which case they default to <code>'STRING</code>
+and <code>'EQUAL</code>, respectively.  For this parameter type, all
+GET/POST parameters which have a name like the result of
+
+<pre>
+  (format nil "~A{~A}" real-name key)
+</pre>
+
+(where <code><i>key</i></code> is a string that doesn't contain curly brackets) will
+become the values (after conversion to <code><i>inner-type</i></code>) of a hash
+table with test function <code><i>test-function</i></code> where <code><i>key</i></code> (after
+conversion to <code><i>key-type</i></code>) will be the corresponding key.  Note that
+<code><i>var</i></code> will always be bound to a hash table, which
+may be empty, so it will never be <code>NIL</code>, even if no
+appropriate GET/POST parameters are found.
+<p>
+To make matters even more complicated, the three compound parameter
+types also have an abbreviated form - just one of the
+symbols <code>LIST</code>, <code>ARRAY</code>,
+or <code>HASH-TABLE</code>.  In this case, the inner type will default
+to <code>'STRING</code>.
+<p>
+If <code><i>parameter-type</i></code> is not provided
+or <code>NIL</code>, <code><i>default-parameter-type</i></code> (the
+default of which is <code>'STRING</code>) will be used instead.
+<p>
+If the result of the computations above would be
+that <code><i>var</i></code> would be bound to <code>NIL</code>,
+then <code><i>init-form</i></code> (if provided) will be evaluated
+instead, and <code><i>var</i></code> will be bound to the result of
+this evaluation.
+<p>
+Handlers built with this macro are constructed in such a way that the
+resulting Lisp function is useful even outside of Hunchentoot.  Specifically,
+all the parameter computations above will only happen
+if <a href="#*request*"><code>*REQUEST*</code></a> is bound, i.e. if
+we're within a Hunchentoot request.  Otherwise, <code><i>var</i></code> will
+always be bound to the result of
+evaluating <code><i>init-form</i></code> unless a corresponding
+keyword argument is provided.
+<p>
+The <a href="#example">example code</a> that comes with Hunchentoot contains an
+example which demonstrates some of the features
+of <a
+href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="dispatch-easy-handlers"><b>dispatch-easy-handlers</b> <i>request</i> =&gt; <i>handler</i></a>
+
+<blockquote><br>
+
+This is a dispatcher which returns the appropriate handler defined
+with <a
+href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a>, if
+there is one.  The newest handlers are checked
+first.  <a
+href="#define-easy-handler"><code>DEFINE-EASY-HANDLER</code></a> makes
+sure that there's always only one handler per name and one per URI.
+URIs are compared
+by <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_equal.htm"><code>EQUAL</code></a>,
+so anonymous functions won't be recognized as being identical.
+
+</blockquote>
+
+<h4><a class=none name="requests">Requests</a></h4>
+
+When a request comes in, Hunchentoot creates a <code>REQUEST</code> object
+which is available to the <a href="#handlers">handler</a> via the
+special variable <a href='#*request*'><code>*REQUEST*</code></a>. This object holds
+all the information available about the request and can be queried
+with the functions described in this chapter. Note that the internal
+structure of <code>REQUEST</code> objects should be considered opaque and may change
+in future releases of Hunchentoot.
+<p>
+In all of the functions below, the default value
+for <code><i>request</i></code> (which is either an optional or a
+keyword argument) is the value of <a href='#*request*'><code>*REQUEST*</code></a>,
+i.e. handlers will usually not need to provide this argument when
+calling the function.
+<p>
+(Some of the function names in this section might seem a bit strange.
+This is because they were initially chosen to be similar to
+environment variables in CGI scripts.)
+
+<p><br>[Special variable]
+<br><a class=none name="*request*"><b>*request*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>REQUEST</code> object.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="host"><b>host</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the value of the incoming <code>Host</code> http header.
+(This corresponds to
+the environment variable <code>HTTP_HOST</code> in CGI
+scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="request-method"><b>request-method</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>keyword</i></a>
+
+<blockquote><br>
+
+Returns the request method as a keyword, i.e. something like <code>:POST</code>.  (This corresponds to the environment
+variable <code>REQUEST_METHOD</code> in CGI scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="request-uri"><b>request-uri</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the URI for <code><i>request</i></code>. Note that this not the full URI but only the part behind the
+scheme and authority components, so that if the user has typed <code>http://user:password at www.domain.com/xxx/frob.html?foo=bar</code> into his browser, this function will return <code>"/xxx/frob.html?foo=bar"</code>.
+(This corresponds to
+the environment variable <code>REQUEST_URI</code> in CGI
+scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="script-name"><b>script-name</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the file name (or path) component of the URI
+for <code><i>request</i></code>, i.e. the part of the string returned
+by <a href="#request-uri"><code>REQUEST-URI</code></a> in front of the
+first question mark (if any).
+(This corresponds to
+the environment variable <code>SCRIPT_NAME</code> in CGI
+scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="query-string"><b>query-string</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the query component of the URI
+for <code><i>request</i></code>, i.e. the part of the string returned
+by <a href="#request-uri"><code>REQUEST-URI</code></a> behind the
+first question mark (if any).
+(This corresponds to
+the environment variable <code>QUERY_STRING</code> in CGI
+scripts.) See also <a href="#get-parameter"><code>GET-PARAMETER</code></a> and <a href="#get-parameters"><code>GET-PARAMETERS</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="get-parameter"><b>get-parameter</b> <i>name <tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the GET parameter (as provided via the request URI) named by the string <code><i>name</i></code> as a string (or <code>NIL</code> if there ain't no GET parameter with this name). Note that only the first value will be returned if the client provided more than one GET parameter with the name <code><i>name</i></code>. See also <a href="#get-parameters"><code>GET-PARAMETERS</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="get-parameters"><b>get-parameters</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all GET parameters (as provided via the request URI). The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the parameter's name while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value (as a string). The elements of this list are in the same order as they were within the request URI. See also <a href="#get-parameter"><code>GET-PARAMETER</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="post-parameter"><b>post-parameter</b> <i>name <tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the POST parameter (as provided in the request's body) named by the string <code><i>name</i></code>. Note that only the first value will be returned if the client provided more than one POST parameter with the name <code><i>name</i></code>.
+This value will usually be a string (or <code>NIL</code> if there ain't no POST parameter with this name). If, however, the browser sent a <a class=none name="upload">file</a> through a <a href="http://www.faqs.org/rfcs/rfc2388.html"><code>multipart/form-data</code></a> form, the value of this function is a three-element list
+<pre>
+(path file-name content-type)
+</pre>
+where <code><i>path</i></code> is a pathname denoting the place were the uploaded file was stored, <code><i>file-name</i></code> (a string) is the file name sent by the browser, and <code><i>content-type</i></code> (also a string) is the content type sent by the browser. The file denoted by <code><i>path</i></code> will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it.
+<p>
+POST parameters will only be computed if the content type of the request body was <code>multipart/form-data</code>
+or <code>application/x-www-form-urlencoded</code>.
+Although this function is called <code>POST-PARAMETER</code>, you can instruct Hunchentoot to compute these parameters for other request methods by setting <a href="#*methods-for-post-parameters*"><code>*METHODS-FOR-POST-PARAMETERS*</code></a>.
+<p>
+See also <a href="#post-parameters"><code>POST-PARAMETERS</code></a> and <a href="#*tmp-directory*"><code>*TMP-DIRECTORY*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="post-parameters"><b>post-parameters</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all POST parameters (as provided via the request's body). The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the parameter's name while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value. The elements of this list are in the same order as they were within the request's body.
+<p>
+See also <a href="#post-parameter"><code>POST-PARAMETER</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*methods-for-post-parameters*"><b>*methods-for-post-parameters*</b></a>
+
+<blockquote><br> A list of the request method types (as keywords) for
+which Hunchentoot will try to compute <a href="#post-parameter">"POST"
+parameters</a>.  The default is the list with the single
+element <code>:POST</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*file-upload-hook*"><b>*file-upload-hook*</b></a>
+
+<blockquote><br> If this is not <code>NIL</code>, it should be
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">designator</a>
+for a unary function which will be called with a pathname for each
+file which is <a href="#upload">uploaded</a> to Hunchentoot.  The pathname
+denotes the temporary file to which the uploaded file is written.  The
+hook is called directly <em>before</em> the file is created.  At this
+point, <a href="#*request*"><code>*REQUEST*</code></a> is already
+bound to the current <code>REQUEST</code> object, but obviously you
+can't access the post parameters yet.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="raw-post-data"><b>raw-post-data</b> <tt>&amp;key</tt> <i>request external-format force-text force-binary want-stream</i> =&gt; <i>raw-body-or-stream</i></a>
+
+<blockquote><br> Returns the content sent by the client in the request
+body if there was any (unless the content type
+was <code>multipart/form-data</code> in which case <code>NIL</code>
+is returned).  By default, the result is a string if the type of
+the <code>Content-Type</code> <a
+href="http://www.faqs.org/rfcs/rfc1590.html">media type</a>
+is <code>"text"</code>, and a vector of octets otherwise.  In the case
+of a string, the external format to be used to decode the content will
+be determined from the <code>charset</code> parameter sent by the
+client (or
+otherwise <a
+href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>
+will be used).
+<p>
+You can also provide an external format explicitly (through
+<code><i>external-format</i></code>) in which case the result will
+unconditionally be a string.  Likewise, you can provide a true value
+for <code><i>force-text</i></code> which will force Hunchentoot to act
+as if the type of the media type had been <code>"text"</code>
+(with <code><i>external-format</i></code> taking precedence if
+provided).  Or you can provide a true value
+for <code><i>force-binary</i></code> which means that you want a
+vector of octets at any rate.  (If both
+<code><i>force-text</i></code> and <code><i>force-binary</i></code>
+are true, an error will be signaled.)
+<p>
+If, however, you provide a true value
+for <code><i>want-stream</i></code>, the other parameters are ignored
+and you'll get the content (flexi) stream to read from it yourself.
+It is then your responsibility to read the correct amount of data,
+because otherwise you won't be able to return a response to the
+client.  The stream will have
+its <a href="http://weitz.de/flexi-streams/#flexi-streams">octet
+position</a> set to <code>0</code>.  If the client provided
+a <code>Content-Length</code> header, the stream will also have
+a
+corresponding <a href="http://weitz.de/flexi-streams/#flexi-streams">bound</a>,
+so no matter whether the client used chunked encoding or not, you can
+always read until EOF.
+<p>
+If the content type of the request
+was <code>multipart/form-data</code>
+or <code>application/x-www-form-urlencoded</code>, the content has
+been read by Hunchentoot already and you can't read from the stream
+anymore.
+<p>
+You can call <a href="#raw-post-data"><code>RAW-POST-DATA</code></a>
+more than once per request, but you can't mix calls which have
+different values for <code><i>want-stream</i></code>.
+<p>
+Note that this function is slightly misnamed because a client can send
+content even if the request method is not POST.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="parameter"><b>parameter</b> <i>name <tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the GET or POST parameter named by the string <code><i>name</i></code> as a string (or <code>NIL</code> if there ain't no parameter with this name). If both a GET and a POST parameter with the name <code><i>name</i></code> exist, the GET parameter will be returned. See also <a href="#get-parameter"><code>GET-PARAMETER</code></a> and <a href="#post-parameter"><code>POST-PARAMETER</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="header-in"><b>header-in</b> <i>name <tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br> Returns the incoming header named by the
+keyword <code><i>name</i></code> as a string (or <code>NIL</code> if
+there ain't no header with this name). Note that this queries the
+headers sent to Hunchentoot by the client <em>or</em> by mod_lisp.  In
+the latter case this may not only include the incoming http headers
+but also
+some <a href='http://www.fractalconcept.com/asp/debug'>headers sent by
+mod_lisp</a>.
+<p>For backwards compatibility, <code><i>name</i></code>
+can also be a string which is matched case-insensitively.  See
+also <a href="#headers-in"><code>HEADERS-IN</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="headers-in"><b>headers-in</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all incoming headers. The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the headers's name (a Lisp keyword) while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value (as a string). There's no guarantee about the order of this list. See also <a href="#header-in"><code>HEADER-IN</code></a> and the remark about incoming headers there.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="authorization"><b>authorization</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>user, password</i></a>
+
+<blockquote><br>
+Returns as two values the user and password (if any) from the incoming <code>Authorization</code> http header.  Returns <code>NIL</code> if there is no such header.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="remote-addr"><b>remote-addr</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the IP address (as a string) of the client which sent the
+request.  (This corresponds to the environment
+variable <code>REMOTE_ADDR</code> in CGI scripts.) See
+also <a href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="remote-port"><b>remote-port</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>number</i></a>
+
+<blockquote><br>
+
+Returns the IP port (as a number) of the client which sent the request.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="real-remote-addr"><b>real-remote-addr</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string{, list}</i></a>
+
+<blockquote><br>
+
+Returns the value of the
+incoming <a
+href="http://en.wikipedia.org/wiki/XFF"><code>X-Forwarded-For</code></a>
+http header as the second value in the form of a list of IP addresses
+and the first element of this list as the first value if this header
+exists. Otherwise returns the value
+of <a href="#remote-addr"><code>REMOTE-ADDR</code></a> as the only
+value.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="server-addr"><b>server-addr</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the IP address (as a string) where the request came in.  (This
+corresponds to the environment variable <code>SERVER_ADDR</code> in
+CGI scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="server-port"><b>server-port</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>number</i></a>
+
+<blockquote><br>
+
+Returns the IP port (as a number) where the request came in.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="server-protocol"><b>server-protocol</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>keyword</i></a>
+
+<blockquote><br>
+
+Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either <code>:HTTP/1.0</code> or <code>:HTTP/1.1</code>.
+(This corresponds to the environment
+variable <code>SERVER_PROTOCOL</code> in CGI scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="mod-lisp-id"><b>mod-lisp-id</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the 'Server ID' sent by mod_lisp. This corresponds to the
+third parameter in the &quot;<a
+href='#LispServer'>LispServer</a>&quot; directive in Apache's
+configuration file and can be interesting if you deploy several different
+Apaches or Hunchentoot instances at once.  Returns <code>NIL</code> in stand-alone servers.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="ssl-session-id"><b>ssl-session-id</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns Apache's SSL session ID if it exists. Note that SSL sessions aren't related to <a href='#sessions'>Hunchentoot sessions</a>.
+(This corresponds to
+the environment variable <code>SSL_SESSION_ID</code> in CGI
+scripts.)  Returns <code>NIL</code> in stand-alone servers.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="user-agent"><b>user-agent</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the value of the incoming <code>User-Agent</code> http header.
+(This corresponds to
+the environment variable <code>HTTP_USER_AGENT</code> in CGI
+scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="referer"><b>referer</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+Returns the value of the incoming <code>Referer</code> (sic!) http header.
+(This corresponds to
+the environment variable <code>HTTP_REFERER</code> in CGI
+scripts.)
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="cookie-in"><b>cookie-in</b> <i>name <tt>&amp;optional</tt> request</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Returns the value of the incoming cookie named by the string <code><i>name</i></code> (or <code>NIL</code> if there ain't no cookie with this name). See also <a href="#cookies-in"><code>COOKIES-IN</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="cookies-in"><b>cookies-in</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all incoming cookies. The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the cookie's name while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is the cookie's value. See also <a href="#cookie-in"><code>COOKIE-IN</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="aux-request-value"><b>aux-request-value</b> <i>symbol <tt>&amp;optional</tt> request</i> =&gt; <i>value, present-p</i>
+<br><tt>(setf (</tt><b>aux-request-value</b> <i>symbol <tt>&amp;optional</tt> request</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+This accessor can be used to associate arbitrary data with the the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> in the <code>REQUEST</code>
+object <code><i>request</i></code>.
+<code><i>present-p</i></code> is <em>true</em> if such data was found,
+otherwise <code>NIL</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="delete-aux-request-value"><b>delete-aux-request-value</b> <i>symbol <tt>&amp;optional</tt> request</i> =&gt; |</a>
+
+<blockquote><br>
+Completely removes any data associated with the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> from the <code>REQUEST</code>
+object <code><i>request</i></code>. Note that this is different from 
+using <a href="#aux-request-value"><code>AUX-REQUEST-VALUE</code></a> to set the data to <code>NIL</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="recompute-request-parameters"><b>recompute-request-parameters</b> <i><tt>&amp;key</tt> request external-format</i> =&gt; |</a>
+
+<blockquote><br> Recomputes the GET and POST parameters for
+the <code>REQUEST</code> object
+<code><i>request</i></code>.  This only makes sense if you've changed
+the external format and with POST parameters it will only work if the
+request body was sent with 
+the <code>application/x-www-form-urlencoded</code> content type.
+<p>
+The default value for
+<code><i>external-format</i></code> is <a
+href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+See <code>test/test.lisp</code> for an example.
+</blockquote>
+
+<h4><a class=none name="replies">Replies</a></h4>
+
+It is the responsibility of a <a href='#handlers'>handler</a> function to prepare the reply for the client. This is done by
+
+<ul>
+  <li>returning a string or an array of octets which will be the reply's body and
+  <li>manipulating a <code>REPLY</code> object which will be described in this section.
+</ul>
+
+For each request there's one <code>REPLY</code> object which is accessible 
+to the handler via the
+special variable <a href='#*reply*'>*REPLY*</a>. This object holds
+all the information available about the reply and can be accessed
+with the functions described in this chapter. Note that the internal
+structure of <code>REPLY</code> objects should be considered opaque and may change
+in future releases of Hunchentoot.
+<p>
+In all of the functions below, the default value
+for the optional argument <code><i>reply</i></code> is the value of <a href='#*reply*'>*REPLY*</a>,
+i.e. handlers will usually not need to provide this argument when
+calling the function.
+<p>
+While Hunchentoot's preferred way of sending data to the client is the
+one described above (i.e. the handler returns the whole payload as a
+string or an array of octets) you can, if you really need to (for
+example for large content bodies), get a stream you can write to
+directly.  This is achieved by first setting
+up <a href="#*reply*"><code>*REPLY*</code></a> and then
+calling <a href="#send-headers"><code>SEND-HEADERS</code></a>.  Note
+that in this case the usual <a href="#log">error handling</a> is
+disabled.  See the file <code>test/test.lisp</code> for an example.
+
+<p><br>[Special variable]
+<br><a class=none name="*reply*"><b>*reply*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>REPLY</code> object.
+
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="header-out"><b>header-out</b> <i>name <tt>&amp;optional</tt> reply</i> =&gt; <i>string</i>
+<br><tt>(setf (</tt><b>header-out</b> <i>name <tt>&amp;optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<code>HEADER-OUT</code> returns the outgoing http header named by the
+keyword <code><i>name</i></code> if there is one,
+otherwise <code>NIL</code>. <code>SETF</code>
+of <code>HEADER-OUT</code> changes the current value of the header
+named <code><i>name</i></code>. If no header
+named <code><i>name</i></code> exists it is created.  For backwards
+compatibility, <code><i>name</i></code> can also be a string in which
+case the association between a header and its name is
+case-insensitive.
+<p>
+Note that the
+headers <code>Set-Cookie</code>, <code>Content-Length</code>,
+and <code>Content-Type</code> cannot be queried
+by <code>HEADER-OUT</code> and <em>must not</em> be set
+by <code>SETF</code> of <code>HEADER-OUT</code>.  Also, there are a
+couple of "technical" headers like <code>Connection</code>
+or <code>Transfer-Encoding</code> that you're not supposed to set
+yourself.  If in doubt, consult the source code or ask on
+the <a href="#mail">mailing list</a>.
+<p>
+See also <a href="#headers-out"><code>HEADERS-OUT</code></a>, <a href="#content-type"><code>CONTENT-TYPE</code></a>, <a href="#content-length"><code>CONTENT-LENGTH</code></a>, <a href="#cookies-out"><code>COOKIES-OUT</code></a>, and <a href="#cookie-out"><code>COOKIE-OUT</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="headers-out"><b>headers-out</b> <i><tt>&amp;optional</tt> request</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all outgoing http parameters (except for <code>Set-Cookie</code>, <code>Content-Length</code>,
+and <code>Content-Type</code>). The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the headers's name while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is its value. This alist should not be manipulated directly, use <code>SETF</code> of <a href="#header-out"><code>HEADER-OUT</code></a> instead.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="cookie-out"><b>cookie-out</b> <i>name <tt>&amp;optional</tt> reply</i> =&gt; <i>cookie</i></a>
+
+<blockquote><br>
+Returns the outgoing cookie named by the string <code><i>name</i></code> (or <code>NIL</code> if there ain't no cookie with this name). See also <a href="#cookies-out"><code>COOKIES-OUT</code></a> and <a href='#cookies'>the section about cookies</a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="cookies-out"><b>cookies-out</b> <i><tt>&amp;optional</tt> reply</i> =&gt; <i>alist</i></a>
+
+<blockquote><br>
+Returns an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of all outgoing cookies. The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a> of each element of this list is the cookie's name while the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a> is the cookie itself. See also <a href="#cookie-out"><code>COOKIE-OUT</code></a> and <a href='#cookies'>the section about cookies</a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="return-code"><b>return-code</b> <i><tt>&amp;optional</tt> reply</i> =&gt; <i>number</i>
+<br><tt>(setf (</tt><b>return-code</b> <i><tt>&amp;optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<code>RETURN-CODE</code> returns the http return code of the
+reply, <code>SETF</code> of <code>RETURN-CODE</code> changes it. The
+return code of each <code>REPLY</code> object is initially set to <a
+href="#+http-ok+"><code>+HTTP-OK+</code></a>.
+
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="content-type"><b>content-type</b> <i><tt>&amp;optional</tt> reply</i> =&gt; <i>string</i>
+<br><tt>(setf (</tt><b>content-type</b> <i><tt>&amp;optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<code>CONTENT-TYPE</code> returns the
+outgoing <code>Content-Type</code> http header. <code>SETF</code>
+of <code>CONTENT-TYPE</code> changes the current value of this header. The content type of each <code>REPLY</code> object is initially set to the value of <a href="#*default-content-type*"><code>*DEFAULT-CONTENT-TYPE*</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="content-length"><b>content-length</b> <i><tt>&amp;optional</tt> reply</i> =&gt; <i>length</i>
+<br><tt>(setf (</tt><b>content-length</b> <i><tt>&amp;optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+<code>CONTENT-LENGTH</code> returns the outgoing
+<code>Content-Length</code> http header. <code>SETF</code> of
+<code>CONTENT-LENGTH</code> changes the current value of this
+header. The content length of each <code>REPLY</code> object is
+initially set to <code>NIL</code>.  If you leave it like that,
+Hunchentoot will automatically try to compute the correct value
+using <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_length.htm"><code>LENGTH</code></a>.
+If you set the value yourself, you <em>must</em> make sure that it's
+the correct length of the body in <em>octets</em> (not in characters).
+In this case, Hunchentoot will use the value as is which can lead to
+erroneous behaviour if it is wrong - so, use at your own risk.
+<p>
+Note that setting this value explicitly doesn't mix well with <a
+href="#*rewrite-for-session-urls*">URL rewriting</a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="send-headers"><b>send-headers</b> =&gt; <i>stream</i></a>
+
+<blockquote><br>
+Sends the initial status line and all headers as determined by
+the <code>REPLY</code> object <a href="#*reply*"><code>*REPLY*</code></a>.  Returns a <a href="http://weitz.de/flexi-streams/#flexi-streams">flexi stream</a> to which the body of
+the reply can be written.  Once this function has been called,
+further changes to <a href="#*reply*"><code>*REPLY*</code></a> don't have any effect.  Also,
+<a href="#log">automatic handling of errors</a> (i.e. sending the
+corresponding status code to the browser, etc.) is turned off for this
+request.  Likewise, functions
+like <a href="#redirect"><code>REDIRECT</code></a> or throwing
+to <a href="#handler-done"><code>HANDLER-DONE</code></a>
+won't have the desired effect once the headers are sent.
+<p>
+If your handlers return the full body as a string or as an array of
+octets, you should <em>not</em> call this function.  If a handler
+calls <a href="#send-headers"><code>SEND-HEADERS</code></a>, its return
+value is ignored.
+<p>
+See also <a href="#reply-external-format"><code>REPLY-EXTERNAL-FORMAT</code></a>.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="reply-external-format"><b>reply-external-format</b> <i><tt>&amp;optional</tt> reply</i> =&gt; <i>external-format</i>
+<br><tt>(setf (</tt><b>reply-external-format</b> <i><tt>&amp;optional</tt> reply</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+
+Gets and sets the external format of the <code>REPLY</code>
+object <code><i>reply</i></code>.  This external format is used when
+character content is written to the client after the headers have been
+sent.  In particular, it is the external format of the stream returned by <a href="#send-headers"><code>SEND-HEADERS</code></a> (but of course you can change it because it's a <a href="http://weitz.de/flexi-streams/#flexi-streams">flexi stream</a>).
+<p>The initial value for each request is the value
+of <a
+href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+
+</blockquote>
+
+<p><br>[Constants]
+<br><a class=none name='+http-continue+'><b>+http-continue+</b></a>
+<br><a class=none name='+http-switching-protocols+'><b>+http-switching-protocols+</b></a>
+<br><a class=none name='+http-ok+'><b>+http-ok+</b></a>
+<br><a class=none name='+http-created+'><b>+http-created+</b></a>
+<br><a class=none name='+http-accepted+'><b>+http-accepted+</b></a>
+<br><a class=none name='+http-non-authoritative-information+'><b>+http-non-authoritative-information+</b></a>
+<br><a class=none name='+http-no-content+'><b>+http-no-content+</b></a>
+<br><a class=none name='+http-reset-content+'><b>+http-reset-content+</b></a>
+<br><a class=none name='+http-partial-content+'><b>+http-partial-content+</b></a>
+<br><a class=none name='+http-multi-status+'><b>+http-multi-status+</b></a>
+<br><a class=none name='+http-multiple-choices+'><b>+http-multiple-choices+</b></a>
+<br><a class=none name='+http-moved-permanently+'><b>+http-moved-permanently+</b></a>
+<br><a class=none name='+http-moved-temporarily+'><b>+http-moved-temporarily+</b></a>
+<br><a class=none name='+http-see-other+'><b>+http-see-other+</b></a>
+<br><a class=none name='+http-not-modified+'><b>+http-not-modified+</b></a>
+<br><a class=none name='+http-use-proxy+'><b>+http-use-proxy+</b></a>
+<br><a class=none name='+http-temporary-redirect+'><b>+http-temporary-redirect+</b></a>
+<br><a class=none name='+http-bad-request+'><b>+http-bad-request+</b></a>
+<br><a class=none name='+http-authorization-required+'><b>+http-authorization-required+</b></a>
+<br><a class=none name='+http-payment-required+'><b>+http-payment-required+</b></a>
+<br><a class=none name='+http-forbidden+'><b>+http-forbidden+</b></a>
+<br><a class=none name='+http-not-found+'><b>+http-not-found+</b></a>
+<br><a class=none name='+http-method-not-allowed+'><b>+http-method-not-allowed+</b></a>
+<br><a class=none name='+http-not-acceptable+'><b>+http-not-acceptable+</b></a>
+<br><a class=none name='+http-proxy-authentication-required+'><b>+http-proxy-authentication-required+</b></a>
+<br><a class=none name='+http-request-time-out+'><b>+http-request-time-out+</b></a>
+<br><a class=none name='+http-conflict+'><b>+http-conflict+</b></a>
+<br><a class=none name='+http-gone+'><b>+http-gone+</b></a>
+<br><a class=none name='+http-length-required+'><b>+http-length-required+</b></a>
+<br><a class=none name='+http-precondition-failed+'><b>+http-precondition-failed+</b></a>
+<br><a class=none name='+http-request-entity-too-large+'><b>+http-request-entity-too-large+</b></a>
+<br><a class=none name='+http-request-uri-too-large+'><b>+http-request-uri-too-large+</b></a>
+<br><a class=none name='+http-unsupported-media-type+'><b>+http-unsupported-media-type+</b></a>
+<br><a class=none name='+http-requested-range-not-satisfiable+'><b>+http-requested-range-not-satisfiable+</b></a>
+<br><a class=none name='+http-expectation-failed+'><b>+http-expectation-failed+</b></a>
+<br><a class=none name='+http-failed-dependency+'><b>+http-failed-dependency+</b></a>
+<br><a class=none name='+http-internal-server-error+'><b>+http-internal-server-error+</b></a>
+<br><a class=none name='+http-not-implemented+'><b>+http-not-implemented+</b></a>
+<br><a class=none name='+http-bad-gateway+'><b>+http-bad-gateway+</b></a>
+<br><a class=none name='+http-service-unavailable+'><b>+http-service-unavailable+</b></a>
+<br><a class=none name='+http-gateway-time-out+'><b>+http-gateway-time-out+</b></a>
+<br><a class=none name='+http-version-not-supported+'><b>+http-version-not-supported+</b></a>
+
+<blockquote><br>
+The values of these constants are 100, 101, 200, 201, 202, 203, 204, 205, 206, 207, 300, 301, 302, 303, 304, 305, 307, 400, 401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412, 413, 414, 415, 416, 417, 424, 500, 501, 502, 503, 504, and 505. See <a href="#return-code"><code>RETURN-CODE</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name='*default-content-type*'><b>*default-content-type*</b></a>
+
+<blockquote><br>
+The value of this variable is used to initialize the content type of each <code>REPLY</code> object. Its initial value is <code>"text/html; charset=iso-8859-1"</code>. See <a href="#content-type"><code>CONTENT-TYPE</code></a>.
+</blockquote>
+
+<h4><a class=none name="cookies">Cookies</a></h4>
+
+Outgoing cookies are stored in the request's <code>REPLY</code> object (see <a href="#cookie-out"><code>COOKIE-OUT</code></a> and <a href="#cookies-out"><code>COOKIES-OUT</code></a>). They are CLOS objects defined like this:
+
+<pre>
+(defclass cookie ()
+  ((name :initarg :name
+         :reader <a class=noborder name='cookie-name'>cookie-name</a>
+         :type string
+         :documentation &quot;The name of the cookie - a string.&quot;)
+   (value :initarg :value
+          :accessor <a class=noborder name='cookie-value'>cookie-value</a>
+          :initform &quot;&quot;
+          :documentation &quot;The value of the cookie. Will be URL-encoded when sent to the browser.&quot;)
+   (expires :initarg :expires
+            :initform nil
+            :accessor <a class=noborder name='cookie-expires'>cookie-expires</a>
+            :documentation &quot;The time (a universal time) when the cookie expires (or NIL).&quot;)
+   (path :initarg :path
+         :initform nil
+         :accessor <a class=noborder name='cookie-path'>cookie-path</a>
+         :documentation &quot;The path this cookie is valid for (or NIL).&quot;)
+   (domain :initarg :domain
+           :initform nil
+           :accessor <a class=noborder name='cookie-domain'>cookie-domain</a>
+           :documentation &quot;The domain this cookie is valid for (or NIL).&quot;)
+   (secure :initarg :secure
+           :initform nil
+           :accessor <a class=noborder name='cookie-secure'>cookie-secure</a>
+           :documentation &quot;A generalized boolean denoting whether this is a secure cookie.&quot;)
+   (http-only :initarg :http-only
+              :initform nil
+              :accessor <a class=noborder name='cookie-http-only'>cookie-http-only</a>
+              :documentation &quot;A generalized boolean denoting whether this is a <a href="http://msdn2.microsoft.com/en-us/library/ms533046.aspx">HttpOnly</a> cookie.&quot;)))
+</pre>
+
+The <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_r.htm#reader">reader</a> <a href="#cookie-name"><code>COOKIE-NAME</code></a> and
+the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessors</a>
+<a href="#cookie-value"><code>COOKIE-VALUE</code></a>, <a
+href="#cookie-expires"><code>COOKIE-EXPIRES</code></a>, <a
+href="#cookie-path"><code>COOKIE-PATH</code></a>, <a
+href="#cookie-domain"><code>COOKIE-DOMAIN</code></a>, <a
+href="#cookie-secure"><code>COOKIE-SECURE</code></a>, and <a
+href="#cookie-http-only"><code>COOKIE-HTTP-ONLY</code></a> are all exported
+from the <code>HUNCHENTOOT</code> package.
+
+<p><br>[Function]
+<br><a class=none name="set-cookie"><b>set-cookie</b> <i>name <tt>&amp;key</tt> value expires path domain secure http-only reply</i> =&gt; <i>cookie</i></a>
+
+<blockquote><br> Creates a <code>COOKIE</code> object from the
+parameters provided to this function and adds it to the outgoing
+cookies of the <a href='#replies'><code>REPLY</code>
+object</a> <code><i>reply</i></code>. If a cookie with the same name
+(case-sensitive) already exists, it is replaced. The default
+for <code><i>reply</i></code> is <a
+href="#*reply*"><code>*REPLY*</code></a>. The default for <code><i>value</i></code> is the empty string.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="set-cookie*"><b>set-cookie*</b> <i>cookie <tt>&amp;optional</tt> reply</i> =&gt; <i>cookie</i></a>
+
+<blockquote><br> Adds the <code>COOKIE</code>
+object <code><i>cookie</i></code> to the outgoing cookies of the <a
+href='#replies'><code>REPLY</code>
+object</a> <code><i>reply</i></code>. If a cookie with the same name
+(case-sensitive) already exists, it is replaced. The default for <code><i>reply</i></code> is <a href="#*reply*"><code>*REPLY*</code></a>.
+</blockquote>
+
+<h4><a class=none name="sessions">Sessions</a></h4>
+
+Hunchentoot supports <em>sessions</em>: Once a Hunchentoot page has
+called <a href="#start-session"><code>START-SESSION</code></a>,
+Hunchentoot uses either cookies or (if the client doesn't send the
+cookies back) <a href="#*rewrite-for-session-urls*">rewrites URLs</a>
+to keep track of this client, i.e. to provide a kind of 'state' for
+the stateless http protocol. The session associated with the client is
+an opaque CLOS object which can be used to store arbitrary data
+between requests.
+<p>
+Hunchentoot makes some reasonable effort to prevent eavesdroppers from
+hijacking sessions (see below), but this should not be considered
+really secure. Don't store sensitive data in sessions and rely
+solely on the session mechanism as a safeguard against malicious users
+who want to get at this data!
+<p>
+For each request there's one <code>SESSION</code> object which is accessible 
+to the handler via the
+special variable <a href='#*session*'><code>*SESSION*</code></a>. This object holds
+all the information available about the session and can be accessed
+with the functions described in this chapter. Note that the internal
+structure of <code>SESSION</code> objects should be considered opaque and may change
+in future releases of Hunchentoot.
+<p>
+Sessions are automatically verified for validity and age when
+the <a href='#requests'><code>REQUEST</code> object</a> is instantiated, i.e. if <a
+href='#*session*'><code>*SESSION*</code></a> is not <code>NIL</code> then this
+session is valid (as far as Hunchentoot is concerned) and not too old.  Old sessions are <a href="#session-gc">automatically removed</a>.
+
+<p><br>[Special variable]
+<br><a class=none name="*session*"><b>*session*</b></a>
+
+<blockquote><br>
+
+Holds the current <code>SESSION</code> object (if any) or <code>NIL</code>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="start-session"><b>start-session</b> =&gt; <i>session</i></a>
+
+<blockquote><br> Returns <a
+href="#*session*"><code>*SESSION*</code></a> if it
+isn't <code>NIL</code>, otherwise creates a new <code>SESSION</code>
+object and returns it.
+</blockquote>
+
+<p><br>[Accessor]
+<br><a class=none name="session-value"><b>session-value</b> <i>symbol <tt>&amp;optional</tt> session</i> =&gt; <i>value, present-p</i>
+<br><tt>(setf (</tt><b>session-value</b> <i>symbol <tt>&amp;optional</tt> session</i>) <i>new-value</i><tt>)</tt></a>
+
+<blockquote><br>
+This accessor can be used to associate arbitrary data with the the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> in the <code>SESSION</code>
+object <code><i>session</i></code>.
+<code><i>present-p</i></code> is <em>true</em> if such data was found,
+otherwise <code>NIL</code>. The default value
+for <code><i>session</i></code> is <a
+href="#*session*"><code>*SESSION*</code></a>.
+<p>
+If <code>SETF</code> of <code>SESSION-VALUE</code> is called with <code><i>session</i></code> being <code>NIL</code> then a session is automatically instantiated with <a href="#start-session"><code>START-SESSION</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="delete-session-value"><b>delete-session-value</b> <i>symbol <tt>&amp;optional</tt> session</i> =&gt; |</a>
+
+<blockquote><br>
+Completely removes any data associated with the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol">symbol</a> <code><i>symbol</i></code> from the <code>SESSION</code>
+object <code><i>session</i></code>. Note that this is different from 
+using <a href="#session-value"><code>SESSION-VALUE</code></a> to set the data to <code>NIL</code>.
+The default value
+for <code><i>session</i></code> is <a
+href="#*session*"><code>*SESSION*</code></a>.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="remove-session"><b>remove-session</b> <i>session</i> =&gt; |</a>
+
+<blockquote><br>
+Completely removes the session <code><i>session</i></code> from Hunchentoot's internal session database.  See also <a href="#*session-removal-hook*"><code>*SESSION-REMOVAL-HOOK*</code></a>.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="reset-sessions"><b>reset-sessions</b> =&gt; |</a>
+
+<blockquote><br>
+This function unconditionally invalidates and destroys <em>all</em> sessions immediately.
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="session-cookie-value"><b>session-cookie-value</b> <i>session</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Returns a unique string that's associated with
+the <code>SESSION</code> object <code><i>session</i></code>. This
+string is sent to the browser as a cookie value or as a GET parameter,
+</blockquote>
+
+
+<p><br>[Function]
+<br><a class=none name="session-counter"><b>session-counter</b> <i>session</i> =&gt; <i>count</i></a>
+
+<blockquote><br>
+Returns the number of times (requests) the <code>SESSION</code> object <code><i>session</i></code> has been used.
+</blockquote>
+
+
+
+<p><br>[Accessor]
+<br><a class=none name="session-max-time"><b>session-max-time</b> <i>session</i> =&gt; <i>seconds</i>
+<br><tt>(setf (</tt><b>session-max-time</b> <i>session</i>) <i>seconds</i><tt>)</tt></a>
+
+<blockquote><br> This gets or sets the maximum time (in seconds)
+the <code>SESSION</code> object <code><i>session</i></code> should be
+valid before it's invalidated: If a request associated with this
+session comes in and the last request for the same session was more
+than <code><i>seconds</i></code> seconds ago
+than the session is deleted and a new one is started for this client.  The default value is determined by <a href="#*session-max-time*"><code>*SESSION-MAX-TIME*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="session-remote-addr"><b>session-remote-addr</b> <i>session</i> =&gt; <i>address</i></a>
+
+<blockquote><br> Returns the 'real' remote address (see <a
+href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>) of the
+client for which the <code>SESSION</code>
+object <code><i>session</i></code> was initiated.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="session-user-agent"><b>session-user-agent</b> <i>session</i> =&gt; <i>address</i></a>
+
+<blockquote><br> Returns the 'User-Agent' http header (see <a
+href="#user-agent"><code>USER-AGENT</code></a>) of the
+client for which the <code>SESSION</code>
+object <code><i>session</i></code> was initiated.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*use-remote-addr-for-sessions*"><b>*use-remote-addr-for-sessions*</b></a>
+
+<blockquote><br>
+
+If this value is <em>true</em> (the default is <code>NIL</code>) then
+the 'real' remote address (see <a
+href="#real-remote-addr"><code>REAL-REMOTE-ADDR</code></a>) of the
+client will be encoded into the session identifier, i.e. if this value
+changes on the client side, the session will automatically be
+invalidated.
+<p>
+Note that this is not secure, because it's obviously not very hard to
+fake an <code>X_FORWARDED_FOR</code> header. On the other hand,
+relying on the remote address (see <a
+href="#remote-addr"><code>REMOTE-ADDR</code></a>) of the client isn't
+an ideal solution either, because some of your users may connect
+through http proxies and the proxy they use may change during the
+session. But then again, some proxies don't
+send <code>X_FORWARDED_FOR</code> headers anyway. Sigh...
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*use-user-agent-for-sessions*"><b>*use-user-agent-for-sessions*</b></a>
+
+<blockquote><br> If this value is <em>true</em> (which is the default)
+then the 'User-Agent' http header (see <a
+href="#user-agent"><code>USER-AGENT</code></a>) of the client will be
+encoded into the session identifier, i.e. if this value changes on the
+client side the session will automatically be invalidated.
+<p>
+While this is intended to make the life of malicious users harder, it
+might affect legitimate users as well: I've seen this http
+header change with certain browsers when the Java plug-in was used.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*rewrite-for-session-urls*"><b>*rewrite-for-session-urls*</b></a>
+
+<blockquote><br> If this value is <em>true</em> (which is the default)
+then content bodies sent by Hunchentoot will be rewritten
+(using <a href='http://weitz.de/url-rewrite/'>URL-REWRITE</a>) such
+that GET parameters for session handling are appended to all relevant
+URLs. This only happens, though, if the body's content type (see <a
+href="#content-type"><code>CONTENT-TYPE</code></a>) starts
+with one of the strings in <a href="#*content-types-for-url-rewrite*"><code>*CONTENT-TYPES-FOR-URL-REWRITE*</code></a> and unless the client has already sent a cookie named <a href="#*session-cookie-name*"><code>*SESSION-COOKIE-NAME*</code></a>.
+<p>
+Note that the function which rewrites the body doesn't understand
+Javascript, so you have to take care of URLs in Javascript code yourself.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*content-types-for-url-rewrite*"><b>*content-types-for-url-rewrite*</b></a>
+
+<blockquote><br>
+This is a list of strings (the initial value is
+<code>("text/html"&nbsp;"application/xhtml+xml")</code>) the
+content-type of an outgoing body is compared with if <a
+href="#*rewrite-for-session-urls*"><code>*REWRITE-FOR-SESSION-URLS*</code></a>
+is true. If the content-type starts with one of these strings, then
+url-rewriting will happen, otherwise it won't.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-cookie-name*"><b>*session-cookie-name*</b></a>
+
+<blockquote><br>
+
+This is the name that is used for the session-related cookie or GET
+parameter sent to the client. Its default value
+is <code>"hunchentoot-session"</code>. Note that changing this name while
+Hunchentoot is running will invalidate existing sessions.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-removal-hook*"><b>*session-removal-hook*</b></a>
+
+<blockquote><br>
+The value of this variable should be a function of one argument, a <code>SESSION</code> object. This function is called directly before the session is destroyed, either by <a href="#reset-sessions"><code>RESET-SESSIONS</code></a>, by <a href="#remove-session"><code>REMOVE-SESSION</code></a>, or when it's invalidated because it's too old.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-max-time*"><b>*session-max-time*</b></a>
+
+<blockquote><br>
+The default time (in seconds) after which a session times out - see <a href="#session-max-time"><code>SESSION-MAX-TIME</code></a>.  This value is initially set to&nbsp;1800.
+</blockquote>
+
+<p><br>[Macro]
+<br><a class=none name="do-sessions"><b>do-sessions</b> <i>(var</i> <tt>&amp;optional</tt> <i>result-form) statement*</i> =&gt; <i>result</i></a>
+
+<blockquote><br>
+
+Executes the statements with <code><i>var</i></code> bound to each
+existing <code>SESSION</code> object consecutively. An implicit block
+named <code>NIL</code> surrounds the body of this macro. Returns the
+values returned by <code><i>result-form</i></code> unless
+<code>RETURN</code> is executed. The scope of the binding of
+<code><i>var</i></code> does <em>not</em> include
+<code><i>result-form</i></code>.
+
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*session-gc-frequency*"><b>*session-gc-frequency*</b></a>
+
+<blockquote><br>
+A session garbage collection (see <a href="#session-gc"><code>SESSION-GC</code></a>) will happen every
+<a
+href="#*session-gc-frequency*"><code>*SESSION-GC-FREQUENCY*</code></a>
+requests (counting only requests which use sessions) if the value of
+this variable is not <code>NIL</code>.  It's default value is&nbsp;50.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="session-gc"><b>session-gc</b> =&gt; |</a>
+
+<blockquote><br>
+Deletes sessions which are too old - see
+<a href="#session-too-old-p"><code>SESSION-TOO-OLD-P</code></a>.
+Usually, you don't call this function directly -
+see <a
+href="#*session-gc-frequency*"><code>*SESSION-GC-FREQUENCY*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="session-too-old-p"><b>session-too-old-p</b> <i>session</i>  =&gt; generalized-boolean</a>
+
+<blockquote><br> Returns a true value if the <code>SESSION</code>
+object <code><i>session</i></code> is <a href="#session-max-time">too old</a> and would be deleted
+during the next <a href="#session-gc">session&nbsp;GC</a>.  You don't
+have to check this manually for sessions
+in <a href="#*session*"><code>*SESSION*</code></a>, but it might be
+useful if you want to <a href="#do-sessions">loop through all
+sessions</a>.
+</blockquote>
+
+
+<h4><a class=none name="log">Logging and error handling</a></h4>
+
+Hunchentoot provides facilities for writing to Apache's error log
+file (when using the mod_lisp front-end) or for logging to an arbitrary file in the file system. Note that, due to the nature of mod_lisp, Apache log mesages don't appear immediately but only after all data has been sent from Hunchentoot to Apache/mod_lisp.
+<p>
+Furthermore, all errors happening within a <a href='#handlers'>handler</a> which are not
+caught by the handler itself are handled by Hunchentoot - see details below.
+
+<p><br>[Accessor]
+<br><a class=none name="log-file"><b>log-file</b> =&gt; <i>pathname</i>
+<br><tt>(setf (</tt><b>log-file</b>) <i>pathspec</i><tt>)</tt></a>
+
+<blockquote><br>
+The function <code>LOG-FILE</code> returns a pathname designating the log file which is currently used (unless log messages are forwarded to Apache).  This destination for log messages can be changed with <code>(SETF&nbsp;LOG-FILE)</code>.  The initial location of the log file is implementation-dependent.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="log-message"><b>log-message</b> <i>log-level format</i> <tt>&amp;rest</tt> <i>args</i> =&gt; |</a>
+
+<blockquote><br> Schedules a message for the Apache log file or writes
+it directly to <a href="#log-file">the current log file</a> depending
+on the value of the <code><i>use-apache-log-p</i></code> argument
+to <a href="#start-server"><code>START-SERVER</code></a>. <code><i>log-level</i></code>
+should be one of the
+keywords <code>:EMERG</code>, <code>:ALERT</code>, <code>:CRIT</code>, <code>:ERROR</code>, <code>:WARNING</code>, <code>:NOTICE</code>, <code>:INFO</code>,
+or <code>:DEBUG</code> which correspond to the various Apache log
+levels. <code><i>log-level</i></code> can also be <code>NIL</code> (in
+which case mod_lisp's default log level is used.  If Apache isn't used, the log level is just written
+to the log file unless it's <code>NIL</code>.
+<code><i>format</i></code> and <code><i>args</i></code> are used as with 
+<a href='http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm'><code>FORMAT</code></a>.
+<p>
+<code>LOG-MESSAGE</code> is a generic function, so you can specialize it or bypass it completely with an around method.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="log-message*"><b>log-message*</b> <i>format</i> <tt>&amp;rest</tt> <i>args</i> =&gt; |</a>
+
+<blockquote><br>
+Like <a href="#log-message"><code>LOG-MESSAGE</code></a> but with <code><i>log-level</i></code> set to <a href="#*default-log-level*"><code>*DEFAULT-LOG-LEVEL*</code></a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*default-log-level*"><b>*default-log-level*</b></a>
+
+<blockquote><br>
+The log level used by <a href="#log-message*"><code>LOG-MESSAGE*</code></a>. The initial value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-errors-p*"><b>*log-lisp-errors-p*</b></a>
+
+<blockquote><br>
+Whether unhandled errors in <a href='#handlers'>handlers</a> should be logged. See also <a href="#*lisp-errors-log-level*"><code>*LISP-ERRORS-LOG-LEVEL*</code></a>. The default value is <code>T</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*lisp-errors-log-level*"><b>*lisp-errors-log-level*</b></a>
+
+<blockquote><br>
+The log level used to log Lisp errors. See also <a href="#*log-lisp-errors-p*"><code>*LOG-LISP-ERRORS-P*</code></a>. The default value is <code>:ERROR</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-warnings-p*"><b>*log-lisp-warnings-p*</b></a>
+
+<blockquote><br>
+Whether unhandled warnings in <a href='#handlers'>handlers</a> should be logged. See also <a href="#*lisp-warnings-log-level*"><code>*LISP-WARNINGS-LOG-LEVEL*</code></a>. The default value is <code>T</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*lisp-warnings-log-level*"><b>*lisp-warnings-log-level*</b></a>
+
+<blockquote><br>
+The log level used to log Lisp warnings. See also <a href="#*log-lisp-warnings-p*"><code>*LOG-LISP-WARNINGS-P*</code></a>. The default value is <code>:WARNING</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-lisp-backtraces-p*"><b>*log-lisp-backtraces-p*</b></a>
+
+<blockquote><br>
+Whether backtraces should also be logged in addition to error messages and warnings. This value will only have effect if <a href="#*log-lisp-errors-p*"><code>*LOG-LISP-ERRORS-P*</code></a> or <a href="#*log-lisp-warnings-p*"><code>*LOG-LISP-WARNINGS-P*</code></a> is <em>true</em>.  The default value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*log-prefix*"><b>*log-prefix*</b></a>
+
+<blockquote><br>
+All messages written to the Apache error log by Hunchentoot are prepended by a string which is the value of this variable enclosed in square brackets. If the value is <code>NIL</code>, however, no such prefix will be written. If the value is <code>T</code> (which is the default), the prefix will be <code>"[Hunchentoot]"</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-lisp-errors-p*"><b>*show-lisp-errors-p*</b></a>
+
+<blockquote><br>
+Whether unhandled Lisp errors should be shown to the user. If this value is <code>NIL</code> (which is the default), only the message <em>An error has occurred</em> will be shown.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-lisp-backtraces-p*"><b>*show-lisp-backtraces-p*</b></a>
+
+<blockquote><br>
+Whether backtraces should also be shown to the user. This value will only have effect if <a href="#*show-lisp-errors-p*"><code>*SHOW-LISP-ERRORS-P*</code></a> is <em>true</em>.  The default value is <code>NIL</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*show-access-log-messages*"><b>*show-access-log-messages*</b></a>
+
+<blockquote><br>
+If this variable is <em>true</em> <em>and</em> if the value of the <code><i>use-apache-log-p</i></code> argument to <a href="#start-server"><code>START-SERVER</code></a> was <code>NIL</code>, then for each request a line somewhat similar to what can be found in Apache's access log will be written to the <a href="#log-file">log file</a>.  The default value of this variable is <code>T</code>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*http-error-handler*"><b>*http-error-handler*</b></a>
+
+<blockquote><br>
+This variable holds <code>NIL</code> (the default) or a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function designator</a> for a function of one argument. The function gets called if the responsible <a href="#handlers">handler</a> has set a return code which is not in <a href="#*approved-return-codes*"><code>*APPROVED-RETURN-CODES*</code></a> and <a href="#*handle-http-errors-p*"><code>*HANDLE-HTTP-ERRORS-P*</code></a> is true.  It receives the return code as its argument and can return the contents of an error page or <code>NIL</code> if it refuses to handle the error, i.e. if Hunchentoot's default error page should be shown. (Note that the function can access the request and reply data.)
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*handle-http-errors-p*"><b>*handle-http-errors-p*</b></a>
+
+<blockquote><br> This variable holds a generalized boolean that
+determines whether return codes not in <a href="#*approved-return-codes*"><code>*APPROVED-RETURN-CODES*</code></a>
+are treated specially.  When its value is true (the default), either a
+default body for the return code or the result of
+calling <a
+href="#*http-error-handler*"><code>*HTTP-ERROR-HANDLER*</code></a> is
+used.  When the value is <code>NIL</code>, no special action is taken
+and you are expected to supply your own response body to describe the
+error.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*approved-return-codes*"><b>*approved-return-codes*</b></a>
+<blockquote><br> 
+A list of return codes the server should not treat as an error -
+see <a href="#*handle-http-errors-p*"><code>*HANDLE-HTTP-ERRORS-P*</code></a>.  The initial value is the list with the values of
+<a href="#+http-ok+"><code>+HTTP-OK+</code></a>, <a href="#+http-no-content+"><code>+HTTP-NO-CONTENT+</code></a>, <a href="#+http-multi-status+"><code>+HTTP-MULTI-STATUS+</code></a>, and <a href="#+http-not-modified+"><code>+HTTP-NOT-MODIFIED+</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="get-backtrace"><b>get-backtrace</b> <i>condition</i> =&gt; <i>backtrace</i></a>
+
+<blockquote><br>
+This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object <code><i>condition</i></code> and
+returns a string with the corresponding backtrace.
+</blockquote>
+
+<h4><a class=none name="debug">Debugging Hunchentoot applications</a></h4>
+
+The best option to debug a Hunchentoot application is
+probably <a href="#*catch-errors-p*">to use the debugger</a>.
+<p>
+One important thing you should try if you're behind mod_lisp is to
+use <a href="#log">an external log file</a> (as opposed to Apache's
+log) because it can reveal error messages that might otherwise get
+lost if something's broken in the communication between Hunchentoot
+and mod_lisp.
+<p>
+Good luck... :)
+
+<p><br>[Special variable]
+<br><a class=none name="*catch-errors-p*"><b>*catch-errors-p*</b></a>
+
+<blockquote><br> If the value of this variable is <code>NIL</code>
+(the default is <code>T</code>), then errors which happen while a
+request is handled aren't <a href="#log">caught as usual</a>, but
+instead your
+Lisp's <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#debugger">debugger</a>
+is <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invoke.htm">invoked</a>.
+This variable should obviously always be set to a <em>true</em> value
+in a production environment.
+See <a
+href="#maybe-invoke-debugger"><code>MAYBE-INVOKE-DEBUGGER</code></a>
+if you want to fine-tune this behaviour.
+</blockquote>
+
+<p><br>[Generic function]
+<br><a class=none name="maybe-invoke-debugger"><b>maybe-invoke-debugger</b> <i>condition</i> =&gt; |</a>
+
+<blockquote><br>
+This generic function is called whenever a
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/09_.htm">condition</a> <code><i>condition</i></code>
+is signaled in Hunchentoot.  You might want to specialize it on
+specific condition classes for debugging purposes.  The default
+method <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_invoke.htm">invokes
+the debugger</a> with <code><i>condition</i></code> if
+<a href="#*catch-errors-p*"><code>*CATCH-ERRORS-P*</code></a> is <code>NIL</code>.
+</blockquote>
+
+
+<p><br>[Special variable]
+<br><a class=none name="*header-stream*"><b>*header-stream*</b></a>
+
+<blockquote><br>
+If this variable is not <code>NIL</code>, it should be bound to a stream to
+which incoming and outgoing headers will be written for debugging
+purposes.
+</blockquote>
+
+<h4><a class=none name="misc">Miscellaneous</a></h4>
+
+Various functions and variables which didn't fit into one of the other categories.
+
+<p><br>[Function]
+<br><a class=none name="ssl-p"><b>ssl-p</b> =&gt; generalized-boolean</a>
+
+<blockquote><br>
+Whether the current connection to the client is secure.
+</blockquote>
+
+<p><br>[Symbol]
+<br><a class=none name="handler-done"><b>handler-done</b></a>
+
+<blockquote><br> This is a <a
+href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch_tag'><em>catch
+tag</em></a> which names a <a
+href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#catch'><em>catch</em></a>
+which is active during the lifetime of a <a
+href='#handlers'>handler</a>. The handler can at any time <a
+href='http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#throw'><em>throw</em></a>
+the outgoing content body (or <code>NIL</code>) to this catch to immediately abort handling the request. See the source code of <a href="#redirect"><code>REDIRECT</code></a> for an example.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="no-cache"><b>no-cache</b> =&gt; |</a>
+
+<blockquote><br> 
+This function will set appropriate outgoing headers to completely prevent caching on virtually all browsers.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="handle-if-modified-since"><b>handle-if-modified-since</b> <i>time</i> =&gt; |</a>
+
+<blockquote><br>
+
+This function is designed to be used inside a <a
+href='#handlers'>handler</a>. If the client has sent an
+'If-Modified-Since' header (see <a
+href='http://www.faqs.org/rfcs/rfc2616.html'>RFC&nbsp;2616</a>,
+section 14.25) and the time specified matches the universal time
+<code><i>time</i></code> then the header <a
+href="#+http-not-modified+"><code>+HTTP-NOT-MODIFIED+</code></a> with
+no content is immediately returned to the client.
+<p>
+Note that for this function to be useful you should usually send
+'Last-Modified' headers back to the client. See the code of <a
+href="#create-static-file-dispatcher-and-handler"><code>CREATE-STATIC-FILE-DISPATCHER-AND-HANDLER</code></a>
+for an example.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="rfc-1123-date"><b>rfc-1123-date</b> <tt>&amp;optional</tt> <i>time</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+
+This function accepts a universal time <code><i>time</i></code>
+(default is the current time) and returns a string which encodes this time according to <a
+href='http://www.faqs.org/rfcs/rfc1123.html'>RFC&nbsp;1123</a>. This can be used to send a 'Last-Modified' header - see <a
+href="#handle-if-modified-since"><code>HANDLE-IF-MODIFIED-SINCE</code></a>.
+
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="redirect"><b>redirect</b> <i>target</i> <tt>&amp;key</tt> <i>host port protocol add-session-id permanently</i> =&gt; |</a>
+
+<blockquote><br> Sends back appropriate headers to redirect the client
+to <code><i>target</i></code> (a string).
+
+If <code><i>target</i></code> is a full URL starting with a scheme, <code><i>host</i></code>, <code><i>port</i></code>, and <code><i>protocol</i></code>
+are ignored.  Otherwise, <code><i>target</i></code> should denote the path part of a
+URL, <code><i>protocol</i></code> must be one of the keywords <code>:HTTP</code> or <code>:HTTPS</code>, and
+the URL to redirect to will be constructed from <code><i>host</i></code>, <code><i>port</i></code>, <code><i>protocol</i></code>,
+and <code><i>target</i></code>.
+<p>
+If <code><i>permanently</i></code>
+is <em>true</em> (the default is <code>NIL</code>), a 301&nbsp;status
+code will be sent, otherwise a 302&nbsp;status code. If <code><i>host</i></code>
+is not provided, the current host (see <a
+href="#host"><code>HOST</code></a>) will be
+used. If <code><i>protocol</i></code> is the
+keyword <code>:HTTPS</code>, the client will be redirected to a https
+URL, if it's <code>:HTTP</code> it'll be sent to a http URL.  If
+both <code><i>host</i></code> and <code><i>protocol</i></code> aren't
+provided, then the value of <code><i>protocol</i></code> will
+match the current request.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="require-authorization"><b>require-authorization</b> <tt>&amp;optional</tt> <i>realm</i> =&gt; |</a>
+
+<blockquote><br> 
+Sends back appropriate headers to require basic HTTP authentication (see <a href='http://www.faqs.org/rfcs/rfc2617.html'>RFC&nbsp;2617</a>) for the realm <code><i>realm</i></code>. The default value for <code><i>realm</i></code> is <code>"Hunchentoot"</code>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="escape-for-html"><b>escape-for-html</b> <i>string</i> =&gt; <i>escaped-string</i></a>
+
+<blockquote><br> 
+Escapes all occurrences of the characters <code>#\&lt;</code>, <code>#\&gt;</code>, <code>#\'</code>, <code>#&quot;</code>, and <code>#\&amp;</code> within <code><i>string</i></code> for HTML output.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="url-encode"><b>url-encode</b> <i>string</i> <tt>&amp;optional</tt> <i>external-format</i> =&gt; <i>url-encoded-string</i></a>
+
+<blockquote><br>
+URL-encodes a string using the external format <code><i>external-format</i></code>.  The default for <code><i>external-format</i></code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="url-decode"><b>url-decode</b> <i>string</i> <tt>&amp;optional</tt> <i>external-format</i> =&gt; <i>url-encoded-string</i></a>
+
+<blockquote><br>
+URL-decodes a string using the external format <code><i>external-format</i></code>, i.e. this is the inverse of <a href="#url-encode"><code>URL-ENCODE</code></a>.
+It is assumed that you'll rarely need this function, if ever.  But just in case - here it is.
+The default for <code><i>external-format</i></code> is the value of <a href="#*hunchentoot-default-external-format*"><code>*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*</code></a>.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="http-token-p"><b>http-token-p</b> <i>object</i> =&gt; <i>generalized-boolean</i></a>
+
+<blockquote><br> This function tests
+whether <code><i>object</i></code> is a non-empty string which is
+a <em>token</em> according to <a href='http://www.faqs.org/rfcs/rfc2068.html'>RFC 2068</a> (i.e. whether it may be used
+for, say, cookie names).
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none name="*tmp-directory*"><b>*tmp-directory*</b></a>
+
+<blockquote><br>
+This should be a pathname denoting a directory where temporary files can be stored. It is used for <a href="#upload">file uploads</a>.
+</blockquote>
+
+<p><br>[Special variable]
+<br><a class=none
+name="*hunchentoot-default-external-format*"><b>*hunchentoot-default-external-format*</b></a>
+
+<blockquote><br> The (<a href="http://weitz.de/flexi-streams/">flexi
+stream</a>) external format used when computing
+the <a href="#requests"><code>REQUEST</code></a> object.  The default
+value is the result of evaluating
+<pre>
+(<a class=noborder href="http://weitz.de/flexi-streams/#make-external-format">flex:make-external-format</a> :latin1 :eol-style :lf)
+</pre>
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="mime-type"><b>mime-type</b> <i>pathspec</i> =&gt; <i>string</i></a>
+
+<blockquote><br>
+Given a pathname designator <code><i>pathspec</i></code> returns the <a href="http://en.wikipedia.org/wiki/Internet_media_type">MIME type</a>
+(as a string) corresponding to the suffix of the file denoted by
+<code><i>pathspec</i></code> (or <code>NIL</code> if none can be
+found).  This is based on the table coming with the Apache
+distribution with some additions.
+</blockquote>
+
+<p><br>[Function]
+<br><a class=none name="reason-phrase"><b>reason-phrase</b> <i>return-code</i> =&gt; <i>string</i></a>
+
+<blockquote><br> Returns a reason phrase for the HTTP return
+code <code><i>return-code</i></code> (which should be an integer)
+or <code>NIL</code> for return codes Hunchentoot doesn't know.
+</blockquote>
+
+<br>&nbsp;<br><h3><a class=none name="ht-mp">The HUNCHENTOOT-MP package</a></h3>
+
+Hunchentoot creates an
+additional <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/11_.htm">package</a> <code>HUNCHENTOOT-MP</code>
+which exports a couple of MP-related symbols
+(namely <code>*CURRENT-PROCESS*</code>, <code>MAKE-LOCK</code>, <code>WITH-LOCK</code>, <code>PROCESS-RUN-FUNCTION</code>,
+and <code>PROCESS-KILL</code>).  These functions and macros have to be
+in Hunchentoot's small portability shim anyway and even if you don't
+spawn your own threads there might be occasions where you want to at
+least use the lock-related functionality to write thread-safe portable
+code.  See the corresponding documentation strings and/or the source
+code for more information.
+
+<br>&nbsp;<br><h3><a class=none name="performance">Performance</a></h3>
+
+If you're concerned about Hunchentoot's performance, you should first
+and foremost check if you aren't wasting your time with premature
+optimization.  Make a reasonable estimate of the amount of traffic
+your website should be able to handle and don't try to benchmark for
+loads Google would be proud of.  Here's a part of an interview with
+someone called John Witchel about his experiences with his
+company <em>Red Gorilla</em> that can't be quoted often enough (it
+seems the original source of the interview has vanished):
+
+<blockquote>
+<b>Q:</b> If you could go back and change anything, would <em>Red Gorilla</em> still be
+in business today?
+<p>
+<b>A:</b> Yes. I would start small and grow as the demand grew. That's what I'm
+doing now.
+<p>
+Back then we planned to be huge from the outset. So we built this
+monster platform on BEA, Sun and Oracle. We had huge dedicated
+connectivity pipes. We had two full racks clustered and fully
+redundant. We had E450's with RAID-5 and all 4 CPU slots filled,
+E250s, F5 load balancers... the cost of keeping that system on was
+enormous. The headcount to keep it humming was enormous too.
+<p>
+The truth is, we could have run the whole company on my laptop using a
+cable modem connection.
+</blockquote>
+
+Having said that, my experience is that Hunchentoot doesn't have to
+hide when it comes to
+serving <a href="#handle-static-file">static files</a>.  If
+you <em>really</em> have performance problems with Hunchentoot, there
+are two things I'm aware of you should watch out for.
+<ul>
+<li>Check how your Lisp implementation implements multi-processing.
+While I write this (April 2007), some Lisps, like CMUCL, still use
+their
+own <a
+href="http://en.wikipedia.org/wiki/Multithreading"><em>green</em>
+threads</a>, and some others, like AllegroCL and LispWorks, use
+OS-threads but allow only one Lisp thread at a time.  Unless you're
+using a Lisp that employs "real" symmetric multi-processing like SBCL
+(on some platforms) or OpenMCL, you shouldn't compare apples with
+oranges.  (Note: For CMUCL, you also shouldn't forget to use the
+dreaded <a
+href="http://wiki.alu.org/Lisp_Gotchas"><code>MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS</code></a>.)
+<li>All text output sent from <a href="#handlers">handlers</a> goes
+through two layers
+of <a
+href="http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html">Gray
+streams</a> by default
+(<a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a>
+and <a href="http://weitz.de/chunga/">Chunga</a>).  This isn't an
+issue for small to medium-sized pages, but can be for large ones.
+There are several ways to cope with this
+- <a
+href="http://common-lisp.net/pipermail/tbnl-devel/2007-March/001093.html">return
+binary data from
+handlers</a>, <a
+href="http://common-lisp.net/pipermail/tbnl-devel/2007-March/001099.html">bypass
+FLEXI-STREAMS</a>, sit behind <a href="#mod_lisp">mod_lisp</a>, etc.
+Try it, and if you <em>really</em> think that Hunchentoot is too slow
+for what you're trying to do and what you'll need, ask on
+the <a href="#href">mailing list</a> and we'll try to help.
+</ul>
+
+<br>&nbsp;<br><h3><a class=none name="history">History</a></h3>
+
+Hunchentoot's predecessor <a href="http://weitz.de/tbnl/">TBNL</a>
+(which is short for &quot;To Be Named Later&quot;) grew over the years
+as a toolkit that I used for various commercial and private
+projects. In August&nbsp;2003, Daniel Barlow started
+a <a href='http://article.gmane.org/gmane.lisp.web/148'>review of web
+APIs</a> on the <a href='http://www.red-bean.com/lispweb/'>lispweb</a>
+mailing list and
+I <a href='http://article.gmane.org/gmane.lisp.web/153'>described</a>
+the API of my hitherto-unreleased bunch of code (and christened it
+"TBNL").
+<p>
+It turned out that <a href='http://www.jeffcaldwell.com/'>Jeff
+Caldwell</a> had worked on something similar so he emailed me and
+proposed to join our efforts. As I had no immediate plans to release
+my code (which was poorly organized, undocumented, and mostly
+CMUCL-specific), I gave it to Jeff and he worked towards a release. He
+added docstrings, refactored, added some stuff, and based it on KMRCL
+to make it portable across several Lisp implementations.
+<p>
+Unfortunately, Jeff is at least as busy as I am so he didn't find the
+time to finish a full release. But in spring&nbsp;2004 I needed a
+documented version of the code for a client of mine who thought
+it would be good if the toolkit were publicly available under an open
+source license. So I took Jeff's code, refactored again (to sync with
+the changes I had done in the meantime), and added documentation.
+This resulted in TBNL&nbsp;0.1.0 (which initially required mod_lisp as its
+front-end).  Jeff's code (which includes a lot more stuff that I
+didn't use) is still available from his own
+website <a href='http://tbnl.org/'>tbnl.org</a>.
+<p>
+In March&nbsp;2005, Bob Hutchinson sent patches which enabled TBNL to use
+other front-ends than mod_lisp.  This made me aware that TBNL was
+already <em>almost</em> a full web server, so eventually I wrote
+Hunchentoot which <em>was</em> a full web server, implemented as a
+wrapper around TBNL.  Hunchentoot&nbsp;0.1.0 was released at the end of
+2005 and was originally LispWorks-only.
+<p>
+Hunchentoot&nbsp;0.4.0, released in October&nbsp;2006, was the first release
+which also worked with other Common Lisp implementations.  It is a
+major rewrite and also incorporates most of TBNL and replaces
+it completely.
+
+<br>&nbsp;<br><h3><a class=none name="index">Symbol index</a></h3>
+
+Here are all exported symbols of the <code>HUNCHENTOOT</code> package
+in alphabetical order linked to their corresponding entries:
+
+    <ul>
+      <li><a href="#*approved-return-codes*"><code>*approved-return-codes*</code></a>
+      <li><a href="#*catch-errors-p*"><code>*catch-errors-p*</code></a>
+      <li><a href="#*cleanup-function*"><code>*cleanup-function*</code></a>
+      <li><a href="#*cleanup-interval*"><code>*cleanup-interval*</code></a>
+      <li><a href="#*content-types-for-url-rewrite*"><code>*content-types-for-url-rewrite*</code></a>
+      <li><a href="#*default-content-type*"><code>*default-content-type*</code></a>
+      <li><a href="#*default-handler*"><code>*default-handler*</code></a>
+      <li><a href="#*default-log-level*"><code>*default-log-level*</code></a>
+      <li><a href="#*default-read-timeout*"><code>*default-read-timeout*</code></a>
+      <li><a href="#*default-write-timeout*"><code>*default-write-timeout*</code></a>
+      <li><a href="#*dispatch-table*"><code>*dispatch-table*</code></a>
+      <li><a href="#*file-upload-hook*"><code>*file-upload-hook*</code></a>
+      <li><a href="#*handle-http-errors-p*"><code>*handle-http-errors-p*</code></a>
+      <li><a href="#*header-stream*"><code>*header-stream*</code></a>
+      <li><a href="#*http-error-handler*"><code>*http-error-handler*</code></a>
+      <li><a href="#*hunchentoot-default-external-format*"><code>*hunchentoot-default-external-format*</code></a>
+      <li><a href="#*lisp-errors-log-level*"><code>*lisp-errors-log-level*</code></a>
+      <li><a href="#*lisp-warnings-log-level*"><code>*lisp-warnings-log-level*</code></a>
+      <li><a href="#*log-lisp-backtraces-p*"><code>*log-lisp-backtraces-p*</code></a>
+      <li><a href="#*log-lisp-errors-p*"><code>*log-lisp-errors-p*</code></a>
+      <li><a href="#*log-lisp-warnings-p*"><code>*log-lisp-warnings-p*</code></a>
+      <li><a href="#*log-prefix*"><code>*log-prefix*</code></a>
+      <li><a href="#*meta-dispatcher*"><code>*meta-dispatcher*</code></a>
+      <li><a href="#*methods-for-post-parameters*"><code>*methods-for-post-parameters*</code></a>
+      <li><a href="#*reply*"><code>*reply*</code></a>
+      <li><a href="#*request*"><code>*request*</code></a>
+      <li><a href="#*rewrite-for-session-urls*"><code>*rewrite-for-session-urls*</code></a>
+      <li><a href="#*server*"><code>*server*</code></a>
+      <li><a href="#*session*"><code>*session*</code></a>
+      <li><a href="#*session-cookie-name*"><code>*session-cookie-name*</code></a>
+      <li><a href="#*session-gc-frequency*"><code>*session-gc-frequency*</code></a>
+      <li><a href="#*session-max-time*"><code>*session-max-time*</code></a>
+      <li><a href="#*session-removal-hook*"><code>*session-removal-hook*</code></a>
+      <li><a href="#*show-access-log-messages*"><code>*show-access-log-messages*</code></a>
+      <li><a href="#*show-lisp-backtraces-p*"><code>*show-lisp-backtraces-p*</code></a>
+      <li><a href="#*show-lisp-errors-p*"><code>*show-lisp-errors-p*</code></a>
+      <li><a href="#*tmp-directory*"><code>*tmp-directory*</code></a>
+      <li><a href="#*use-remote-addr-for-sessions*"><code>*use-remote-addr-for-sessions*</code></a>
+      <li><a href="#*use-user-agent-for-sessions*"><code>*use-user-agent-for-sessions*</code></a>
+      <li><a href="#+http-accepted+"><code>+http-accepted+</code></a>
+      <li><a href="#+http-authorization-required+"><code>+http-authorization-required+</code></a>
+      <li><a href="#+http-bad-gateway+"><code>+http-bad-gateway+</code></a>
+      <li><a href="#+http-bad-request+"><code>+http-bad-request+</code></a>
+      <li><a href="#+http-conflict+"><code>+http-conflict+</code></a>
+      <li><a href="#+http-continue+"><code>+http-continue+</code></a>
+      <li><a href="#+http-created+"><code>+http-created+</code></a>
+      <li><a href="#+http-expectation-failed+"><code>+http-expectation-failed+</code></a>
+      <li><a href="#+http-failed-dependency+"><code>+http-failed-dependency+</code></a>
+      <li><a href="#+http-forbidden+"><code>+http-forbidden+</code></a>
+      <li><a href="#+http-gateway-time-out+"><code>+http-gateway-time-out+</code></a>
+      <li><a href="#+http-gone+"><code>+http-gone+</code></a>
+      <li><a href="#+http-internal-server-error+"><code>+http-internal-server-error+</code></a>
+      <li><a href="#+http-length-required+"><code>+http-length-required+</code></a>
+      <li><a href="#+http-method-not-allowed+"><code>+http-method-not-allowed+</code></a>
+      <li><a href="#+http-moved-permanently+"><code>+http-moved-permanently+</code></a>
+      <li><a href="#+http-moved-temporarily+"><code>+http-moved-temporarily+</code></a>
+      <li><a href="#+http-multi-status+"><code>+http-multi-status+</code></a>
+      <li><a href="#+http-multiple-choices+"><code>+http-multiple-choices+</code></a>
+      <li><a href="#+http-no-content+"><code>+http-no-content+</code></a>
+      <li><a href="#+http-non-authoritative-information+"><code>+http-non-authoritative-information+</code></a>
+      <li><a href="#+http-not-acceptable+"><code>+http-not-acceptable+</code></a>
+      <li><a href="#+http-not-found+"><code>+http-not-found+</code></a>
+      <li><a href="#+http-not-implemented+"><code>+http-not-implemented+</code></a>
+      <li><a href="#+http-not-modified+"><code>+http-not-modified+</code></a>
+      <li><a href="#+http-ok+"><code>+http-ok+</code></a>
+      <li><a href="#+http-partial-content+"><code>+http-partial-content+</code></a>
+      <li><a href="#+http-payment-required+"><code>+http-payment-required+</code></a>
+      <li><a href="#+http-precondition-failed+"><code>+http-precondition-failed+</code></a>
+      <li><a href="#+http-proxy-authentication-required+"><code>+http-proxy-authentication-required+</code></a>
+      <li><a href="#+http-request-entity-too-large+"><code>+http-request-entity-too-large+</code></a>
+      <li><a href="#+http-request-time-out+"><code>+http-request-time-out+</code></a>
+      <li><a href="#+http-request-uri-too-large+"><code>+http-request-uri-too-large+</code></a>
+      <li><a href="#+http-requested-range-not-satisfiable+"><code>+http-requested-range-not-satisfiable+</code></a>
+      <li><a href="#+http-reset-content+"><code>+http-reset-content+</code></a>
+      <li><a href="#+http-see-other+"><code>+http-see-other+</code></a>
+      <li><a href="#+http-service-unavailable+"><code>+http-service-unavailable+</code></a>
+      <li><a href="#+http-switching-protocols+"><code>+http-switching-protocols+</code></a>
+      <li><a href="#+http-temporary-redirect+"><code>+http-temporary-redirect+</code></a>
+      <li><a href="#+http-unsupported-media-type+"><code>+http-unsupported-media-type+</code></a>
+      <li><a href="#+http-use-proxy+"><code>+http-use-proxy+</code></a>
+      <li><a href="#+http-version-not-supported+"><code>+http-version-not-supported+</code></a>
+      <li><a href="#authorization"><code>authorization</code></a>
+      <li><a href="#aux-request-value"><code>aux-request-value</code></a>
+      <li><a href="#content-length"><code>content-length</code></a>
+      <li><a href="#content-type"><code>content-type</code></a>
+      <li><a href="#cookie-domain"><code>cookie-domain</code></a>
+      <li><a href="#cookie-expires"><code>cookie-expires</code></a>
+      <li><a href="#cookie-http-only"><code>cookie-http-only</code></a>
+      <li><a href="#cookie-in"><code>cookie-in</code></a>
+      <li><a href="#cookie-name"><code>cookie-name</code></a>
+      <li><a href="#cookie-out"><code>cookie-out</code></a>
+      <li><a href="#cookie-path"><code>cookie-path</code></a>
+      <li><a href="#cookie-secure"><code>cookie-secure</code></a>
+      <li><a href="#cookie-value"><code>cookie-value</code></a>
+      <li><a href="#cookies-in"><code>cookies-in</code></a>
+      <li><a href="#cookies-out"><code>cookies-out</code></a>
+      <li><a href="#create-folder-dispatcher-and-handler"><code>create-folder-dispatcher-and-handler</code></a>
+      <li><a href="#create-prefix-dispatcher"><code>create-prefix-dispatcher</code></a>
+      <li><a href="#create-regex-dispatcher"><code>create-regex-dispatcher</code></a>
+      <li><a href="#create-static-file-dispatcher-and-handler"><code>create-static-file-dispatcher-and-handler</code></a>
+      <li><a href="#default-dispatcher"><code>default-dispatcher</code></a>
+      <li><a href="#define-easy-handler"><code>define-easy-handler</code></a>
+      <li><a href="#delete-aux-request-value"><code>delete-aux-request-value</code></a>
+      <li><a href="#delete-session-value"><code>delete-session-value</code></a>
+      <li><a href="#dispatch-easy-handlers"><code>dispatch-easy-handlers</code></a>
+      <li><a href="#dispatch-request"><code>dispatch-request</code></a>
+      <li><a href="#do-sessions"><code>do-sessions</code></a>
+      <li><a href="#escape-for-html"><code>escape-for-html</code></a>
+      <li><a href="#get-backtrace"><code>get-backtrace</code></a>
+      <li><a href="#get-parameter"><code>get-parameter</code></a>
+      <li><a href="#get-parameters"><code>get-parameters</code></a>
+      <li><a href="#handle-if-modified-since"><code>handle-if-modified-since</code></a>
+      <li><a href="#handle-static-file"><code>handle-static-file</code></a>
+      <li><a href="#handler-done"><code>handler-done</code></a>
+      <li><a href="#header-in"><code>header-in</code></a>
+      <li><a href="#header-out"><code>header-out</code></a>
+      <li><a href="#headers-in"><code>headers-in</code></a>
+      <li><a href="#headers-out"><code>headers-out</code></a>
+      <li><a href="#host"><code>host</code></a>
+      <li><a href="#http-token-p"><code>http-token-p</code></a>
+      <li><a href="#log-file"><code>log-file</code></a>
+      <li><a href="#log-message"><code>log-message</code></a>
+      <li><a href="#log-message*"><code>log-message*</code></a>
+      <li><a href="#maybe-invoke-debugger"><code>maybe-invoke-debugger</code></a>
+      <li><a href="#mime-type"><code>mime-type</code></a>
+      <li><a href="#mod-lisp-id"><code>mod-lisp-id</code></a>
+      <li><a href="#no-cache"><code>no-cache</code></a>
+      <li><a href="#parameter"><code>parameter</code></a>
+      <li><a href="#post-parameter"><code>post-parameter</code></a>
+      <li><a href="#post-parameters"><code>post-parameters</code></a>
+      <li><a href="#query-string"><code>query-string</code></a>
+      <li><a href="#raw-post-data"><code>raw-post-data</code></a>
+      <li><a href="#real-remote-addr"><code>real-remote-addr</code></a>
+      <li><a href="#reason-phrase"><code>reason-phrase</code></a>
+      <li><a href="#recompute-request-parameters"><code>recompute-request-parameters</code></a>
+      <li><a href="#redirect"><code>redirect</code></a>
+      <li><a href="#referer"><code>referer</code></a>
+      <li><a href="#remote-addr"><code>remote-addr</code></a>
+      <li><a href="#remote-port"><code>remote-port</code></a>
+      <li><a href="#remote-session"><code>remote-session</code></a>
+      <li><a href="#reply-external-format"><code>reply-external-format</code></a>
+      <li><a href="#request-method"><code>request-method</code></a>
+      <li><a href="#request-uri"><code>request-uri</code></a>
+      <li><a href="#require-authorization"><code>require-authorization</code></a>
+      <li><a href="#reset-sessions"><code>reset-sessions</code></a>
+      <li><a href="#return-code"><code>return-code</code></a>
+      <li><a href="#rfc-1123-date"><code>rfc-1123-date</code></a>
+      <li><a href="#script-name"><code>script-name</code></a>
+      <li><a href="#send-headers"><code>send-headers</code></a>
+      <li><a href="#server-addr"><code>server-addr</code></a>
+      <li><a href="#server-address"><code>server-address</code></a>
+      <li><a href="#server-dispatch-table"><code>server-dispatch-table</code></a>
+      <li><a href="#server-local-port"><code>server-local-port</code></a>
+      <li><a href="#server-name"><code>server-name</code></a>
+      <li><a href="#server-port"><code>server-port</code></a>
+      <li><a href="#server-protocol"><code>server-protocol</code></a>
+      <li><a href="#session-cookie-value"><code>session-cookie-value</code></a>
+      <li><a href="#session-counter"><code>session-counter</code></a>
+      <li><a href="#session-gc"><code>session-gc</code></a>
+      <li><a href="#session-max-time"><code>session-max-time</code></a>
+      <li><a href="#session-too-old-p"><code>session-too-old-p</code></a>
+      <li><a href="#session-remote-addr"><code>session-remote-addr</code></a>
+      <li><a href="#session-user-agent"><code>session-user-agent</code></a>
+      <li><a href="#session-value"><code>session-value</code></a>
+      <li><a href="#set-cookie"><code>set-cookie</code></a>
+      <li><a href="#set-cookie*"><code>set-cookie*</code></a>
+      <li><a href="#ssl-p"><code>ssl-p</code></a>
+      <li><a href="#ssl-session-id"><code>ssl-session-id</code></a>
+      <li><a href="#start-server"><code>start-server</code></a>
+      <li><a href="#start-session"><code>start-session</code></a>
+      <li><a href="#stop-server"><code>stop-server</code></a>
+      <li><a href="#url-decode"><code>url-decode</code></a>
+      <li><a href="#url-encode"><code>url-encode</code></a>
+      <li><a href="#user-agent"><code>user-agent</code></a>
+    </ul>
+
+<br>&nbsp;<br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+Thanks to Jeff Caldwell - TBNL would not have been released without
+his efforts. Thanks to <a href="http://www.fractalconcept.com/">Marc
+Battyani</a> for mod_lisp and
+to <a href="http://www.swiss.ai.mit.edu/~cph/">Chris Hanson</a> for
+mod_lisp2. Thanks
+to <a href="http://www.cliki.net/Stefan%20Scholl">Stefan Scholl</a>
+and Travis Cross for various additions and fixes to TBNL,
+to <a href="http://www.foldr.org/~michaelw/">Michael Weber</a> for
+initial file upload code, and
+to <a href="http://www.ltn.lv/~jonis/">Janis Dzerins</a> for
+his <a href="http://common-lisp.net/project/rfc2388/">RFC&nbsp;2388
+code</a>. Thanks to Bob Hutchison for his code for multiple front-ends
+(which made me realize that TBNL was already pretty close to a "real"
+web server) and the initial UTF-8 example.  Thanks to John
+Foderaro's <a
+href="http://opensource.franz.com/aserve/index.html">AllegroServe</a>
+for inspiration.  Thanks
+to <a href="http://www.htg1.de/">Uwe von Loh</a> for the <a href="http://www.htg1.de/hunchentoot/hunchentoot.html">Hunchentoot
+logo</a>.
+<p>
+Hunchentoot originally used code
+from <a href="http://www.cliki.net/ACL-COMPAT">ACL-COMPAT</a>,
+specifically the chunking code from Jochen Schmidt.  (This has been
+replaced by <a href="http://weitz.de/chunga/">Chunga</a>.)  When I
+ported Hunchentoot to other Lisps than LispWorks, I stole code from
+ACL-COMPAT, <a href="http://www.cliki.net/kmrcl">KMRCL</a>,
+and <a href="http://www.cliki.net/trivial-sockets">trivial-sockets</a>
+for implementation-dependent stuff like sockets and MP.
+<p>
+Parts of this documentation were prepared
+with <a
+href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>, no animals were harmed.
+</p>
+<p>
+$Header: /usr/local/cvsrep/hunchentoot/doc/index.html,v 1.126 2007/12/29 17:35:03 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/easy-handlers.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,319 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/easy-handlers.lisp,v 1.12 2007/05/25 11:32:50 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun compute-real-name (symbol)
+  "Computes the `real' paramater name \(a string) from the Lisp
+symbol SYMBOL.  Used in cases where no parameter name is
+provided."
+  ;; we just downcase the symbol's name
+  (string-downcase symbol))
+
+(defun convert-parameter (argument type)
+  "Converts the string ARGUMENT to TYPE where TYPE is one of the
+symbols STRING, CHARACTERS, INTEGER, KEYWORD, or BOOLEAN - or
+otherwise a function designator for a function of one argument.
+ARGUMENT can also be NIL in which case this function also returns
+NIL unconditionally."
+  (when (listp argument)
+    ;; this if for the case that ARGUMENT is NIL or the result of a
+    ;; file upload
+    (return-from convert-parameter argument))
+  (case type
+    (string argument)
+    (character (and (= (length argument) 1)
+                    (char argument 0)))
+    (integer (ignore-errors (parse-integer argument :junk-allowed t)))
+    (keyword (make-keyword argument :destructivep nil))
+    (boolean t)
+    (otherwise (funcall type argument))))
+
+(defun compute-simple-parameter (parameter-name type parameter-reader)
+  "Retrieves the parameter named PARAMETER-NAME using the reader
+PARAMETER-READER and converts it to TYPE."
+  (convert-parameter (funcall parameter-reader parameter-name) type))
+
+(defun compute-list-parameter (parameter-name type parameters)
+  "Retrieves all parameters from PARAMETERS which are named
+PARAMETER-NAME, converts them to TYPE, and returns a list of
+them."
+  (loop for (name . value) in parameters
+        when (string= name parameter-name)
+        collect (convert-parameter value type)))
+
+(defun compute-array-parameter (parameter-name type parameters)
+  "Retrieves all parameters from PARAMETERS which are named like
+\"PARAMETER-NAME[N]\" \(where N is a non-negative integer),
+converts them to TYPE, and returns an array where the Nth element
+is the corresponding value."
+  ;; see <http://common-lisp.net/pipermail/tbnl-devel/2006-September/000660.html>
+  #+:sbcl (declare (sb-ext:muffle-conditions warning))
+  (let* ((index-value-list
+          (loop for (full-name . value) in parameters
+                for index = (register-groups-bind (name index-string)
+                                ("^(.*)\\[(\\d+)\\]$" full-name)
+                              (when (string= name parameter-name)
+                                (parse-integer index-string)))
+                when index
+                collect (cons index (convert-parameter value type))))
+         (array (make-array (1+ (reduce #'max index-value-list
+                                        :key #'car
+                                        :initial-value -1))
+                            :initial-element nil)))
+    (loop for (index . value) in index-value-list
+          do (setf (aref array index) value))
+    array))
+
+(defun compute-hash-table-parameter (parameter-name type parameters key-type test-function)
+  "Retrieves all parameters from PARAMETERS which are named like
+\"PARAMETER-NAME{FOO}\" \(where FOO is any sequence of characters
+not containing curly brackets), converts them to TYPE, and
+returns a hash table with test function TEST-FUNCTION where the
+corresponding value is associated with the key FOO \(converted to
+KEY-TYPE)."
+  (let ((hash-table (make-hash-table :test test-function)))
+    (loop for (full-name . value) in parameters
+          for key = (register-groups-bind (name key-string)
+                        ("^(.*){([^{}]+)}$" full-name)
+                      (when (string= name parameter-name)
+                        (convert-parameter key-string key-type)))
+          when key
+          do (setf (gethash key hash-table)
+                   (convert-parameter value type)))
+    hash-table))
+
+(defun compute-parameter (parameter-name parameter-type request-type)
+  "Computes and returns the parameter\(s) called PARAMETER-NAME
+and converts it/them according to the value of PARAMETER-TYPE.
+REQUEST-TYPE is one of :GET, :POST, or :BOTH."
+  (when (member parameter-type '(list array hash-table))
+    (setq parameter-type (list parameter-type 'string)))
+  (let ((parameter-reader (ecase request-type
+                              (:get #'get-parameter)
+                              (:post #'post-parameter)
+                              (:both #'parameter)))
+        (parameters (and (listp parameter-type)
+                         (case request-type
+                           (:get (get-parameters))
+                           (:post (post-parameters))
+                           (:both (append (get-parameters) (post-parameters)))))))
+    (cond ((atom parameter-type)
+           (compute-simple-parameter parameter-name parameter-type parameter-reader))
+          ((and (null (cddr parameter-type))
+                (eq (first parameter-type) 'list))
+           (compute-list-parameter parameter-name (second parameter-type) parameters))
+          ((and (null (cddr parameter-type))
+                (eq (first parameter-type) 'array))
+           (compute-array-parameter parameter-name (second parameter-type) parameters))
+          ((and (null (cddddr parameter-type))
+                (eq (first parameter-type) 'hash-table))
+           (compute-hash-table-parameter parameter-name (second parameter-type) parameters
+                                         (or (third parameter-type) 'string)
+                                         (or (fourth parameter-type) 'equal)))
+          (t (error "Don't know what to do with parameter type ~S." parameter-type)))))
+
+(defun make-defun-parameter (description default-parameter-type default-request-type)
+  "Creates a keyword parameter to be used by DEFINE-EASY-HANDLER.
+DESCRIPTION is one of the elements of DEFINE-EASY-HANDLER's
+LAMBDA-LIST and DEFAULT-PARAMETER-TYPE and DEFAULT-REQUEST-TYPE
+are the global default values."
+  (when (atom description)
+    (setq description (list description)))
+  (destructuring-bind (parameter-name &key (real-name (compute-real-name parameter-name))
+                                           parameter-type init-form request-type)
+      description
+    `(,parameter-name (or (and (boundp '*request*)
+                               (compute-parameter ,real-name
+                                                  ,(or parameter-type default-parameter-type)
+                                                  ,(or request-type default-request-type)))
+                          ,init-form))))
+
+(defmacro define-easy-handler (description lambda-list &body body)
+  "Defines a handler with the body BODY and optionally registers
+it with a URI so that it will be found by DISPATCH-EASY-HANDLERS.
+DESCRIPTION is either a symbol NAME or a list matching the
+destructuring lambda list
+
+  (name &key uri server-names default-parameter-type default-request-type).
+
+LAMBDA-LIST is a list the elements of which are either a symbol
+VAR or a list matching the destructuring lambda list
+
+  (var &key real-name parameter-type init-form request-type).
+
+The resulting handler will be a Lisp function with the name NAME
+and keyword parameters named by the VAR symbols.  Each VAR will
+be bound to the value of the GET or POST parameter called
+REAL-NAME \(a string) before BODY is executed.  If REAL-NAME is
+not provided, it will be computed by downcasing the symbol name
+of VAR.
+
+If URI \(which is evaluated) is provided, then it must be a string or
+a function designator for a function of one argument.  In this case,
+the handler will be returned by DISPATCH-EASY-HANDLERS, if URI is a
+string and the script name of a request is URI, or if URI designates a
+function and applying this function to the current request object
+returns a true value.
+
+SERVER-NAMES \(which is evaluated) can be a list of symbols which
+means that the handler will be returned by DISPATCH-EASY-HANDLERS in
+servers which have one of these names \(see SERVER-NAME).
+SERVER-NAMES can also be the symbol T which means that the handler
+will be returned by DISPATCH-EASY-HANDLERS in every server.
+
+Whether the GET or POST parameter \(or both) will be taken into
+consideration, depends on REQUEST-TYPE which can
+be :GET, :POST, :BOTH, or NIL.  In the last case, the value of
+DEFAULT-REQUEST-TYPE \(the default of which is :BOTH) will be
+used.
+
+The value of VAR will usually be a string \(unless it resulted from a
+file upload in which case it won't be converted at all), but if
+PARAMETER-TYPE \(which is evaluated) is provided, the string will be
+converted to another Lisp type by the following rules:
+
+If the corresponding GET or POST parameter wasn't provided by the
+client, VAR's value will be NIL.  If PARAMETER-TYPE is 'STRING, VAR's
+value remains as is.  If PARAMETER-TYPE is 'INTEGER and the parameter
+string consists solely of decimal digits, VAR's value will be the
+corresponding integer, otherwise NIL.  If PARAMETER-TYPE is 'KEYWORD,
+VAR's value will be the keyword obtained by interning the upcased
+parameter string into the keyword package.  If PARAMETER-TYPE is
+'CHARACTER and the parameter string is of length one, VAR's value will
+be the single character of this string, otherwise NIL.  If
+PARAMETER-TYPE is 'BOOLEAN, VAR's value will always be T \(unless it
+is NIL by the first rule above, of course).  If PARAMETER-TYPE is any
+other atom, it is supposed to be a function designator for a unary
+function which will be called to convert the string to something else.
+
+Those were the rules for `simple' types, but PARAMETER-TYPE can
+also be a list starting with one of the symbols LIST, ARRAY, or
+HASH-TABLE.  The second value of the list must always be a simple
+parameter type as in the last paragraph - we'll call it the
+`inner type' below.
+
+In the case of 'LIST, all GET/POST parameters called REAL-NAME
+will be collected, converted to the inner type, and assembled
+into a list which will be the value of VAR.
+
+In the case of 'ARRAY, all GET/POST parameters which have a name
+like the result of
+
+  (format nil \"~A[~A]\" real-name n)
+
+where N is a non-negative integer, will be assembled into an
+array where the Nth element will be set accordingly, after
+conversion to the inner type.  The array, which will become the
+value of VAR, will be big enough to hold all matching parameters,
+but not bigger.  Array elements not set as described above will
+be NIL.  Note that VAR will always be bound to an array, which
+may be empty, so it will never be NIL, even if no appropriate
+GET/POST parameters are found.
+
+The full form of a 'HASH-TABLE parameter type is
+
+  (hash-table inner-type key-type test-function),
+
+but KEY-TYPE and TEST-FUNCTION can be left out in which case they
+default to 'STRING and 'EQUAL, respectively.  For this parameter
+type, all GET/POST parameters which have a name like the result
+of
+
+  (format nil \"~A{~A}\" real-name key)
+
+\(where KEY is a string that doesn't contain curly brackets) will
+become the values \(after conversion to INNER-TYPE) of a hash
+table with test function TEST-FUNCTION where KEY \(after
+conversion to KEY-TYPE) will be the corresponding key.  Note that
+VAR will always be bound to a hash table, which may be empty, so
+it will never be NIL, even if no appropriate GET/POST parameters
+are found.
+
+To make matters even more complicated, the three compound
+parameter types also have an abbreviated form - just one of the
+symbols LIST, ARRAY, or HASH-TABLE.  In this case, the inner type
+will default to 'STRING.
+
+If PARAMETER-TYPE is not provided or NIL, DEFAULT-PARAMETER-TYPE
+\(the default of which is 'STRING) will be used instead.
+
+If the result of the computations above would be that VAR would
+be bound to NIL, then INIT-FORM \(if provided) will be evaluated
+instead, and VAR will be bound to the result of this evaluation.
+
+Handlers built with this macro are constructed in such a way that
+the resulting Lisp function is useful even outside of
+Hunchentoot.  Specifically, all the parameter computations above
+will only happen if *REQUEST* is bound, i.e. if we're within a
+Hunchentoot request.  Otherwise, VAR will always be bound to the
+result of evaluating INIT-FORM unless a corresponding keyword
+argument is provided."
+  (when (atom description)
+    (setq description (list description)))
+  (destructuring-bind (name &key uri (server-names t)
+                            (default-parameter-type ''string)
+                            (default-request-type :both))
+      description
+    `(progn
+       ,@(when uri
+           (list
+            (with-rebinding (uri)
+              `(progn
+                 (setq *easy-handler-alist*
+                       (delete-if (lambda (list)
+                                    (or (equal ,uri (first list))
+                                        (eq ',name (third list))))
+                                  *easy-handler-alist*))
+                 (push (list ,uri ,server-names ',name) *easy-handler-alist*)))))
+       (defun ,name (&key ,@(loop for part in lambda-list
+                                  collect (make-defun-parameter part
+                                                                default-parameter-type
+                                                                default-request-type)))
+         , at body))))
+
+;; help the LispWorks IDE to find these definitions
+#+:lispworks
+(dspec:define-form-parser define-easy-handler (description)
+  `(,define-easy-handler ,(if (atom description) description (first description))))
+
+#+:lispworks
+(dspec:define-dspec-alias define-easy-handler (name)
+  `(defun ,name))
+
+(defun dispatch-easy-handlers (request)
+  "This is a dispatcher which returns the appropriate handler
+defined with DEFINE-EASY-HANDLER, if there is one."
+  (loop for (uri server-names easy-handler) in *easy-handler-alist*
+        when (and (or (eq server-names t)
+                      (find (server-name *server*) server-names :test #'eq))
+                  (cond ((stringp uri)
+                         (string= (script-name request) uri))
+                        (t (funcall uri request))))
+        do (return easy-handler)))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/headers.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,323 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/headers.lisp,v 1.25 2007/12/29 17:35:00 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun maybe-write-to-header-stream (key &optional value)
+  (when *header-stream*
+    (format *header-stream* "~A~@[: ~A~]~%" key
+            (and value (regex-replace-all "[\\r\\n]" value " ")))
+    (force-output *header-stream*)))
+
+(defun compute-length (content)
+  "Computes and returns the length of CONTENT in octets.  Returns as a
+second value CONTENT as a vector of octets.  The result depends on the
+external format of *REPLY*."
+  (when (null content)
+    (return-from compute-length))
+  (when (stringp content)
+    (setq content
+          (string-to-octets content :external-format (reply-external-format))))
+  (values (length content) content))
+
+(defmethod write-header-line ((mod-lisp-p (eql nil)) key value)
+  "Accepts strings KEY and VALUE and writes them directly to the
+client as an HTTP header line."
+  (write-string key *hunchentoot-stream*)
+  (write-string ": " *hunchentoot-stream*)
+  ;; remove line breaks
+  (write-string (regex-replace-all "[\\r\\n]" value " ") *hunchentoot-stream*)
+  (write-string +crlf+ *hunchentoot-stream*))
+
+(defmethod write-header-line (mod-lisp-p key value)
+  "Accepts strings KEY and VALUE and writes them, one line at a time,
+to the mod_lisp socket stream."
+  (write-line key *hunchentoot-stream*)
+  ;; remove line breaks
+  (write-line (regex-replace-all "[\\r\\n]" value " ") *hunchentoot-stream*))
+
+(defmethod write-header-line :after (mod-lisp-p key value)
+  (declare (ignorable mod-lisp-p))
+  (maybe-write-to-header-stream key value))
+
+(defun start-output (&optional (content nil content-provided-p))
+  "Sends all headers and maybe the content body to
+*HUNCHENTOOT-STREAM*.  Returns immediately and does nothing if called
+more than once per request.  Handles the supported return codes
+accordingly.  Called by PROCESS-REQUEST and/or SEND-HEADERS.  Returns
+the stream to write to."
+  ;; send headers only once
+  (when *headers-sent*
+    (return-from start-output))
+  (setq *headers-sent* t)
+  ;; read post data to clear stream
+  (raw-post-data)
+  (let* ((mod-lisp-p (server-mod-lisp-p *server*))
+         (return-code (return-code))
+         (chunkedp (and (server-output-chunking-p *server*)
+                        (eq (server-protocol) :http/1.1)
+                        ;; only turn chunking on if the content
+                        ;; length is unknown at this point...
+                        (null (or (content-length) content-provided-p))
+                        ;; ...AND if the return code isn't one where
+                        ;; Hunchentoot (or a user error handler) sends its
+                        ;; own content
+                        (member return-code *approved-return-codes*)))
+         (reason-phrase (reason-phrase return-code))
+         (request-method (request-method))
+         (head-request-p (eq request-method :head))
+         content-modified-p)
+    (unless mod-lisp-p
+      (multiple-value-bind (keep-alive-p keep-alive-requested-p)
+          (keep-alive-p)
+        (when keep-alive-p
+          (setq keep-alive-p
+                ;; use keep-alive if there's a way for the client to
+                ;; determine when all content is sent (or if there
+                ;; is no content)
+                (or chunkedp
+                    head-request-p
+                    (eq (return-code) +http-not-modified+)
+                    (content-length)
+                    content)))
+        ;; now set headers for keep-alive and chunking
+        (when chunkedp
+          (setf (header-out "Transfer-Encoding") "chunked"))
+        (cond (keep-alive-p
+               (setf *close-hunchentoot-stream* nil)
+               (when (or (not (eq (server-protocol) :http/1.1))
+                         keep-alive-requested-p)
+                 ;; persistent connections are implicitly assumed for
+                 ;; HTTP/1.1, but we return a 'Keep-Alive' header if the
+                 ;; client has explicitly asked for one
+                 (setf (header-out "Connection") "Keep-Alive"
+                       (header-out "Keep-Alive")
+                       (format nil "timeout=~D" (server-read-timeout *server*)))))
+              (t (setf (header-out "Connection") "Close"))))
+      (unless (and (header-out-set-p "Server")
+                   (null (header-out "Server")))
+        (setf (header-out "Server") (or (header-out "Server")
+                                        (server-name-header))))
+      (setf (header-out "Date") (rfc-1123-date)))
+    (unless reason-phrase
+      (setq content (escape-for-html
+                     (format nil "Unknown http return code: ~A" return-code))
+            content-modified-p t
+            return-code +http-internal-server-error+
+            reason-phrase (reason-phrase return-code)))
+    (unless (or (not *handle-http-errors-p*)
+                (member return-code *approved-return-codes*))
+      ;; call error handler, if any - should return NIL if it can't
+      ;; handle the error
+      (let (error-handled-p)
+        (when *http-error-handler*
+          (setq error-handled-p (funcall *http-error-handler* return-code)
+                content (or error-handled-p content)
+                content-modified-p (or content-modified-p error-handled-p)))
+        ;; handle common return codes other than 200, which weren't
+        ;; handled by the error handler
+        (unless error-handled-p
+          (setf (content-type)
+                "text/html; charset=iso-8859-1"
+                content-modified-p t
+                content
+                (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~A<p><hr>~A</p></body></html>"
+                        return-code reason-phrase
+                        (case return-code
+                          ((#.+http-internal-server-error+) content)
+                          ((#.+http-moved-temporarily+ #.+http-moved-permanently+)
+                           (format nil "The document has moved <a href='~A'>here</a>"
+                                   (header-out "Location")))
+                          ((#.+http-authorization-required+)
+                           "The server could not verify that you are authorized to access the document requested.  Either you supplied the wrong credentials \(e.g., bad password), or your browser doesn't understand how to supply the credentials required.")
+                          ((#.+http-forbidden+)
+                           (format nil "You don't have permission to access ~A on this server."
+                                   (script-name)))
+                          ((#.+http-not-found+)
+                           (format nil "The requested URL ~A was not found on this server."
+                                   (script-name)))
+                          ((#.+http-bad-request+)
+                           "Your browser sent a request that this server could not understand.")
+                          (otherwise ""))
+                        (address-string))))))
+    ;; start with status line      
+    (cond (mod-lisp-p
+           (write-header-line t "Status" (format nil "~D ~A" return-code reason-phrase)))
+          (t
+           (let ((first-line
+                  (format nil "HTTP/1.1 ~D ~A" return-code reason-phrase)))
+             (write-string first-line *hunchentoot-stream*)
+             (write-string +crlf+ *hunchentoot-stream*)
+             (maybe-write-to-header-stream first-line))))
+    (when (and (stringp content)
+               (not content-modified-p)
+               (starts-with-one-of-p (or (content-type) "")
+                                     *content-types-for-url-rewrite*))
+      ;; if the Content-Type header starts with one of the strings
+      ;; in *CONTENT-TYPES-FOR-URL-REWRITE* then maybe rewrite the
+      ;; content
+      (setq content (maybe-rewrite-urls-for-session content)))
+    (let ((content-length (content-length)))
+      (unless content-length
+        (multiple-value-setq (content-length content) (compute-length content)))
+      ;; write the corresponding headers for the content
+      (when content-length
+        (write-header-line mod-lisp-p "Content-Length" (format nil "~D" content-length))
+        (when mod-lisp-p
+          (write-header-line t "Lisp-Content-Length"
+                             (cond (head-request-p "0")
+                                   (t (format nil "~D" content-length))))
+          (write-header-line t "Keep-Socket" "1")
+          (setq *close-hunchentoot-stream* nil)))
+      (when-let (content-type (content-type))
+        (write-header-line mod-lisp-p "Content-Type" content-type))
+      ;; write all headers from the REPLY object
+      (loop for (key . value) in (headers-out)
+            when value
+            do (write-header-line mod-lisp-p (string-capitalize key) value))
+      ;; now the cookies
+      (loop for (nil . cookie) in (cookies-out)
+            do (write-header-line mod-lisp-p "Set-Cookie" (stringify-cookie cookie)))
+      (when mod-lisp-p
+        ;; send log messages to mod_lisp
+        (loop for (log-level . message) in (reverse (log-messages *reply*))
+              do (write-header-line t (case log-level
+                                        ((:emerg) "Log-Emerg")
+                                        ((:alert) "Log-Alert")
+                                        ((:crit) "Log-Crit")
+                                        ((:error) "Log-Error")
+                                        ((:warning) "Log-Warning")
+                                        ((:notice) "Log-Notice")
+                                        ((:info) "Log-Info")
+                                        ((:debug) "Log-Debug")
+                                        (otherwise "Log"))
+                                    message)))
+      ;; all headers sent
+      (cond (mod-lisp-p
+             (write-line "end" *hunchentoot-stream*)
+             (maybe-write-to-header-stream "end"))
+            (t
+             (write-string +crlf+ *hunchentoot-stream*)
+             (maybe-write-to-header-stream "")))
+      ;; access log message
+      (when (and *show-access-log-messages*
+                 (not (server-use-apache-log-p *server*)))
+        (ignore-errors
+          (log-message nil "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] \"~A ~A~@[?~A~] ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\""
+                       (remote-addr) (header-in :x-forwarded-for)
+                       (authorization) request-method (script-name)
+                       (query-string) (server-protocol)
+                       return-code content content-length
+                       (referer) (user-agent)))))
+    (setf (flexi-stream-external-format *hunchentoot-stream*) (reply-external-format))
+    ;; now optional content
+    (unless (or (null content) head-request-p)
+      (ignore-errors
+        #+:clisp
+        (unless (stringp content)
+          (setf (flexi-stream-element-type *hunchentoot-stream*) 'octet))
+        (write-sequence content *hunchentoot-stream*)))
+    (when chunkedp
+      ;; turn chunking on after the headers have been sent
+      (setf (chunked-stream-output-chunking-p
+             (flexi-stream-stream *hunchentoot-stream*)) t))
+    *hunchentoot-stream*))
+
+(defun send-headers ()
+  "Sends the initial status line and all headers as determined by
+the REPLY object *REPLY*.  Returns a stream to which the body of
+the reply can be written.  Once this function has been called,
+further changes to *REPLY* don't have any effect.  Also,
+automatic handling of errors \(i.e. sending the corresponding
+status code to the browser, etc.) is turned off for this request.
+If your handlers return the full body as a string or as an array
+of octets you should NOT call this function."
+  (start-output))
+
+(defun get-request-data ()
+  "Reads incoming headers from mod_lisp or directly from the client
+via *HUNCHENTOOT-STREAM*.  Returns as multiple values the headers as
+an alist, the stream to read the request body from, the method, the
+URI, and the protocol of the request.  The last three values are only
+returned if we're not behind mod_lisp."
+  (ignore-errors
+    (let* ((mod-lisp-p (server-mod-lisp-p *server*))
+           (first-line (if mod-lisp-p
+                         (read-line *hunchentoot-stream* nil nil)
+                         (cl:handler-case
+                             (read-line* *hunchentoot-stream*)
+                           ((or end-of-file
+                                #+:sbcl sb-sys:io-timeout
+                                #+:cmu sys:io-timeout
+                                #+:allegro excl:socket-error) ()
+                             nil)))))
+      (cond ((null first-line)
+             ;; socket closed - return immediately
+             nil)
+            (mod-lisp-p
+             ;; we're behind mod_lisp, so we read alternating
+             ;; key/value lines
+             (let ((second-line (read-line *hunchentoot-stream* t)))
+               (maybe-write-to-header-stream first-line second-line)
+               (let* ((headers
+                       (loop for key = (read-line *hunchentoot-stream* nil nil)
+                             while (and key (string-not-equal key "end"))
+                             for value = (read-line *hunchentoot-stream* t)
+                             collect (cons (make-keyword key) value)
+                             do (maybe-write-to-header-stream key value)))
+                      (content-length (cdr (assoc :content-length headers))))
+                 ;; add contents of first two lines
+                 (push (cons (make-keyword first-line) second-line) headers)
+                 (values (delete-duplicates headers :test #'eq :key #'car)
+                         (and (or content-length
+                                  (server-input-chunking-p *server*))
+                              *hunchentoot-stream*)))))
+            (t
+             ;; we're a stand-alone web server, so we use Chunga to
+             ;; read the headers
+             (destructuring-bind (method url-string &optional protocol)
+                 (split "\\s+" first-line :limit 3)
+               (maybe-write-to-header-stream first-line)
+               (let ((headers (and protocol (read-http-headers *hunchentoot-stream*
+                                                               *header-stream*))))
+                 (unless protocol (setq protocol "HTTP/0.9"))
+                 (when (equalp (cdr (assoc :expect headers)) "100-continue")
+                   ;; handle 'Expect: 100-continue' header
+                   (let ((continue-line
+                          (format nil "HTTP/1.1 ~D ~A"
+                                  +http-continue+
+                                  (reason-phrase +http-continue+))))
+                     (write-string continue-line *hunchentoot-stream*)
+                     (write-string +crlf+ *hunchentoot-stream*)
+                     (write-string +crlf+ *hunchentoot-stream*)
+                     (force-output *hunchentoot-stream*)
+                     (maybe-write-to-header-stream continue-line)
+                     (maybe-write-to-header-stream "")))
+                 (values headers *hunchentoot-stream* (make-keyword method) url-string
+                         (make-keyword (string-trim '(#\Space #\Tab #\NewLine #\Return) protocol))))))))))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot-test.asd	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,35 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/hunchentoot-test.asd,v 1.2 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(asdf:defsystem :hunchentoot-test
+  :components ((:module "test"
+                        :serial t
+                        :components ((:file "packages")
+                                     (:file "test"))))
+  :depends-on (:hunchentoot :cl-who))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,81 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/hunchentoot.asd,v 1.53 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :hunchentoot-asd
+  (:use :cl :asdf))
+
+(in-package :hunchentoot-asd)
+
+(defvar *hunchentoot-version* "0.15.0"
+  "A string denoting the current version of Hunchentoot.  Used
+for diagnostic output.")
+
+(export '*hunchentoot-version*)
+
+(asdf:defsystem :hunchentoot
+  :serial t
+  :version #.*hunchentoot-version*
+  :depends-on (:chunga
+               :cl-base64
+               :cl-ppcre
+               #-(or :lispworks :hunchentoot-no-ssl) :cl+ssl
+               :md5
+               :rfc2388
+               #+:sbcl :sb-bsd-sockets
+               #+:sbcl :sb-posix
+               #+:openmcl :acl-compat
+               :url-rewrite)
+  :components ((:file "packages")
+               (:file "conditions")
+               #+:allegro (:file "port-acl")
+               #+:clisp (:file "port-clisp")
+               #+:cmu (:file "port-cmu")
+               #+:lispworks (:file "port-lw")
+               #+:openmcl (:file "port-mcl")
+               #+:sbcl (:file "port-sbcl")
+               (:file "specials")
+               (:file "mime-types")
+               (:file "util")
+               (:file "log")
+               (:file "cookie")
+               (:file "reply")
+               (:file "request")
+               (:file "session")
+               (:file "misc")
+               (:file "easy-handlers")
+               (:file "headers")
+               #+(and :allegro :unix) (:file "unix-acl")
+               #+(and :clisp :unix) (:file "unix-clisp")               
+               #+(and :cmu :unix) (:file "unix-cmu")
+               #+(and :lispworks :unix) (:file "unix-lw")
+               #+(and :openmcl :unix) (:file "unix-mcl")
+               #+(and :sbcl :unix (not :win32)) (:file "unix-sbcl")
+               (:file "server")))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/log.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,93 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/log.lisp,v 1.9 2007/10/19 23:51:32 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defgeneric log-message (log-level fmt &rest args))
+
+(defmethod log-message (log-level fmt &rest args)
+  "Sends a formatted message to Apache's error log when the data gets
+sent to Apache/mod_lisp and SERVER-USE-APACHE-LOG-P is true, otherwise
+logs to the file denoted by LOG-FILE.  FMT and ARGS are as in FORMAT.
+LOG-LEVEL is a keyword denoting the corresponding Apache error level."
+  (let ((message (apply #'format nil fmt args)))
+    (cond ((and (boundp '*server*)
+                (server-mod-lisp-p *server*)
+                (server-use-apache-log-p *server*))
+           (with-input-from-string (s message)
+             (loop with prolog = (case *log-prefix*
+                                   ((nil) "")
+                                   ((t) "[Hunchentoot] ")
+                                   (otherwise (format nil "[~A] " *log-prefix*)))
+                   for line = (read-line s nil nil)
+                   while line
+                   do (push (cons log-level
+                                  (format nil "~A~A" prolog line))
+                            (slot-value *reply* 'log-messages)))))
+          (t (with-lock (*log-file-lock*)
+               (ignore-errors
+                 (unless *log-file-stream*
+                   (let ((log-file-stream
+                          (open (ensure-directories-exist *log-file*)
+                                :direction :output
+                                :element-type 'octet
+                                :if-does-not-exist :create
+                                :if-exists :append
+                                #+:openmcl #+:openmcl
+                                :sharing :lock)))
+                     (setq *log-file-stream*
+                           (make-flexi-stream log-file-stream
+                                              :external-format +utf-8+))))
+                 (handler-case
+                     (format *log-file-stream*
+                             "[~A~@[ [~A]~]] ~A~%" (iso-time) log-level message)
+                   (error ()
+                     (format *log-file-stream* "[~A [EMERG]] A message could not be logged!"
+                             (iso-time))))
+                 (force-output *log-file-stream*))))))
+  (values))
+
+(defun log-message* (fmt &rest args)
+  "Same as LOG-MESSAGE* but with the default log level \(as
+defined by *DEFAULT-LOG-LEVEL*)."
+  (apply #'log-message *default-log-level* fmt args))
+
+(defun log-file ()
+  "Returns the log file which is currently used."
+  *log-file*)
+
+(defun (setf log-file) (pathspec)
+  "Sets the log file which is to be used."
+  (with-lock (*log-file-lock*)
+    (when *log-file-stream*
+      (ignore-errors
+        (close *log-file-stream*))
+      (setq *log-file-stream* nil))
+    (setq *log-file* pathspec)))
+  
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/mime-types.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,362 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/mime-types.lisp,v 1.3 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defparameter *mime-type-list* '(("application/andrew-inset" "ez")
+                                 ("application/cu-seeme" "cu")
+                                 ("application/dsptype" "tsp")
+                                 ("application/futuresplash" "spl")
+                                 ("application/hta" "hta")
+                                 ("application/java-archive" "jar")
+                                 ("application/java-serialized-object" "ser")
+                                 ("application/java-vm" "class")
+                                 ("application/mac-binhex40" "hqx")
+                                 ("application/mac-compactpro" "cpt")
+                                 ("application/mathematica" "nb")
+                                 ("application/msaccess" "mdb")
+                                 ("application/msword" "doc" "dot")
+                                 ("application/octet-stream" "bin")
+                                 ("application/oda" "oda")
+                                 ("application/ogg" "ogg")
+                                 ("application/pdf" "pdf")
+                                 ("application/pgp-keys" "key")
+                                 ("application/pgp-signature" "pgp")
+                                 ("application/pics-rules" "prf")
+                                 ("application/postscript" "ps" "ai" "eps")
+                                 ("application/rar" "rar")
+                                 ("application/rdf+xml" "rdf")
+                                 ("application/rss+xml" "rss")
+                                 ("application/smil" "smi" "smil")
+                                 ("application/wordperfect" "wpd")
+                                 ("application/wordperfect5.1" "wp5")
+                                 ("application/xhtml+xml" "xhtml" "xht")
+                                 ("application/xml" "fo" "xml" "xsl")
+                                 ("application/zip" "zip")
+                                 ("application/vnd.cinderella" "cdy")
+                                 ("application/vnd.mozilla.xul+xml" "xul")
+                                 ("application/vnd.ms-excel" "xls" "xlb" "xlt")
+                                 ("application/vnd.ms-pki.seccat" "cat")
+                                 ("application/vnd.ms-pki.stl" "stl")
+                                 ("application/vnd.ms-powerpoint" "ppt" "pps")
+                                 ("application/vnd.oasis.opendocument.chart" "odc")
+                                 ("application/vnd.oasis.opendocument.database" "odb")
+                                 ("application/vnd.oasis.opendocument.formula" "odf")
+                                 ("application/vnd.oasis.opendocument.graphics" "odg")
+                                 ("application/vnd.oasis.opendocument.graphics-template" "otg")
+                                 ("application/vnd.oasis.opendocument.image" "odi")
+                                 ("application/vnd.oasis.opendocument.presentation" "odp")
+                                 ("application/vnd.oasis.opendocument.presentation-template" "otp")
+                                 ("application/vnd.oasis.opendocument.spreadsheet" "ods")
+                                 ("application/vnd.oasis.opendocument.spreadsheet-template" "ots")
+                                 ("application/vnd.oasis.opendocument.text" "odt")
+                                 ("application/vnd.oasis.opendocument.text-master" "odm")
+                                 ("application/vnd.oasis.opendocument.text-template" "ott")
+                                 ("application/vnd.oasis.opendocument.text-web" "oth")
+                                 ("application/vnd.rim.cod" "cod")
+                                 ("application/vnd.smaf" "mmf")
+                                 ("application/vnd.stardivision.calc" "sdc")
+                                 ("application/vnd.stardivision.draw" "sda")
+                                 ("application/vnd.stardivision.impress" "sdd" "sdp")
+                                 ("application/vnd.stardivision.math" "smf")
+                                 ("application/vnd.stardivision.writer" "sdw" "vor")
+                                 ("application/vnd.stardivision.writer-global" "sgl")
+                                 ("application/vnd.sun.xml.calc" "sxc")
+                                 ("application/vnd.sun.xml.calc.template" "stc")
+                                 ("application/vnd.sun.xml.draw" "sxd")
+                                 ("application/vnd.sun.xml.draw.template" "std")
+                                 ("application/vnd.sun.xml.impress" "sxi")
+                                 ("application/vnd.sun.xml.impress.template" "sti")
+                                 ("application/vnd.sun.xml.math" "sxm")
+                                 ("application/vnd.sun.xml.writer" "sxw")
+                                 ("application/vnd.sun.xml.writer.global" "sxg")
+                                 ("application/vnd.sun.xml.writer.template" "stw")
+                                 ("application/vnd.symbian.install" "sis")
+                                 ("application/vnd.visio" "vsd")
+                                 ("application/vnd.wap.wbxml" "wbxml")
+                                 ("application/vnd.wap.wmlc" "wmlc")
+                                 ("application/vnd.wap.wmlscriptc" "wmlsc")
+                                 ("application/x-123" "wk")
+                                 ("application/x-abiword" "abw")
+                                 ("application/x-apple-diskimage" "dmg")
+                                 ("application/x-bcpio" "bcpio")
+                                 ("application/x-bittorrent" "torrent")
+                                 ("application/x-cdf" "cdf")
+                                 ("application/x-cdlink" "vcd")
+                                 ("application/x-chess-pgn" "pgn")
+                                 ("application/x-cpio" "cpio")
+                                 ("application/x-csh" "csh")
+                                 ("application/x-debian-package" "deb" "udeb")
+                                 ("application/x-director" "dcr" "dir" "dxr")
+                                 ("application/x-dms" "dms")
+                                 ("application/x-doom" "wad")
+                                 ("application/x-dvi" "dvi")
+                                 ("application/x-flac" "flac")
+                                 ("application/x-font" "pfa" "pfb" "gsf" "pcf")
+                                 ("application/x-freemind" "mm")
+                                 ("application/x-futuresplash" "spl")
+                                 ("application/x-gnumeric" "gnumeric")
+                                 ("application/x-go-sgf" "sgf")
+                                 ("application/x-graphing-calculator" "gcf")
+                                 ("application/x-gtar" "gtar" "tgz" "taz")
+                                 ("application/x-hdf" "hdf")
+                                 ("application/x-httpd-php" "phtml" "pht" "php")
+                                 ("application/x-httpd-php-source" "phps")
+                                 ("application/x-httpd-php3" "php3")
+                                 ("application/x-httpd-php3-preprocessed" "php3p")
+                                 ("application/x-httpd-php4" "php4")
+                                 ("application/x-ica" "ica")
+                                 ("application/x-internet-signup" "ins" "isp")
+                                 ("application/x-iphone" "iii")
+                                 ("application/x-iso9660-image" "iso")
+                                 ("application/x-java-jnlp-file" "jnlp")
+                                 ("application/x-javascript" "js")
+                                 ("application/x-jmol" "jmz")
+                                 ("application/x-kchart" "chrt")
+                                 ("application/x-killustrator" "kil")
+                                 ("application/x-koan" "skp" "skd" "skt" "skm")
+                                 ("application/x-kpresenter" "kpr" "kpt")
+                                 ("application/x-kspread" "ksp")
+                                 ("application/x-kword" "kwd" "kwt")
+                                 ("application/x-latex" "latex")
+                                 ("application/x-lha" "lha")
+                                 ("application/x-lzh" "lzh")
+                                 ("application/x-lzx" "lzx")
+                                 ("application/x-maker" "frm" "maker" "frame" "fm" "fb" "book" "fbdoc")
+                                 ("application/x-mif" "mif")
+                                 ("application/x-ms-wmd" "wmd")
+                                 ("application/x-ms-wmz" "wmz")
+                                 ("application/x-msdos-program" "com" "exe" "bat" "dll")
+                                 ("application/x-msi" "msi")
+                                 ("application/x-netcdf" "nc")
+                                 ("application/x-ns-proxy-autoconfig" "pac")
+                                 ("application/x-nwc" "nwc")
+                                 ("application/x-object" "o")
+                                 ("application/x-oz-application" "oza")
+                                 ("application/x-pkcs7-certreqresp" "p7r")
+                                 ("application/x-pkcs7-crl" "crl")
+                                 ("application/x-python-code" "pyc" "pyo")
+                                 ("application/x-quicktimeplayer" "qtl")
+                                 ("application/x-redhat-package-manager" "rpm")
+                                 ("application/x-sh" "sh")
+                                 ("application/x-shar" "shar")
+                                 ("application/x-shockwave-flash" "swf" "swfl")
+                                 ("application/x-stuffit" "sit")
+                                 ("application/x-sv4cpio" "sv4cpio")
+                                 ("application/x-sv4crc" "sv4crc")
+                                 ("application/x-tar" "tar")
+                                 ("application/x-tcl" "tcl")
+                                 ("application/x-tex-gf" "gf")
+                                 ("application/x-tex-pk" "pk")
+                                 ("application/x-texinfo" "texinfo" "texi")
+                                 ("application/x-trash" "~%" "" "bak" "old" "sik")
+                                 ("application/x-troff" "tt" "r" "roff")
+                                 ("application/x-troff-man" "man")
+                                 ("application/x-troff-me" "me")
+                                 ("application/x-troff-ms" "ms")
+                                 ("application/x-ustar" "ustar")
+                                 ("application/x-wais-source" "src")
+                                 ("application/x-wingz" "wz")
+                                 ("application/x-x509-ca-cert" "crt")
+                                 ("application/x-xcf" "xcf")
+                                 ("application/x-xfig" "fig")
+                                 ("application/x-xpinstall" "xpi")
+                                 ("audio/basic" "au" "snd")
+                                 ("audio/midi" "mid" "midi" "kar")
+                                 ("audio/mpeg" "mpga" "mpega" "mp2" "mp3" "m4a")
+                                 ("audio/mpegurl" "m3u")
+                                 ("audio/prs.sid" "sid")
+                                 ("audio/x-aiff" "aif" "aiff" "aifc")
+                                 ("audio/x-gsm" "gsm")
+                                 ("audio/x-mpegurl" "m3u")
+                                 ("audio/x-ms-wma" "wma")
+                                 ("audio/x-ms-wax" "wax")
+                                 ("audio/x-pn-realaudio" "ra" "rm" "ram")
+                                 ("audio/x-realaudio" "ra")
+                                 ("audio/x-scpls" "pls")
+                                 ("audio/x-sd2" "sd2")
+                                 ("audio/x-wav" "wav")
+                                 ("chemical/x-alchemy" "alc")
+                                 ("chemical/x-cache" "cac" "cache")
+                                 ("chemical/x-cache-csf" "csf")
+                                 ("chemical/x-cactvs-binary" "cbin" "cascii" "ctab")
+                                 ("chemical/x-cdx" "cdx")
+                                 ("chemical/x-cerius" "cer")
+                                 ("chemical/x-chem3d" "c3d")
+                                 ("chemical/x-chemdraw" "chm")
+                                 ("chemical/x-cif" "cif")
+                                 ("chemical/x-cmdf" "cmdf")
+                                 ("chemical/x-cml" "cml")
+                                 ("chemical/x-compass" "cpa")
+                                 ("chemical/x-crossfire" "bsd")
+                                 ("chemical/x-csml" "csml" "csm")
+                                 ("chemical/x-ctx" "ctx")
+                                 ("chemical/x-cxf" "cxf" "cef")
+                                 ("chemical/x-embl-dl-nucleotide" "emb" "embl")
+                                 ("chemical/x-galactic-spc" "spc")
+                                 ("chemical/x-gamess-input" "inp" "gam" "gamin")
+                                 ("chemical/x-gaussian-checkpoint" "fch" "fchk")
+                                 ("chemical/x-gaussian-cube" "cub")
+                                 ("chemical/x-gaussian-input" "gau" "gjc" "gjf")
+                                 ("chemical/x-gaussian-log" "gal")
+                                 ("chemical/x-gcg8-sequence" "gcg")
+                                 ("chemical/x-genbank" "gen")
+                                 ("chemical/x-hin" "hin")
+                                 ("chemical/x-isostar" "istr" "ist")
+                                 ("chemical/x-jcamp-dx" "jdx" "dx")
+                                 ("chemical/x-kinemage" "kin")
+                                 ("chemical/x-macmolecule" "mcm")
+                                 ("chemical/x-macromodel-input" "mmd" "mmod")
+                                 ("chemical/x-mdl-molfile" "mol")
+                                 ("chemical/x-mdl-rdfile" "rd")
+                                 ("chemical/x-mdl-rxnfile" "rxn")
+                                 ("chemical/x-mdl-sdfile" "sd" "sdf")
+                                 ("chemical/x-mdl-tgf" "tgf")
+                                 ("chemical/x-mmcif" "mcif")
+                                 ("chemical/x-mol2" "mol2")
+                                 ("chemical/x-molconn-Z" "b")
+                                 ("chemical/x-mopac-graph" "gpt")
+                                 ("chemical/x-mopac-input" "mop" "mopcrt" "mpc" "dat" "zmt")
+                                 ("chemical/x-mopac-out" "moo")
+                                 ("chemical/x-mopac-vib" "mvb")
+                                 ("chemical/x-ncbi-asn1" "asn")
+                                 ("chemical/x-ncbi-asn1-ascii" "prt" "ent")
+                                 ("chemical/x-ncbi-asn1-binary" "val" "aso")
+                                 ("chemical/x-ncbi-asn1-spec" "asn")
+                                 ("chemical/x-pdb" "pdb" "ent")
+                                 ("chemical/x-rosdal" "ros")
+                                 ("chemical/x-swissprot" "sw")
+                                 ("chemical/x-vamas-iso14976" "vms")
+                                 ("chemical/x-vmd" "vmd")
+                                 ("chemical/x-xtel" "xtel")
+                                 ("chemical/x-xyz" "xyz")
+                                 ("image/gif" "gif")
+                                 ("image/ief" "ief")
+                                 ("image/jpeg" "jpeg" "jpg" "jpe")
+                                 ("image/pcx" "pcx")
+                                 ("image/png" "png")
+                                 ("image/svg+xml" "svg" "svgz")
+                                 ("image/tiff" "tiff" "tif")
+                                 ("image/vnd.djvu" "djvu" "djv")
+                                 ("image/vnd.wap.wbmp" "wbmp")
+                                 ("image/x-cmu-raster" "ras")
+                                 ("image/x-coreldraw" "cdr")
+                                 ("image/x-coreldrawpattern" "pat")
+                                 ("image/x-coreldrawtemplate" "cdt")
+                                 ("image/x-corelphotopaint" "cpt")
+                                 ("image/x-icon" "ico")
+                                 ("image/x-jg" "art")
+                                 ("image/x-jng" "jng")
+                                 ("image/x-ms-bmp" "bmp")
+                                 ("image/x-photoshop" "psd")
+                                 ("image/x-portable-anymap" "pnm")
+                                 ("image/x-portable-bitmap" "pbm")
+                                 ("image/x-portable-graymap" "pgm")
+                                 ("image/x-portable-pixmap" "ppm")
+                                 ("image/x-rgb" "rgb")
+                                 ("image/x-xbitmap" "xbm")
+                                 ("image/x-xpixmap" "xpm")
+                                 ("image/x-xwindowdump" "xwd")
+                                 ("model/iges" "igs" "iges")
+                                 ("model/mesh" "msh" "mesh" "silo")
+                                 ("model/vrml" "wrl" "vrml")
+                                 ("text/calendar" "ics" "icz")
+                                 ("text/comma-separated-values" "csv")
+                                 ("text/css" "css")
+                                 ("text/h323" "323")
+                                 ("text/html" "html" "htm" "shtml")
+                                 ("text/iuls" "uls")
+                                 ("text/mathml" "mml")
+                                 ("text/plain" "asc" "txt" "text" "diff" "pot")
+                                 ("text/richtext" "rtx")
+                                 ("text/rtf" "rtf")
+                                 ("text/scriptlet" "sct" "wsc")
+                                 ("text/texmacs" "tm" "ts")
+                                 ("text/tab-separated-values" "tsv")
+                                 ("text/vnd.sun.j2me.app-descriptor" "jad")
+                                 ("text/vnd.wap.wml" "wml")
+                                 ("text/vnd.wap.wmlscript" "wmls")
+                                 ("text/x-bibtex" "bib")
+                                 ("text/x-boo" "boo")
+                                 ("text/x-c++hdr" "h++" "hpp" "hxx" "hh")
+                                 ("text/x-c++src" "c++" "cpp" "cxx" "cc")
+                                 ("text/x-chdr" "h")
+                                 ("text/x-component" "htc")
+                                 ("text/x-csh" "csh")
+                                 ("text/x-csrc" "c")
+                                 ("text/x-dsrc" "d")
+                                 ("text/x-haskell" "hs")
+                                 ("text/x-java" "java")
+                                 ("text/x-literate-haskell" "lhs")
+                                 ("text/x-moc" "moc")
+                                 ("text/x-pascal" "pp" "as")
+                                 ("text/x-pcs-gcd" "gcd")
+                                 ("text/x-perl" "pl" "pm")
+                                 ("text/x-python" "py")
+                                 ("text/x-setext" "etx")
+                                 ("text/x-sh" "sh")
+                                 ("text/x-tcl" "tcl" "tk")
+                                 ("text/x-tex" "tex" "ltx" "sty" "cls")
+                                 ("text/x-vcalendar" "vcs")
+                                 ("text/x-vcard" "vcf")
+                                 ("video/dl" "dl")
+                                 ("video/dv" "dif" "dv")
+                                 ("video/fli" "fli")
+                                 ("video/gl" "gl")
+                                 ("video/mpeg" "mpeg" "mpg" "mpe")
+                                 ("video/mp4" "mp4")
+                                 ("video/quicktime" "qt" "mov")
+                                 ("video/vnd.mpegurl" "mxu")
+                                 ("video/x-la-asf" "lsf" "lsx")
+                                 ("video/x-mng" "mng")
+                                 ("video/x-ms-asf" "asf" "asx")
+                                 ("video/x-ms-wm" "wm")
+                                 ("video/x-ms-wmv" "wmv")
+                                 ("video/x-ms-wmx" "wmx")
+                                 ("video/x-ms-wvx" "wvx")
+                                 ("video/x-msvideo" "avi")
+                                 ("video/x-sgi-movie" "movie")
+                                 ("x-conference/x-cooltalk" "ice")
+                                 ("x-world/x-vrml" "vrm" "vrml" "wrl"))
+  "An alist where the cars are MIME types and the cdrs are list
+of file suffixes for the corresponding type.")
+
+(defparameter *mime-type-hash*
+  (let ((hash (make-hash-table :test #'equalp)))
+    (loop for (type . suffixes) in *mime-type-list* do
+          (loop for suffix in suffixes do
+                (setf (gethash suffix hash) type)))
+    hash)
+  "A hash table which maps file suffixes to MIME types.")
+
+(defun mime-type (pathspec)
+  "Given a pathname designator PATHSPEC returns the MIME type
+\(as a string) corresponding to the suffix of the file denoted by
+PATHSPEC \(or NIL)."
+  (gethash (pathname-type pathspec) *mime-type-hash*))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/misc.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,276 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/misc.lisp,v 1.13 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(let ((scanner-hash (make-hash-table :test #'equal)))
+  (defun scanner-for-get-param (param-name)
+    "Returns a CL-PPCRE scanner which matches a GET parameter in a
+URL.  Scanners are memoized in SCANNER-HASH once they are created."
+    (or (gethash param-name scanner-hash)
+        (setf (gethash param-name scanner-hash)
+                (create-scanner
+                 `(:alternation
+                   ;; session=value at end of URL
+                   (:sequence
+                    (:char-class #\? #\&)
+                    ,param-name
+                    #\=
+                    (:greedy-repetition 0 nil (:inverted-char-class #\&))
+                    :end-anchor)
+                   ;; session=value with other parameters following
+                   (:sequence
+                    (:register (:char-class #\? #\&))
+                    ,param-name
+                    #\=
+                    (:greedy-repetition 0 nil (:inverted-char-class #\&))
+                    #\&))))))
+  (defun add-cookie-value-to-url (url &key (cookie-name *session-cookie-name*)
+                                           (value (session-cookie-value))
+                                           (replace-ampersands-p t))
+    "Removes all GET parameters named COOKIE-NAME from URL and then
+adds a new GET parameter with the name COOKIE-NAME and the value
+VALUE.  If REPLACE-AMPERSANDS-P is true all literal ampersands in URL
+are replaced with '&amp;'. The resulting URL is returned."
+    (unless url
+      ;; see URL-REWRITE:*URL-REWRITE-FILL-TAGS*
+      (setq url (request-uri *request*)))
+    (setq url (regex-replace-all (scanner-for-get-param cookie-name) url "\\1"))
+    (when value
+      (setq url (format nil "~A~:[?~;&~]~A=~A"
+                        url 
+                        (find #\? url)
+                        cookie-name
+                        (url-encode value))))
+    (when replace-ampersands-p
+      (setq url (regex-replace-all "&" url "&amp;")))
+    url))
+
+(defun maybe-rewrite-urls-for-session (html &key (cookie-name *session-cookie-name*)
+                                                 (value (session-cookie-value)))
+  "Rewrites the HTML page HTML such that the name/value pair
+COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
+cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
+true.  See the docs for URL-REWRITE:REWRITE-URLS."
+  (cond ((or (not *rewrite-for-session-urls*)
+             (null value)
+             (cookie-in cookie-name))
+          html)
+        (t
+          (with-input-from-string (*standard-input* html)
+            (with-output-to-string (*standard-output*)
+              (url-rewrite:rewrite-urls
+               (lambda (url)
+                 (add-cookie-value-to-url url
+                                          :cookie-name cookie-name
+                                          :value value))))))))
+
+(defmethod dispatch-request (dispatch-table)
+  "Dispatches *REQUEST* based upon rules in the DISPATCH-TABLE.
+This method provides the default Hunchentoot behavior."
+  (loop for dispatcher in dispatch-table
+        for action = (funcall dispatcher *request*)
+        when action return (funcall action)
+        finally (setf (return-code *reply*) +http-not-found+)))
+
+(defun default-dispatcher (request)
+  "Default dispatch function which handles every request with the
+function stored in *DEFAULT-HANDLER*."
+  (declare (ignore request))
+  *default-handler*)
+
+(defun default-handler ()
+  "The handler that is supposed to serve the request if no other
+handler is called."
+  (log-message :info "Default handler called for script ~A" (script-name))
+  (format nil "<html><head><title>Hunchentoot</title></head><body><h2>Hunchentoot Default Page</h2><p>This the Hunchentoot default page. You're most likely seeing it because the server administrator hasn't set up a custom default page yet.</p><p>Hunchentoot is a web server written in <a href='http://www.lisp.org/'>Common Lisp</a>.  More info about Hunchentoot can be found at <a href='http://weitz.de/hunchentoot/'>http://weitz.de/hunchentoot/</a>.</p></p><p><hr>~A</p></body></html>"
+          (address-string)))
+
+(defun create-prefix-dispatcher (prefix page-function)
+  "Creates a dispatch function which will dispatch to the
+function denoted by PAGE-FUNCTION if the file name of the current
+request starts with the string PREFIX."
+  (lambda (request)
+    (let ((mismatch (mismatch (script-name request) prefix
+                              :test #'char=)))
+      (and (or (null mismatch)
+               (>= mismatch (length prefix)))
+           page-function))))
+
+(defun create-regex-dispatcher (regex page-function)
+  "Creates a dispatch function which will dispatch to the
+function denoted by PAGE-FUNCTION if the file name of the current
+request matches the CL-PPCRE regular expression REGEX."
+  (let ((scanner (create-scanner regex)))
+    (lambda (request)
+      (and (scan scanner (script-name request))
+           page-function))))
+
+(defun handle-static-file (path &optional content-type)
+  "A function which acts like a Hunchentoot handler for the file
+denoted by PATH.  Send a content type header corresponding to
+CONTENT-TYPE or \(if that is NIL) tries to determine the content
+type via the file's suffix."
+  (unless (or (pathname-name path)
+              (pathname-type path))
+    ;; not a file
+    (setf (return-code) +http-bad-request+)
+    (throw 'handler-done nil))
+  (unless (probe-file path)
+    ;; does not exist
+    (setf (return-code) +http-not-found+)
+    (throw 'handler-done nil))
+  (let ((time (or (file-write-date path) (get-universal-time))))
+    (setf (content-type) (or content-type
+                             (mime-type path)
+                             "application/octet-stream"))
+    (handle-if-modified-since time)
+    (with-open-file (file path
+                     :direction :input
+                     :element-type 'octet
+                     :if-does-not-exist nil)
+      (setf (header-out "Last-Modified") (rfc-1123-date time)
+            (content-length) (file-length file))
+      (let ((out (send-headers)))
+        #+:clisp
+        (setf (flexi-stream-element-type *hunchentoot-stream*) 'octet)
+        (loop with buf = (make-array +buffer-length+ :element-type 'octet)
+              for pos = (read-sequence buf file)
+              until (zerop pos)
+              do (write-sequence buf out :end pos)
+                 (finish-output out))))))
+
+(defun create-static-file-dispatcher-and-handler (uri path &optional content-type)
+  "Creates and returns a dispatch function which will dispatch to a
+handler function which emits the file denoted by the pathname
+designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of
+the request matches the string URI.  If CONTENT-TYPE is NIL tries to
+determine the content type via the file's suffix."
+  ;; the dispatcher
+  (lambda (request)
+    (when (equal (script-name request) uri)
+      ;; the handler
+      (lambda ()
+        (handle-static-file path content-type)))))
+
+(defun enough-url (url url-prefix)
+  "Returns the relative portion of URL relative to URL-PREFIX, similar
+to what ENOUGH-NAMESTRING does for pathnames."
+  (subseq url (mismatch url url-prefix)))
+
+(defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
+  "Creates and returns a dispatch function which will dispatch to a
+handler function which emits the file relative to BASE-PATH that is
+denoted by the URI of the request relative to URI-PREFIX.  URI-PREFIX
+must be a string ending with a slash, BASE-PATH must be a pathname
+designator for an existing directory.  If CONTENT-TYPE is not NIL,
+it'll be the content type used for all files in the folder."
+  (unless (and (stringp uri-prefix)
+               (plusp (length uri-prefix))
+               (char= (char uri-prefix (1- (length uri-prefix))) #\/))
+    (error "~S must be string ending with a slash." uri-prefix))
+  (when (or (pathname-name base-path)
+            (pathname-type base-path))
+    (error "~S is supposed to denote a directory." base-path))
+  (flet ((handler ()
+           (let* ((script-name (url-decode (script-name)))
+                  (script-path (enough-url (regex-replace-all "\\\\" script-name "/")
+                                           uri-prefix))
+                  (script-path-directory (pathname-directory script-path)))
+             (unless (or (stringp script-path-directory)
+                         (null script-path-directory)
+                         (and (listp script-path-directory)
+                              (eq (first script-path-directory) :relative)
+                              (loop for component in (rest script-path-directory)
+                                    always (stringp component))))
+               (setf (return-code) +http-forbidden+)
+               (throw 'handler-done nil))
+             (handle-static-file (merge-pathnames script-path base-path) content-type))))
+    (create-prefix-dispatcher uri-prefix #'handler)))
+
+(defun no-cache ()
+  "Adds appropriate headers to completely prevent caching on most browsers."
+  (setf (header-out "Expires")
+          "Mon, 26 Jul 1997 05:00:00 GMT"
+        (header-out "Cache-Control")
+          "no-store, no-cache, must-revalidate, post-check=0, pre-check=0"
+        (header-out "Pragma")
+          "no-cache"
+        (header-out "Last-Modified")
+          (rfc-1123-date))
+  (values))
+
+(defun ssl-p ()
+  "Whether the current connection to the client is secure."
+  (cond ((server-mod-lisp-p *server*) (ssl-session-id *request*))
+        (t #-:hunchentoot-no-ssl (server-ssl-certificate-file *server*)
+           #+:hunchentoot-no-ssl nil)))
+
+(defun redirect (target &key (host (host *request*) host-provided-p)
+                             port
+                             (protocol (if (ssl-p) :https :http))
+                             (add-session-id (not (or host-provided-p
+                                                      (starts-with-scheme-p target)
+                                                      (cookie-in *session-cookie-name*))))
+                             permanently)
+  "Redirects the browser to TARGET which should be a string.  If
+TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL
+are ignored.  Otherwise, TARGET should denote the path part of a URL,
+PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to
+redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET.
+Adds a session ID if ADD-SESSION-ID is true.  If PERMANENTLY is true,
+a 301 request is sent to the browser, otherwise a 302."
+  (let ((url (if (starts-with-scheme-p target)
+               target
+               (format nil "~A://~A~@[:~A~]~A"
+                       (ecase protocol
+                         ((:http) "http")
+                         ((:https) "https"))
+                       (if port                         
+                         (first (ppcre:split ":" (or host "")))
+                         host)
+                       port target))))
+    (when add-session-id
+      (setq url (add-cookie-value-to-url url :replace-ampersands-p nil)))
+    (setf (header-out :location)
+            url
+          (return-code *reply*)
+            (if permanently
+              +http-moved-permanently+
+              +http-moved-temporarily+))
+    (throw 'handler-done nil)))
+
+(defun require-authorization (&optional (realm "Hunchentoot"))
+  "Sends back appropriate headers to require basic HTTP authentication
+\(see RFC 2617) for the realm REALM."
+  (setf (header-out "WWW-Authenticate")
+          (format nil "Basic realm=\"~A\"" (quote-string realm))
+        (return-code *reply*)
+          +http-authorization-required+)
+  (throw 'handler-done nil))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/packages.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,228 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/packages.lisp,v 1.33 2007/09/18 14:23:23 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :hunchentoot-mp
+  (:nicknames :tbnl-mp)
+  (:use :cl)
+  (:export :*current-process*
+           :make-lock
+           :with-lock
+           :process-run-function
+           :process-kill))
+
+(defpackage :hunchentoot
+  (:nicknames :tbnl)
+  (:use :cl :cl-ppcre :chunga :flexi-streams :url-rewrite :hunchentoot-mp)
+  (:shadow :assoc
+           #+:sbcl :defconstant
+           :handler-case
+           :ignore-errors
+           :url-encode)
+  ;; see ASDF system definition
+  (:import-from :hunchentoot-asd :*hunchentoot-version*)
+  #+:lispworks
+  (:import-from :lw :with-unique-names :when-let)
+  (:export :*approved-return-codes*
+           :*catch-errors-p*
+           :*cleanup-function*
+           :*cleanup-interval*
+           :*content-types-for-url-rewrite*
+           :*default-content-type*
+           :*default-handler*
+           :*default-log-level*
+           :*default-read-timeout*
+           :*default-write-timeout*
+           :*dispatch-table*
+           :*file-upload-hook*
+           :*handle-http-errors-p*
+           :*header-stream*
+           :*http-error-handler*
+           :*hunchentoot-default-external-format*
+           :*lisp-errors-log-level*
+           :*lisp-warnings-log-level*
+           :*listener*
+           :*log-lisp-backtraces-p*
+           :*log-lisp-errors-p*
+           :*log-lisp-warnings-p*
+           :*log-prefix*
+           :*meta-dispatcher*
+           :*methods-for-post-parameters*
+           :*reply*
+           :*request*
+           :*rewrite-for-session-urls*
+           :*server*
+           :*session*
+           :*session-cookie-name*
+           :*session-gc-frequency*
+           :*session-max-time*
+           :*session-removal-hook*
+           :*show-access-log-messages*
+           :*show-lisp-backtraces-p*
+           :*show-lisp-errors-p*
+           :*tmp-directory*
+           :*use-remote-addr-for-sessions*
+           :*use-user-agent-for-sessions*
+           :+http-accepted+
+           :+http-authorization-required+
+           :+http-bad-gateway+
+           :+http-bad-request+
+           :+http-conflict+
+           :+http-continue+
+           :+http-created+
+           :+http-expectation-failed+
+           :+http-failed-dependency+
+           :+http-forbidden+
+           :+http-gateway-time-out+
+           :+http-gone+
+           :+http-internal-server-error+
+           :+http-length-required+
+           :+http-method-not-allowed+
+           :+http-moved-permanently+
+           :+http-moved-temporarily+
+           :+http-multiple-choices+
+           :+http-multi-status+
+           :+http-no-content+
+           :+http-non-authoritative-information+
+           :+http-not-acceptable+
+           :+http-not-found+
+           :+http-not-implemented+
+           :+http-not-modified+
+           :+http-ok+
+           :+http-partial-content+
+           :+http-payment-required+
+           :+http-precondition-failed+
+           :+http-proxy-authentication-required+
+           :+http-request-entity-too-large+
+           :+http-request-time-out+
+           :+http-request-uri-too-large+
+           :+http-requested-range-not-satisfiable+
+           :+http-reset-content+
+           :+http-see-other+
+           :+http-service-unavailable+
+           :+http-switching-protocols+
+           :+http-temporary-redirect+
+           :+http-unsupported-media-type+
+           :+http-use-proxy+
+           :+http-version-not-supported+
+           :authorization
+           :aux-request-value
+           :content-length
+           :content-type
+           :cookie-domain
+           :cookie-expires
+           :cookie-http-only
+           :cookie-in
+           :cookie-name
+           :cookie-out
+           :cookie-path
+           :cookie-secure
+           :cookie-value
+           :cookies-in
+           :cookies-out
+           :create-folder-dispatcher-and-handler
+           :create-prefix-dispatcher
+           :create-regex-dispatcher
+           :create-static-file-dispatcher-and-handler
+           :default-dispatcher
+           :define-easy-handler
+           :delete-aux-request-value
+           :delete-session-value
+           :dispatch-easy-handlers
+           :dispatch-request
+           :do-sessions
+           :escape-for-html
+           :get-backtrace
+           :get-parameter
+           :get-parameters
+           :handle-if-modified-since
+           :handle-static-file
+           :handler-done
+           :header-in
+           :header-out
+           :headers-in
+           :headers-out
+           :host
+           :http-token-p
+           :log-file
+           :log-message
+           :log-message*
+           :maybe-invoke-debugger
+           :mime-type
+           :mod-lisp-id
+           :no-cache
+           :parameter
+           :post-parameter
+           :post-parameters
+           :query-string
+           :raw-post-data
+           :real-remote-addr
+           :reason-phrase
+           :recompute-request-parameters
+           :redirect
+           :referer
+           :remote-addr
+           :remote-port
+           :remove-session
+           :reply-external-format
+           :request-method
+           :request-uri
+           :require-authorization
+           :reset-sessions
+           :return-code
+           :rfc-1123-date
+           :script-name
+           :send-headers
+           :server-addr
+           :server-address
+           :server-dispatch-table
+           :server-local-port
+           :server-name
+           :server-port
+           :server-protocol
+           :session-counter
+           :session-gc
+           :session-max-time
+           :session-too-old-p
+           :session-remote-addr
+           :session-cookie-value
+           :session-user-agent
+           :session-value
+           :set-cookie
+           :set-cookie*
+           :ssl-p
+           :ssl-session-id
+           :start-server
+           :start-session
+           :stop-server
+           :url-decode
+           :url-encode
+           :user-agent))
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-acl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,145 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-acl.lisp,v 1.10 2007/11/03 21:46:18 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  #-(and :allegro-version>= (version>= 7 0))
+  (error "You need at least version 7.0 of AllegroCL.")
+  ;; make sure code for sockets and OS interface is loaded
+  (require :sock)
+  (require :osi))
+
+(defun make-lock (name)
+  "See AllegroCL documentation for MP:MAKE-PROCESS-LOCK."
+  (mp:make-process-lock :name name))
+
+(defmacro with-lock ((lock) &body body)
+  "See AllegroCL documentation for MP:WITH-PROCESS-LOCK."
+  `(mp:with-process-lock (,lock) , at body))
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Like INCF but wrapped with SYS:WITHOUT-SCHEDULING so other
+threads can't interfer."
+  `(sys:without-scheduling (incf ,place ,delta)))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "See AllegroCL documentation for SYS:WITH-TIMEOUT."
+  `(sys:with-timeout (,seconds , at timeout-forms) , at body))
+
+(defun process-run-function (name function &rest args)
+  "See AllegroCL documentation for MP:PROCESS-RUN-FUNCTION."
+  (apply #'mp:process-run-function name function args))
+
+(defun process-kill (process)
+  "See AllegroCL documentation for MP:PROCESS-KILL."
+  (mp:process-kill process))
+
+(define-symbol-macro *current-process*
+  mp:*current-process*)
+
+(defun process-allow-scheduling ()
+  "See AllegroCL documentation for MP:PROCESS-ALLOW-SCHEDULE."
+  (mp:process-allow-schedule))
+
+(defun start-up-server (&key service address process-name announce function &allow-other-keys)
+  "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER.  See
+<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm>
+for more info."
+  (let (done)
+    (flet ((open-socket-and-accept ()
+             (handler-bind ((error (lambda (condition)
+                                     (funcall announce nil condition)
+                                     (setq done condition)
+                                     (return-from open-socket-and-accept))))
+               (let (socket)
+                 (unwind-protect
+                     (progn
+                       (setf socket (socket:make-socket :address-family :internet
+                                       :type :hiper
+                                       :format :bivalent
+                                       :connect :passive
+                                       :local-host address
+                                       :local-port service
+                                       :reuse-address t
+                                       :backlog 5))
+                       (funcall announce socket)
+                       (setq done socket)
+                       (loop (funcall function (socket:accept-connection socket :wait t))))
+                   (when socket
+                     (cl:ignore-errors (close socket))))))))
+      (let ((listener-thread (process-run-function process-name #'open-socket-and-accept)))
+        (mp:process-wait "Waiting for server to start" (lambda () done))
+        (typecase done
+          (socket:socket listener-thread)
+          (t (values nil done)))))))
+
+(defun make-socket-stream (socket read-timeout write-timeout)
+  "Accepts a socket `handle' SOCKET and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  ;; in the case of AllegroCL, SOCKET:ACCEPT-CONNECTION already
+  ;; returned a stream
+  (socket:set-socket-options socket :nodelay t)
+  (socket:socket-control socket
+                         :read-timeout read-timeout
+                         :write-timeout write-timeout)
+  (values socket
+          (ignore-errors
+            (socket:ipaddr-to-dotted (socket:local-host socket)))
+          (ignore-errors
+            (socket:ipaddr-to-dotted (socket:remote-host socket)))
+          (ignore-errors
+            (socket:remote-port socket))))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace."
+  (with-output-to-string (s)
+    (with-standard-io-syntax
+      (let ((*print-readably* nil)
+            (*print-miser-width* 40)
+            (*print-pretty* t)
+            (tpl:*zoom-print-circle* t)
+            (tpl:*zoom-print-level* nil)
+            (tpl:*zoom-print-length* nil))
+        (cl:ignore-errors
+          (format *terminal-io* "~
+~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+                  error))
+        (cl:ignore-errors
+          (let ((*terminal-io* s)
+                (*standard-output* s))
+            (tpl:do-command "zoom"
+                            :from-read-eval-print-loop nil
+                            :count t
+                            :all t)))))))
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-clisp.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,131 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10; -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-clisp.lisp,v 1.1 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2006, Luis Ol?veira <loliveira at common-lisp.net>.
+;;; Copyright (c) 2007, Anton Vodonosov <avodonosov at yandex.ru>.
+;;; Copyright (c) 2007, Dr. Edmund Weitz.
+;;; All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defmacro with-lock ((lock) &body body)
+  "Executes the BODY.  LOCK is ignored because CLISP doesn't support
+threads."
+  (declare (ignore lock))
+  `(progn , at body))
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Expands to INCF.  No special semantics because CLISP doesn't support threads."
+  `(incf ,place ,delta))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Executes the code BODY and returns the results of the last form.
+SECONDS and TIMEOUT-FORMS are ignored since CLISP doesn't support
+threads."
+  (declare (ignore seconds timeout-forms))  
+  `(progn , at body))
+
+(defun make-lock (lock)
+  "CLISP doesn't support threads, so the function just returns its
+argument LOCK."
+  lock)
+
+(defvar *current-process* "*CURRENT-PROCESS*"
+  "CLISP doesn't support threads, so this value is just a dummy stub.")
+
+(defun process-run-function (name function &rest args)
+  "In a multithreaded environment, this would run FUNCTION in a new
+thread, but in CLISP we just apply FUNCTION to ARGS."
+  (declare (ignore name))
+  (apply function args))
+
+(defun process-allow-scheduling ()
+  "Does nothing because CLISP doesn't support threads."
+  )
+
+(defun process-kill (process)
+  "Does nothing because CLISP doesn't support threads."
+  (declare (ignore process))
+  )
+
+(defun start-up-server (&key service address process-name announce function &allow-other-keys)
+  "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER.  See
+<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm>
+for more info."
+  (declare (ignore process-name))
+  (cl:ignore-errors
+   (let ((socket (socket:socket-server service :interface address :backlog 5)))
+      (funcall announce socket)
+      (unwind-protect
+           (loop (funcall function 
+                          (socket:socket-accept socket 
+                                                :buffered t 
+                                                :element-type 'octet)))
+        (cl:ignore-errors
+          (socket:socket-server-close socket))))))
+
+(defun make-socket-stream (socket read-timeout write-timeout)
+  "Accepts a socket `handle' HANDLE and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  (socket:socket-options socket
+                         :SO-RCVTIMEO read-timeout
+                         :SO-SNDTIMEO write-timeout)
+  (multiple-value-bind (remote-host remote-port)
+      (socket:socket-stream-peer socket)
+    (values socket
+            (nth-value 1 (socket:socket-stream-local socket))
+            remote-host
+            remote-port)))
+
+;;; the following code is from swank-clisp.lisp (SLIME):
+
+(defun format-frame (frame)
+  "Returns a string describing the call stack frame object FRAME."
+  (string-trim #(#\Newline #\Space #\Tab)
+               (with-output-to-string (out)
+                 (sys::describe-frame out frame))))
+
+(defun function-frame-p (formatted-frame)
+  "Determines whether the frame described by FORMATTED-FRAME 
+is a function frame."
+  (char= #\< (aref formatted-frame 0)))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces."
+  (declare (ignore error))
+  (with-output-to-string (stream)
+    (do ((last nil frame)
+         (frame (sys::the-frame) (sys::frame-up-1 frame 1)))
+        ((eq frame last))
+      (let ((formatted-frame (format-frame frame)))
+        (when (function-frame-p formatted-frame)
+          (write-line (subseq formatted-frame (+ (position #\> formatted-frame) 2)
+                              (position #\Newline formatted-frame))
+                      stream))))))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-cmu.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,137 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-cmu.lisp,v 1.10 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+#-:mp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (error "This library needs a version of CMUCL with MP support."))
+
+(defun make-lock (name)
+  "See CMUCL documentation for MP:MAKE-LOCK."
+  (mp:make-lock name))
+
+(defmacro with-lock ((lock) &body body)
+  "See CMUCL documentation for MP:WITH-LOCK-HELD."
+  `(mp:with-lock-held (,lock) , at body))
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Like INCF but wrapped with MP:WITHOUT-SCHEDULING so other
+threads can't interfer."
+  `(mp:without-scheduling (incf ,place ,delta)))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "See CMUCL documentation for MP:WITH-TIMEOUT."
+  `(mp:with-timeout (,seconds , at timeout-forms) , at body))
+
+(defun process-run-function (name function &rest args)
+  "See CMUCL documentation for MP:MAKE-PROCESS."
+  (mp:make-process (lambda ()
+                     (apply function args))
+                   :name name))
+
+(defun process-kill (process)
+  "See CMUCL documentation for MP:DESTROY-PROCESS."
+  (mp:destroy-process process))
+
+(define-symbol-macro *current-process*
+  mp:*current-process*)
+
+(defun process-allow-scheduling ()
+  "See CMUCL documentation for MP:PROCESS-YIELD."
+  (mp:process-yield))
+
+(defun start-up-server (&key service address process-name announce function &allow-other-keys)
+  "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER.  See
+<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm>
+for more info."
+  (let (done)
+    (flet ((open-socket-and-accept ()
+             (handler-bind ((error (lambda (condition)
+                                     (funcall announce nil condition)
+                                     (setq done condition)
+                                     (return-from open-socket-and-accept))))
+               (let (socket)
+                 (unwind-protect
+                     (progn
+                       (setf socket (ext:create-inet-listener service :stream
+                                                              :reuse-address t
+                                                              :backlog 5
+                                                              :host (or address 0)))
+                       (funcall announce socket)
+                       (setq done socket)
+                       (loop (funcall function (ext:accept-tcp-connection socket))))
+                   (when socket
+                     (cl:ignore-errors
+                       (ext:close-socket socket))))))))
+      (let ((listener-thread (process-run-function process-name #'open-socket-and-accept)))
+        (mp:process-wait "Waiting for server to start" (lambda () done))
+        (typecase done
+          (condition (values nil done))
+          (t listener-thread))))))
+
+(defun format-address (address)
+  "Converts an integer in network byte order denoting an IP
+address into the corresponding string representation."
+  (format nil "~A.~A.~A.~A"
+          (ash address -24)
+          (logand (ash address -16) #xFF)
+          (logand (ash address -8) #xFF)
+          (logand address #xFF)))
+
+(defun make-socket-stream (handle read-timeout write-timeout)
+  "Accepts a socket `handle' HANDLE and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  (declare (ignore write-timeout))
+  (let ((local-host (ext:get-socket-host-and-port handle)))
+    (multiple-value-bind (remote-host remote-port)
+        (ext:get-peer-host-and-port handle)
+      (values (sys:make-fd-stream handle
+                                  :input t :output t
+                                  :element-type 'octet
+                                  :auto-close t
+                                  :buffering :full
+                                  :timeout read-timeout
+                                  :name (format nil "~A:~A" (format-address remote-host) remote-port))
+              (format-address local-host)
+              (format-address remote-host)
+              remote-port))))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace."
+  (declare (ignore error))
+  (with-output-to-string (s)
+    (let ((debug:*debug-print-level* nil)
+          (debug:*debug-print-length* nil))
+      (debug:backtrace most-positive-fixnum s))))
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-lw.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,173 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-lw.lisp,v 1.12 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+#+(and :lispworks4.4 (or :win32 :linux))
+(let ((id :system-cons-free-chain))
+  (unless (scm::patch-id-loaded-p id)
+    (error "You need a patch to improve the performance of this code. Request patch ~S for ~A for ~A from lisp-support at lispworks.com using the Report Bug command."
+          id (lisp-implementation-type)
+          #+:win32 "Windows"
+          #+:linux "Linux")))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; make sure socket code is loaded
+  (require "comm"))
+
+(defun make-lock (name)
+  "See LispWorks documentation for MP:MAKE-LOCK."
+  (mp:make-lock :name name))
+
+(defmacro with-lock ((lock) &body body)
+  "See LispWorks documentation for MP:WITH-LOCK."
+  `(mp:with-lock (,lock) , at body))
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Like INCF but wrapped with MP:WITHOUT-PREEMPTION so other
+threads can't interfer."
+  `(mp:without-preemption (incf ,place ,delta)))
+
+(defun invoke-with-timeout (duration body-fn timeout-fn)
+  "Executes the function \(with no arguments) BODY-FN and returns
+its results but stops execution after DURATION seconds and then
+instead calls TIMEOUT-FN and returns its values."
+  ;; from Portable AllegroServe
+  (block timeout
+    (let* ((process mp:*current-process*)
+           (unsheduledp nil)
+           (timer (mp:make-timer
+                   #'(lambda ()
+                       (mp:process-interrupt process
+                                             #'(lambda ()
+                                                 (unless unsheduledp
+                                                   (return-from timeout
+                                                     (funcall timeout-fn)))))))))
+      (mp:schedule-timer-relative timer duration)
+      (unwind-protect
+          (funcall body-fn)
+        (mp:without-interrupts
+         (mp:unschedule-timer timer)
+         (setf unsheduledp t))))))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Executes the code BODY and returns the results of the last
+form but stops execution after SECONDS seconds and then instead
+executes the code in TIMEOUT-FORMS."
+  ;; from Portable AllegroServe
+  `(invoke-with-timeout ,seconds
+                        #'(lambda ()
+                            , at body)
+                        #'(lambda ()
+                            , at timeout-forms)))
+
+(defun process-run-function (name function &rest args)
+  "See LispWorks documentation for MP:PROCESS-RUN-FUNCTION."
+  (apply #'mp:process-run-function name nil function args))
+
+(defun process-kill (process)
+  "See LispWorks documentation for MP:PROCESS-KILL."
+  (mp:process-kill process))
+
+(define-symbol-macro *current-process*
+  mp:*current-process*)
+
+(defun process-allow-scheduling ()
+  "See LispWorks documentation for MP:PROCESS-ALLOW-SCHEDULING."
+  (mp:process-allow-scheduling))
+
+(defun start-up-server (&rest args)
+  "See LispWorks documentation for COMM:START-UP-SERVER."
+  (apply #'comm:start-up-server args))
+
+(defun make-socket-stream (socket read-timeout write-timeout)
+  "Accepts a socket `handle' SOCKET and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  #-:lispworks5 (declare (ignore write-timeout))
+  (let ((local-host (comm:get-socket-address socket)))
+    (multiple-value-bind (remote-host remote-port)
+        (comm:get-socket-peer-address socket)
+      (values (make-instance 'comm:socket-stream
+                 :socket socket
+                 :direction :io
+                 :read-timeout read-timeout
+                 #+:lispworks5 #+:lispworks5
+                 :write-timeout write-timeout
+                 :element-type 'octet)
+              (ignore-errors
+                (comm:ip-address-string local-host))
+              (ignore-errors
+                (comm:ip-address-string remote-host))
+              remote-port))))
+
+#-:hunchentoot-no-ssl
+(defun make-ssl-server-stream (socket-stream &key certificate-file privatekey-file privatekey-password)
+  "Given the server socket stream SOCKET-STREAM attaches SSL to the
+stream using the certificate file CERTIFICATE-FILE and the private key
+file PRIVATEKEY-FILE.  Both of these values must be namestrings
+denoting the location of the files.  If PRIVATEKEY-PASSWORD is not NIL
+then it should be the password for the private key file \(if
+necessary)."
+  (flet ((ctx-configure-callback (ctx)
+           (when privatekey-password
+             (comm:set-ssl-ctx-password-callback ctx :password privatekey-password))
+           (comm:ssl-ctx-use-certificate-file ctx
+                                              certificate-file
+                                              comm:ssl_filetype_pem)
+           (comm:ssl-ctx-use-privatekey-file ctx
+                                             privatekey-file
+                                             comm:ssl_filetype_pem)))
+    (comm:attach-ssl socket-stream
+                     :ctx-configure-callback #'ctx-configure-callback)))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace."
+  (declare (ignore error))
+  (with-output-to-string (s)
+    (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many most-positive-fixnum))
+          (*debug-io* s)
+          (dbg:*debug-print-level* nil)
+          (dbg:*debug-print-length* nil))
+      (dbg:bug-backtrace nil))))
+
+;; some help for the IDE
+(dspec:define-dspec-alias defvar-unbound (name)
+  `(defparameter ,name))
+
+(dspec:define-dspec-alias def-http-return-code (name)
+  `(defconstant ,name))
+
+(editor:setup-indent "defvar-unbound" 1 2 4)
+
+(editor:setup-indent "def-http-return-code" 1 2 4)
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,136 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-mcl.lisp,v 1.9 2007/11/03 21:46:19 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun make-lock (name)
+  "See OpenMCL documentation for CCL:MAKE-LOCK."
+  (ccl:make-lock name))
+
+(defmacro with-lock ((lock) &body body)
+  "See OpenMCL documentation for CCL:WITH-LOCK-GRABBED."
+  `(ccl:with-lock-grabbed (,lock) , at body))
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Like INCF, but other threads can't interfer."
+  `(ccl::atomic-incf-decf ,place ,delta))
+
+(defun invoke-with-timeout (seconds bodyfn timeoutfn)
+  "Executes the function \(with no arguments) BODY-FN and returns
+its results but stops execution after DURATION seconds and then
+instead calls TIMEOUT-FN and returns its values."
+  ;; from Portable AllegroServe
+  (block timeout
+    (let* ((timer (ccl::make-timer-request seconds
+                                           #'(lambda ()
+                                               (return-from timeout (funcall timeoutfn))))))
+      (ccl::enqueue-timer-request timer)
+      (unwind-protect (funcall bodyfn)
+	(ccl::dequeue-timer-request timer)))))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Executes the code BODY and returns the results of the last
+form but stops execution after SECONDS seconds and then instead
+executes the code in TIMEOUT-FORMS."
+  ;; from Portable AllegroServe
+  `(invoke-with-timeout ,seconds
+                        #'(lambda () , at body)
+                        #'(lambda () , at timeout-forms)))
+
+(defun process-run-function (name function &rest args)
+  "See OpenMCL documentation for CCL:PROCESS-RUN-FUNCTION."
+  (apply #'ccl:process-run-function name function args))
+
+(defun process-kill (process)
+  "See OpenMCL documentation for CCL:PROCESS-KILL."
+  (ccl:process-kill process))
+
+(define-symbol-macro *current-process*
+  ccl:*current-process*)
+
+(defun process-allow-scheduling ()
+  "See OpenMCL documentation for CCL:PROCESS-ALLOW-SCHEDULE"
+  (ccl:process-allow-schedule))
+
+(defun start-up-server (&key service address process-name announce function &allow-other-keys)
+  "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER.  See
+<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm>
+for more info."
+  (let (done)
+    (flet ((open-socket-and-accept ()
+             (handler-bind ((error (lambda (condition)
+                                     (funcall announce nil condition)
+                                     (setq done condition)
+                                     (return-from open-socket-and-accept))))
+               (let (socket)
+                 (unwind-protect
+                     (progn
+                       (setf socket (ccl:make-socket :address-family :internet
+                                                     :type :stream
+                                                     :connect :passive
+                                                     :local-host address
+                                                     :local-port service
+                                                     :reuse-address t
+                                                     :backlog 5))
+                       (funcall announce socket)
+                       (setq done socket)
+                       (loop (funcall function (ccl:accept-connection socket :wait t))))
+                   (when socket
+                     (cl:ignore-errors
+                       (close socket))))))))
+      (let ((listener-thread (process-run-function process-name #'open-socket-and-accept)))
+        (ccl:process-wait "Waiting for server to start" (lambda () done))
+        (typecase done
+          (condition (values nil done))
+          (t listener-thread))))))
+
+(defun make-socket-stream (socket read-timeout write-timeout)
+  "Accepts a socket `handle' SOCKET and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  (declare (ignore read-timeout write-timeout))
+  (values socket
+          (ignore-errors 
+            (ccl:ipaddr-to-dotted (ccl:local-host socket)))
+          (ignore-errors 
+            (ccl:ipaddr-to-dotted (ccl:remote-host socket)))
+          (ignore-errors
+            (ccl:remote-port socket))))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace."
+  (with-output-to-string (s)
+    (let ((*debug-io* s))
+      (format *terminal-io* "~
+~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+              error)
+      (ccl:print-call-history :detailed-p nil))))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-sbcl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,205 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/port-sbcl.lisp,v 1.13 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+#-:sb-unicode
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (error "This library needs a version of SBCL with Unicode support."))
+
+#-:sb-thread
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (warn "Without thread support, this library is only useful for development."))
+
+(defmacro defconstant (name value &optional doc)
+  "Make sure VALUE is evaluated only once \(to appease SBCL)."
+  `(cl:defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+     ,@(when doc (list doc))))
+
+(defun make-lock (name)
+  "See SBCL documentation for SB-THREAD:MAKE-MUTEX."
+  (sb-thread:make-mutex :name name))
+
+(defmacro with-lock ((lock) &body body)
+  "See SBCL documentation for SB-THREAD:WITH-RECURSIVE-LOCK."
+  `(sb-thread:with-recursive-lock (,lock) , at body))
+
+(defvar *incf-mutex* (sb-thread:make-mutex :name "incf-mutex")
+  "The mutex used for ATOMIC-INCF.")
+
+(defmacro atomic-incf (place &optional (delta 1))
+  "Like INCF but protected by a mutex, so other threads can't
+interfer."
+  `(with-lock (*incf-mutex*) (incf ,place ,delta)))
+
+;; determine whether SB-EXT:WITH-TIMEOUT is supported; we can't just
+;; use (FIND-SYMBOL "WITH-TIMEOUT" "SB-EXT") because sometimes (for
+;; example in SBCL 1.0.6 for Win32) the function is present, but
+;; doesn't work
+(eval-when (:compile-toplevel :load-toplevel :execute)     
+  (defun ensured-sleep-millis (milliseconds)
+    "Sleeps \(in fact loops) not less then MILLISECONDS number of
+milliseconds; the minimal sleep time is one internal time unit. Don't
+use this function for large time values, because it eats processor
+power."
+    (do ((start-time (get-internal-real-time)))
+        ((< (+ start-time (ceiling (* internal-time-units-per-second 
+                                      (/ milliseconds 1000))))
+            (get-internal-real-time)))))
+  (cl:handler-case
+      (sb-ext:with-timeout 0.0000001 (ensured-sleep-millis 5))
+    (sb-ext:timeout ()
+      (pushnew :hunchentoot-sbcl-with-timeout *features*))
+    (t ())))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Executes the code BODY and returns the results of the last
+form but stops execution after SECONDS seconds and then instead
+executes the code in TIMEOUT-FORMS."
+  (declare (ignorable seconds timeout-forms body))
+  #-:hunchentoot-sbcl-with-timeout `(cl:progn , at body)
+  #+:hunchentoot-sbcl-with-timeout
+  `(cl:handler-case
+     (sb-ext:with-timeout ,seconds , at body)
+     (sb-ext:timeout () , at timeout-forms)))
+
+(defun process-run-function (name function &rest args)
+  "See SBCL documentation for SB-THREAD:MAKE-THREAD."
+  (declare (ignorable name))
+  #+:sb-thread
+  (sb-thread:make-thread (lambda ()
+                           (apply function args))
+                         :name name)
+  #-:sb-thread
+  (apply function args))
+
+(defun process-kill (process)
+  "See SBCL documentation for SB-THREAD:TERMINATE-THREAD."
+  (sb-thread:terminate-thread process))
+
+(define-symbol-macro *current-process*
+  sb-thread:*current-thread*)
+
+(defun process-allow-scheduling ()
+  "Used to simulate a function like PROCESS-ALLOW-SCHEDULING
+which can be found in most other Lisps."
+  (sleep .1))
+
+(defun resolve-hostname (name)
+  "Converts from different types to represent an IP address to
+the canonical representation which is an array with four
+integers."
+  (typecase name
+    (null #(0 0 0 0))
+    (string (car (sb-bsd-sockets:host-ent-addresses
+                  (sb-bsd-sockets:get-host-by-name name))))
+    (integer (make-array 4 :initial-contents (list (ash name -24)
+                                                   (logand (ash name -16) #xFF)
+                                                   (logand (ash name -8) #xFF)
+                                                   (logand name #xFF))))
+    (t name)))
+
+(defun start-up-server (&key service address process-name announce function &allow-other-keys)
+  "Tries to \(partly) emulate LispWorks' COMM:START-UP-SERVER.  See
+<http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-56.htm>
+for more info."
+  (let (done)
+    (flet ((open-socket-and-accept ()
+             (handler-bind ((error (lambda (condition)
+                                     (funcall announce nil condition)
+                                     (setq done condition)
+                                     (return-from open-socket-and-accept))))
+               (let (socket)
+                 (unwind-protect
+                     (progn
+                       (setf socket (make-instance 'sb-bsd-sockets:inet-socket
+                                       :type :stream
+                                       :protocol :tcp)
+                             (sb-bsd-sockets:sockopt-reuse-address socket) t)
+                       (sb-bsd-sockets:socket-bind socket (resolve-hostname address) service)
+                       (sb-bsd-sockets:socket-listen socket 5)
+                       (funcall announce socket)
+                       (setq done socket)
+                       (loop (funcall function (sb-bsd-sockets:socket-accept socket))))
+                   (when socket
+                     (cl:ignore-errors
+                       (sb-bsd-sockets:socket-close socket))))))))
+      (let ((listener-thread (process-run-function process-name #'open-socket-and-accept)))
+        (loop until done do (sleep .1))
+        (typecase done
+          (sb-bsd-sockets:inet-socket listener-thread)
+          (t (values nil done)))))))
+
+(defun format-address (address)
+  "Converts an array of four integers denoting an IP address into
+the corresponding string representation."
+  (format nil "~{~A~^.~}" (coerce address 'list)))
+
+(defun make-socket-stream (socket read-timeout write-timeout)
+  "Accepts a socket `handle' SOCKET and creates and returns a
+corresponding stream, setting its read and write timeout if
+applicable.  Returns three other values - the address the request
+arrived at, and the address and port of the remote host."
+  (declare (ignore write-timeout))
+  (let ((local-host (sb-bsd-sockets:socket-name socket)))
+    (multiple-value-bind (remote-host remote-port)
+        (sb-bsd-sockets:socket-peername socket)
+      (values (sb-bsd-sockets:socket-make-stream socket
+                                                 :input t
+                                                 :output t
+                                                 :element-type 'octet
+                                                 :timeout read-timeout
+                                                 :buffering :full)
+              (format-address local-host)
+              (format-address remote-host)
+              remote-port))))
+
+;; determine how we're going to access the backtrace in the next
+;; function
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
+    (pushnew :hunchentoot-sbcl-debug-print-variable-alist *features*)))
+
+(defun get-backtrace (error)
+  "This is the function that is used internally by Hunchentoot to
+show or log backtraces.  It accepts a condition object ERROR and
+returns a string with the corresponding backtrace."
+  (declare (ignore error))
+  (with-output-to-string (s)
+    #+:hunchentoot-sbcl-debug-print-variable-alist
+    (let ((sb-debug:*debug-print-variable-alist*
+            (list* '(*print-level* . nil)
+                   '(*print-length* . nil)
+                   sb-debug:*debug-print-variable-alist*)))
+      (sb-debug:backtrace most-positive-fixnum s))
+    #-:hunchentoot-sbcl-debug-print-variable-alist
+    (let ((sb-debug:*debug-print-level* nil)
+          (sb-debug:*debug-print-length* nil))
+      (sb-debug:backtrace most-positive-fixnum s))))
+

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/reply.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,144 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/reply.lisp,v 1.19 2007/09/24 13:43:45 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defclass reply ()
+  ((content-type :initform *default-content-type*
+                 :documentation "The outgoing 'Content-Type' http
+header which defaults to the value of *DEFAULT-CONTENT-TYPE*.")
+   (content-length :initform nil
+                   :documentation "The outgoing 'Content-Length'
+http header which defaults NIL.  If this is NIL, Hunchentoot will
+compute the content length.")
+   (headers-out :initform nil
+                :documentation "An alist of the outgoing http headers
+not including the 'Set-Cookie', 'Content-Length', and 'Content-Type'
+headers.  Use the functions HEADER-OUT and \(SETF HEADER-OUT) to
+modify this slot.")
+   (return-code :initform +http-ok+
+                :documentation "The http return code of this
+reply.  The return codes Hunchentoot can handle are defined in
+specials.lisp.")
+   (external-format :initform *hunchentoot-default-external-format*
+                    :documentation "The external format of the reply -
+used for character output.")
+   (log-messages :initform nil
+                 :reader log-messages
+                 :documentation "A list \(in reverse chronological
+order) of the messages which are to be written to the Apache error
+log.  This slot's value should only be modified by the functions
+defined in log.lisp.")
+   (cookies-out :initform nil
+                :documentation "The outgoing cookies.  This slot's
+value should only be modified by the functions defined in
+cookies.lisp."))
+  (:documentation "Objects of this class hold all the information
+about an outgoing reply. They are created automatically by
+Hunchentoot and can be accessed and modified by the corresponding
+handler."))
+
+(defun headers-out (&optional (reply *reply*))
+  "Returns an alist of the outgoing headers associated with the
+REPLY object REPLY."
+  (slot-value reply 'headers-out))
+
+(defun cookies-out (&optional (reply *reply*))
+  "Returns an alist of the outgoing cookies associated with the
+REPLY object REPLY."
+  (slot-value reply 'cookies-out))
+
+(defun (setf cookies-out) (new-value &optional (reply *reply*))
+  "Returns an alist of the outgoing cookies associated with the
+REPLY object REPLY."
+  (setf (slot-value reply 'cookies-out) new-value))
+
+(defun content-type (&optional (reply *reply*))
+  "The outgoing 'Content-Type' http header of REPLY."
+  (slot-value reply 'content-type))
+
+(defun (setf content-type) (new-value &optional (reply *reply*))
+  "Sets the outgoing 'Content-Type' http header of REPLY."
+  (setf (slot-value reply 'content-type) new-value))
+
+(defun content-length (&optional (reply *reply*))
+  "The outgoing 'Content-Length' http header of REPLY."
+  (slot-value reply 'content-length))
+
+(defun (setf content-length) (new-value &optional (reply *reply*))
+  "Sets the outgoing 'Content-Length' http header of REPLY."
+  (setf (slot-value reply 'content-length) new-value))
+
+(defun return-code (&optional (reply *reply*))
+  "The http return code of REPLY.  The return codes Hunchentoot can
+handle are defined in specials.lisp."
+  (slot-value reply 'return-code))
+
+(defun (setf return-code) (new-value &optional (reply *reply*))
+  "Sets the http return code of REPLY."
+  (setf (slot-value reply 'return-code) new-value))
+
+(defun reply-external-format (&optional (reply *reply*))
+  "The external format of REPLY which is used for character output."
+  (slot-value reply 'external-format))
+
+(defun (setf reply-external-format) (new-value &optional (reply *reply*))
+  "Sets the external format of REPLY."
+  (setf (slot-value reply 'external-format) new-value))
+
+(defun header-out-set-p (name &optional (reply *reply*))
+  "Returns a true value if the outgoing http header named NAME has
+been specified already.  NAME should be a keyword or a string."
+  (assoc name (headers-out reply)))
+
+(defun header-out (name &optional (reply *reply*))
+  "Returns the current value of the outgoing http header named NAME.
+NAME should be a keyword or a string."
+  (cdr (assoc name (headers-out reply))))
+
+(defun cookie-out (name &optional (reply *reply*))
+  "Returns the current value of the outgoing cookie named
+NAME. Search is case-sensitive."
+  (cdr (assoc name (cookies-out reply) :test #'string=)))
+
+(defsetf header-out (name &optional (reply '*reply*))
+    (new-value)
+  "Changes the current value of the outgoing http header named NAME (a
+keyword or a string).  If a header with this name doesn't exist, it is
+created."
+  (with-rebinding (name reply)
+    (with-unique-names (symbol place)
+      `(let* ((,symbol (if (stringp ,name) (make-keyword ,name :destructivep nil) ,name))
+              (,place (assoc ,symbol (headers-out ,reply) :test #'string-equal)))
+         (cond
+           (,place
+            (setf (cdr ,place) ,new-value))
+           (t
+            (push (cons ,symbol ,new-value) (slot-value ,reply 'headers-out))
+            ,new-value))))))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/request.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,475 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/request.lisp,v 1.34 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defclass request ()
+  ((headers-in :initarg :headers-in
+               :documentation "An alist of the incoming headers.  Note
+that these might be the headers coming in from mod_lisp which are
+different from the headers sent by the client.")
+   (method :initarg :method
+           :documentation "The request method as a keyword.  This slot
+is only filled if we're not behind mod_lisp.")
+   (uri :initarg :uri
+           :documentation "The request URI as a string.  This slot is
+only filled if we're not behind mod_lisp.")
+   (server-protocol :initarg :server-protocol
+                    :documentation "The HTTP protocol as a keyword.
+This slot is only filled if we're not behind mod_lisp.")
+   (content-stream :initarg :content-stream
+                   :reader content-stream
+                   :documentation "A stream from which the request
+body can be read if there is one.")
+   (cookies-in :initform nil
+               :documentation "An alist of the cookies sent by the client.")
+   (get-parameters :initform nil
+                   :documentation "An alist of the GET parameters sent
+by the client.")
+   (post-parameters :initform nil
+                    :documentation "An alist of the POST parameters
+sent by the client.")
+   (script-name :initform nil
+                :documentation "The URI requested by the client without
+the query string.")
+   (query-string :initform nil
+                 :documentation "The query string of this request.")
+   (session :initform nil
+            :accessor session
+            :documentation "The session object associated with this
+request.")
+   (aux-data :initform nil
+             :accessor aux-data
+             :documentation "Used to keep a user-modifiable alist with
+arbitrary data during the request.")
+   (raw-post-data :initform nil
+                  :documentation "The raw string sent as the body of a
+POST request, populated only if not a multipart/form-data request."))
+  (:documentation "Objects of this class hold all the information
+about an incoming request.  They are created automatically by
+Hunchentoot and can be accessed by the corresponding handler."))
+
+(defun parse-rfc2388-form-data (stream content-type-header)
+  "Creates an alist of POST parameters from the stream STREAM which is
+supposed to be of content type 'multipart/form-data'."
+  (let* ((parsed-content-type-header (rfc2388:parse-header content-type-header :value))
+	 (boundary (or (cdr (rfc2388:find-parameter
+                             "BOUNDARY"
+                             (rfc2388:header-parameters parsed-content-type-header)))
+		       (return-from parse-rfc2388-form-data))))
+    (loop for part in (rfc2388:parse-mime stream boundary)
+          for headers = (rfc2388:mime-part-headers part)
+          for content-disposition-header = (rfc2388:find-content-disposition-header headers)
+          for name = (cdr (rfc2388:find-parameter
+                           "NAME"
+                           (rfc2388:header-parameters content-disposition-header)))
+          when name
+          collect (cons name
+                        (let ((contents (rfc2388:mime-part-contents part)))
+                          (if (pathnamep contents)
+                            (list contents
+                                  (rfc2388:get-file-name headers)
+                                  (rfc2388:content-type part :as-string t))
+                            contents))))))
+
+(defun get-post-data (&key (request *request*) want-stream (already-read 0))
+  "Reads the request body from the stream and stores the raw contents
+\(as an array of octets) in the corresponding slot of the REQUEST
+object.  Returns just the stream if WANT-STREAM is true.  If there's a
+Content-Length header, it is assumed, that ALREADY-READ octets have
+already been read."
+  (let* ((headers-in (headers-in request))
+         (content-length (when-let (content-length-header (cdr (assoc :content-length headers-in)))
+                           (parse-integer content-length-header :junk-allowed t)))
+         (content-stream (content-stream request)))
+    (setf (slot-value request 'raw-post-data)
+          (cond (want-stream
+                 (setf (flexi-stream-position *hunchentoot-stream*) 0)
+                 (when content-length
+                   (setf (flexi-stream-bound content-stream) content-length))
+                 content-stream)
+                ((and content-length (> content-length already-read))
+                 (decf content-length already-read)
+                 (when (input-chunking-p)
+                   ;; see RFC 2616, section 4.4
+                   (log-message :warn "Got Content-Length header although input chunking is on."))
+                 (let ((content (make-array content-length :element-type 'octet)))
+                   #+:clisp (setf (flexi-stream-element-type content-stream) 'octet)
+                   (read-sequence content content-stream)
+                   content))
+                ((input-chunking-p)
+                 (loop with buffer = (make-array +buffer-length+ :element-type 'octet)
+                       with content = (make-array 0 :element-type 'octet :adjustable t)
+                       for index = 0 then (+ index pos)
+                       for pos = (read-sequence buffer content-stream)
+                       do (adjust-array content (+ index pos))
+                          (replace content buffer :start1 index :end2 pos)
+                       while (= pos +buffer-length+)
+                       finally (return content)))))))
+
+(defmethod initialize-instance :after ((request request) &rest init-args)
+  "The only initarg for a REQUEST object is :HEADERS-IN.  All other
+slot values are computed in this :AFTER method."
+  (declare (ignore init-args))
+  (with-slots (headers-in cookies-in get-parameters post-parameters script-name query-string session)
+      request
+    (handler-case
+        (progn
+          (when (server-mod-lisp-p *server*)
+            ;; convert these two values to keywords
+            (let ((method-pair (assoc :method headers-in)))
+              (setf (cdr method-pair) (make-keyword (cdr method-pair))))
+            (let ((protocol-pair (assoc :server-protocol headers-in)))
+              (setf (cdr protocol-pair) (make-keyword (cdr protocol-pair))))
+            ;; and convert these two values to integers
+            (let ((remote-ip-port-pair (assoc :remote-ip-port headers-in)))
+              (setf (cdr remote-ip-port-pair) (parse-integer (cdr remote-ip-port-pair)
+                                                             :junk-allowed t)))
+            (let ((server-ip-port-pair (assoc :server-ip-port headers-in)))
+              (setf (cdr server-ip-port-pair) (parse-integer (cdr server-ip-port-pair)
+                                                             :junk-allowed t))))
+          ;; compute SCRIPT-NAME and QUERY-STRING slots from
+          ;; REQUEST_URI environment variable
+          (let* ((uri (request-uri request))
+                 (match-start (position #\? uri)))
+            (cond
+             (match-start
+              (setq script-name (subseq uri 0 match-start)
+                    query-string (subseq uri (1+ match-start))))
+             (t (setq script-name uri))))
+          ;; some clients (e.g. ASDF-INSTALL) send requests like
+          ;; "GET http://server/foo.html HTTP/1.0"...
+          (setq script-name (regex-replace "^https?://[^/]+" script-name ""))
+          ;; compute GET parameters from query string and cookies from
+          ;; the incoming 'Cookie' header
+          (setq get-parameters
+                (form-url-encoded-list-to-alist (split "&" query-string))
+                cookies-in
+                (form-url-encoded-list-to-alist (split "\\s*[,;]\\s*" (cdr (assoc :cookie headers-in)))
+                                                +utf-8+)
+                session (session-verify request)
+                *session* session)
+          ;; if the content-type is 'application/x-www-form-urlencoded'
+          ;; or 'multipart/form-data', compute the post parameters from
+          ;; the content body
+          (when (member (request-method request) *methods-for-post-parameters* :test #'eq)
+            (when-let (content-type (cdr (assoc :content-type headers-in)))
+              (multiple-value-bind (type subtype external-format)
+                  (parse-content-type content-type t)
+                (setq post-parameters
+                      (cond ((and (string-equal type "application")
+                                  (string-equal subtype "x-www-form-urlencoded"))
+                             (unless (or (assoc :content-length headers-in)
+                                         (input-chunking-p))
+                               (error "Can't read request body because there's no~
+Content-Length header and input chunking is off."))
+                             (form-url-encoded-list-to-alist
+                              (split "&" (raw-post-data :request request
+                                                        ;; ASCII would suffice according to RFC...
+                                                        :external-format +latin-1+))
+                              external-format))
+                            ((and (string-equal type "multipart")
+                                  (string-equal subtype "form-data"))
+                             (setf (slot-value request 'raw-post-data) t)                           
+                             (handler-case
+                                 (let* ((*request* request)
+                                        (content-stream (content-stream request))
+                                        (start (flexi-stream-position content-stream)))
+                                   (prog1
+                                       (parse-rfc2388-form-data content-stream content-type)
+                                     (let* ((end (flexi-stream-position content-stream))
+                                            (stray-data (get-post-data :already-read (- end start))))
+                                       (when (and stray-data (plusp (length stray-data)))
+                                         (warn "~A octets of stray data after form-data sent by client."
+                                               (length stray-data))))
+                                     (setf (slot-value request 'raw-post-data) t)))
+                               (error (msg)
+                                 (log-message :error
+                                              "While parsing multipart/form-data parameters: ~A"
+                                              msg)
+                                 nil)))))))))
+      (error (cond)
+        (log-message* "Error when creating REQUEST object: ~A" cond)
+        ;; we assume it's not our fault...
+        (setf (return-code) +http-bad-request+)))))
+
+(defun recompute-request-parameters (&key (request *request*)
+                                          (external-format *hunchentoot-default-external-format*))
+  "Recomputes the GET and POST parameters for the REQUEST object
+REQUEST.  This only makes sense if you're switching external formats
+during the request."
+  (with-slots (headers-in get-parameters post-parameters query-string)
+      request
+    (setq get-parameters
+          (form-url-encoded-list-to-alist (split "&" query-string) external-format)
+          post-parameters
+          (when-let (raw-post-data (raw-post-data :request request
+                                                  :external-format +latin-1+))
+            (and (when-let (content-type (cdr (assoc :content-type headers-in)))
+                   (multiple-value-bind (type subtype)
+                       (parse-content-type content-type)
+                     (and (string-equal type "application")
+                          (string-equal subtype "x-www-form-urlencoded"))))
+                 (form-url-encoded-list-to-alist (split "&" raw-post-data) external-format)))))
+  (values))
+                                                
+(defun script-name (&optional (request *request*))
+  "Returns the file name of the REQUEST object REQUEST. That's the
+requested URI without the query string \(i.e the GET parameters)."
+  (slot-value request 'script-name))
+
+(defun query-string (&optional (request *request*))
+  "Returns the query string of the REQUEST object REQUEST. That's
+the part behind the question mark \(i.e. the GET parameters)."
+  (slot-value request 'query-string))
+
+(defun get-parameters (&optional (request *request*))
+  "Returns an alist of the GET parameters associated with the REQUEST
+object REQUEST."
+  (slot-value request 'get-parameters))
+
+(defun post-parameters (&optional (request *request*))
+  "Returns an alist of the POST parameters associated with the REQUEST
+object REQUEST."
+  (slot-value request 'post-parameters))
+
+(defun headers-in (&optional (request *request*))
+  "Returns an alist of the incoming headers associated with the
+REQUEST object REQUEST."
+  (slot-value request 'headers-in))
+
+(defun cookies-in (&optional (request *request*))
+  "Returns an alist of all cookies associated with the REQUEST object
+REQUEST."
+  (slot-value request 'cookies-in))
+
+(defun header-in (name &optional (request *request*))
+  "Returns the incoming header with name NAME.  NAME can be a keyword
+\(recommended) or a string."
+  (cdr (assoc name (headers-in request))))
+
+(defun authorization (&optional (request *request*))
+  "Returns as two values the user and password \(if any) as encoded in
+the 'AUTHORIZATION' header.  Returns NIL if there is no such header."
+  (let* ((authorization (header-in :authorization request))
+         (start (and authorization
+                     (> (length authorization) 5)
+                     (string-equal "Basic" authorization :end2 5)
+                     (scan "\\S" authorization :start 5))))
+    (when start
+      (destructuring-bind (&optional user password)
+          (split ":" (base64:base64-string-to-string (subseq authorization start)))
+        (values user password)))))
+
+(defun remote-addr (&optional (request *request*))
+  "Returns the address the current request originated from."
+  (cond ((server-mod-lisp-p *server*) (header-in :remote-ip-addr request))
+        (t *remote-host*)))
+
+(defun real-remote-addr (&optional (request *request*))
+  "Returns the 'X-Forwarded-For' incoming http header as the
+second value in the form of a list of IP addresses and the first
+element of this list as the first value if this header exists.
+Otherwise returns the value of REMOTE-ADDR as the only value."
+  (let ((x-forwarded-for (header-in :x-forwarded-for request)))
+    (cond (x-forwarded-for (let ((addresses (split "\\s*,\\s*" x-forwarded-for)))
+                             (values (first addresses) addresses)))
+          (t (remote-addr request)))))
+
+(defun server-addr (&optional (request *request*))
+  "Returns the address at which the current request arrived."
+  (cond ((server-mod-lisp-p *server*) (header-in :server-ip-addr request))
+        (t *local-host*)))
+
+(defun remote-port (&optional (request *request*))
+  "Returns the port the current request originated from."
+  (cond ((server-mod-lisp-p *server*) (header-in :remote-ip-port request))
+        (t *remote-port*)))
+
+(defun server-port (&optional (request *request*))
+  "Returns the port at which the current request arrived."
+  (cond ((server-mod-lisp-p *server*) (header-in :server-ip-port request))
+        (t (server-local-port *server*))))
+
+(defun host (&optional (request *request*))
+  "Returns the 'Host' incoming http header value."
+  (header-in :host request))
+
+(defun request-uri (&optional (request *request*))
+  "Returns the request URI."
+  (cond ((server-mod-lisp-p *server*) (header-in :url request))
+        (t (slot-value request 'uri))))
+
+(defun request-method (&optional (request *request*))
+  "Returns the request method as a Lisp keyword."
+  (cond ((server-mod-lisp-p *server*) (header-in :method request))
+        (t (slot-value request 'method))))
+
+(defun server-protocol (&optional (request *request*))
+  "Returns the request protocol as a Lisp keyword."
+  (cond ((server-mod-lisp-p *server*) (header-in :server-protocol request))
+        (t (slot-value request 'server-protocol))))
+
+(defun mod-lisp-id (&optional (request *request*))
+  "Returns the 'Server ID' sent by mod_lisp.  This value is set in
+Apache's server configuration file and is of course only available if
+mod_lisp is the front-end."
+  (and (or (server-mod-lisp-p *server*)
+           (warn "Calling MOD-LISP-ID although ~S is a stand-alone server."
+                 *server*))
+       (header-in :server-id request)))
+
+(defun ssl-session-id (&optional (request *request*))
+  "Returns the 'SSL_SESSION_ID' header sent my mod_lisp and is of
+course only available if mod_lisp is the front-end."
+  (and (or (server-mod-lisp-p *server*)           
+           (warn "Calling SSL-SESSION-ID although ~S is a stand-alone server."
+                 *server*))
+       (header-in :ssl-session-id request)))
+
+(defun user-agent (&optional (request *request*))
+  "Returns the 'User-Agent' http header."
+  (header-in :user-agent request))
+
+(defun cookie-in (name &optional (request *request*))
+  "Returns the cookie with the name NAME \(a string) as sent by the
+browser - or NIL if there is none."
+  (cdr (assoc name (cookies-in request) :test #'string=)))
+
+(defun referer (&optional (request *request*))
+  "Returns the 'Referer' \(sic!) http header."
+  (header-in :referer request))
+
+(defun get-parameter (name &optional (request *request*))
+  "Returns the GET parameter with name NAME \(a string) - or NIL if
+there is none.  Search is case-sensitive."
+  (cdr (assoc name (get-parameters request) :test #'string=)))
+
+(defun post-parameter (name &optional (request *request*))
+  "Returns the POST parameter with name NAME \(a string) - or NIL if
+there is none.  Search is case-sensitive."
+  (cdr (assoc name (post-parameters request) :test #'string=)))
+
+(defun parameter (name &optional (request *request*))
+  "Returns the GET or the POST parameter with name NAME \(a string) -
+or NIL if there is none.  If both a GET and a POST parameter with the
+same name exist the GET parameter is returned.  Search is
+case-sensitive."
+  (or (get-parameter name request)
+      (post-parameter name request)))
+
+(defun handle-if-modified-since (time &optional (request *request*))
+  "Handles the 'If-Modified-Since' header of REQUEST.  The date string
+is compared to the one generated from the supplied universal time
+TIME."
+  (let ((if-modified-since (header-in :if-modified-since request))
+        (time-string (rfc-1123-date time)))
+    ;; simple string comparison is sufficient; see RFC 2616 14.25
+    (when (and if-modified-since
+               (equal if-modified-since time-string))
+      (setf (return-code) +http-not-modified+)
+      (throw 'handler-done nil))
+    (values)))
+
+(defun raw-post-data (&key (request *request*) external-format force-binary force-text want-stream)
+  "Returns the content sent by the client if there was any \(unless
+the content type was \"multipart/form-data\").  By default, the result
+is a string if the type of the `Content-Type' media type is \"text\",
+and a vector of octets otherwise.  In the case of a string, the
+external format to be used to decode the content will be determined
+from the `charset' parameter sent by the client \(or otherwise
+*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT* will be used).
+
+You can also provide an external format explicitly \(through
+EXTERNAL-FORMAT) in which case the result will unconditionally be a
+string.  Likewise, you can provide a true value for FORCE-TEXT which
+will force Hunchentoot to act as if the type of the media type had
+been \"text\".  Or you can provide a true value for FORCE-BINARY which
+means that you want a vector of octets at any rate.
+
+If, however, you provide a true value for WANT-STREAM, the other
+parameters are ignored and you'll get the content \(flexi) stream to
+read from it yourself.  It is then your responsibility to read the
+correct amount of data, because otherwise you won't be able to return
+a response to the client.  If the content type of the request was
+`multipart/form-data' or `application/x-www-form-urlencoded', the
+content has been read by Hunchentoot already and you can't read from
+the stream anymore.
+
+You can call RAW-POST-DATA more than once per request, but you can't
+mix calls which have different values for WANT-STREAM.
+
+Note that this function is slightly misnamed because a client can send
+content even if the request method is not POST."
+  (when (and force-binary force-text)
+    (error "It doesn't make sense to set both FORCE-BINARY and FORCE-TEXT to a true value."))
+  (unless (or external-format force-binary)
+    (setq external-format
+          (when-let (content-type (cdr (assoc :content-type (headers-in request))))
+            (nth-value 2 (parse-content-type content-type force-text)))))
+  (let ((raw-post-data (or (slot-value request 'raw-post-data)
+                           (get-post-data :request request :want-stream want-stream))))
+    (cond ((typep raw-post-data 'stream) raw-post-data)
+          ((member raw-post-data '(t nil)) nil)
+          (external-format (octets-to-string raw-post-data :external-format external-format))
+          (t raw-post-data))))
+
+(defun aux-request-value (symbol &optional (request *request*))
+  "Returns the value associated with SYMBOL from the request object
+REQUEST \(the default is the current request) if it exists.  The
+second return value is true if such a value was found."
+  (when request
+    (let ((found (assoc symbol (aux-data request))))
+      (values (cdr found) found))))
+
+(defsetf aux-request-value (symbol &optional request)
+    (new-value)
+  "Sets the value associated with SYMBOL from the request object
+REQUEST \(default is *REQUEST*).  If there is already a value
+associated with SYMBOL it will be replaced."
+  (with-rebinding (symbol)
+    (with-unique-names (place %request)
+      `(let* ((,%request (or ,request *request*))
+              (,place (assoc ,symbol (aux-data ,%request))))
+         (cond
+           (,place
+            (setf (cdr ,place) ,new-value))
+           (t
+            (push (cons ,symbol ,new-value)
+                  (aux-data ,%request))
+            ,new-value))))))
+
+(defun delete-aux-request-value (symbol &optional (request *request*))
+  "Removes the value associated with SYMBOL from the request object
+REQUEST."
+  (when request
+    (setf (aux-data request)
+            (delete symbol (aux-data request)
+                    :key #'car :test #'eq)))
+  (values))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/server.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,440 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/server.lisp,v 1.38 2007/11/03 21:46:19 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defclass server ()
+  ((socket :accessor server-socket
+           :documentation "The socket the server is listening on.")
+   (port :initarg :port
+         :reader server-local-port
+         :documentation "The port the server is listening on.
+See START-SERVER.")
+   (address :initarg :address
+            :reader server-address
+            :documentation "The address the server is listening
+on.  See START-SERVER.")
+   (name :initarg :name
+         :accessor server-name
+         :documentation "The optional name of the server, a symbol.")
+   (dispatch-table :initarg :dispatch-table
+                   :accessor server-dispatch-table
+                   :documentation "The dispatch-table used by this
+server.  Can be NIL to denote that *META-DISPATCHER* should be called
+instead.")
+   (output-chunking-p :initarg :output-chunking-p
+                      :reader server-output-chunking-p
+                      :documentation "Whether the server may use output chunking.")
+   (input-chunking-p :initarg :input-chunking-p
+                     :reader server-input-chunking-p
+                     :documentation "Whether the server may use input chunking.")
+   (read-timeout :initarg :read-timeout
+                 :reader server-read-timeout
+                 :documentation "The read-timeout of the server.")
+   (write-timeout :initarg :write-timeout
+                  :reader server-write-timeout
+                  :documentation "The write-timeout of the server.")
+   (listener :accessor server-listener
+             :documentation "The Lisp process which listens for
+incoming requests and starts new worker threads for each new
+connection.")
+   (workers :initform nil
+            :accessor server-workers
+            :documentation "A list of currently active worker threads.")
+   (mod-lisp-p :initform nil
+               :initarg :mod-lisp-p
+               :reader server-mod-lisp-p
+               :documentation "Whether this is a genuine
+Hunchentoot server or \"just\" infrastructure for mod_lisp.")
+   (use-apache-log-p :initarg :use-apache-log-p
+                     :reader server-use-apache-log-p
+                     :documentation "Whether the server should use
+Apache's log file.  Only applicable if MOD-LISP-P is true.")
+   #-:hunchentoot-no-ssl
+   (ssl-certificate-file :initarg :ssl-certificate-file
+                         :reader server-ssl-certificate-file
+                         :documentation "The namestring of a
+certificate file if SSL is used, NIL otherwise.")
+   #-:hunchentoot-no-ssl
+   (ssl-privatekey-file :initarg :ssl-privatekey-file
+                        :reader server-ssl-privatekey-file
+                        :documentation "The namestring of a
+private key file if SSL is used, NIL otherwise.")
+   #-:hunchentoot-no-ssl
+   (ssl-privatekey-password :initarg :ssl-privatekey-password
+                            :reader server-ssl-privatekey-password
+                            :documentation "The password for the
+private key file or NIL.")
+   (lock :initform (make-lock (format nil "hunchentoot-lock-~A"
+                                      *server-counter*))
+         :reader server-lock
+         :documentation "A lock which is used to make sure that
+we can shutdown the server cleanly."))
+  (:documentation "An object of this class contains all relevant
+information about a running Hunchentoot server instance."))
+
+(defun start-server (&key (port 80 port-provided-p)
+                          address
+                          dispatch-table
+                          (name (gensym))
+                          (mod-lisp-p nil)
+                          (use-apache-log-p mod-lisp-p)
+                          (input-chunking-p t)
+                          (read-timeout *default-read-timeout*)
+                          (write-timeout *default-write-timeout*)
+                          #+(and :unix (not :win32)) setuid
+                          #+(and :unix (not :win32)) setgid
+                          #-:hunchentoot-no-ssl ssl-certificate-file
+                          #-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file)
+                          #-:hunchentoot-no-ssl ssl-privatekey-password)
+  "Starts a Hunchentoot server and returns the SERVER object \(which
+can be stopped with STOP-SERVER).  PORT is the port the server will be
+listening on - the default is 80 \(or 443 if SSL information is
+provided).  If ADDRESS is a string denoting an IP address, then the
+server only receives connections for that address.  This must be one
+of the addresses associated with the machine and allowed values are
+host names such as \"www.nowhere.com\" and address strings like
+\"204.71.177.75\".  If ADDRESS is NIL, then the server will receive
+connections to all IP addresses on the machine.  This is the default.
+
+DISPATCH-TABLE can either be a dispatch table which is to be used by
+this server or NIL which means that at request time *META-DISPATCHER*
+will be called to retrieve a dispatch table.
+
+NAME should be a symbol which can be used to name the server.  This
+name can utilized when defining \"easy handlers\" - see
+DEFINE-EASY-HANDLER.  The default name is an uninterned symbol as
+returned by GENSYM.
+
+If MOD-LISP-P is true, the server will act as a back-end for mod_lisp,
+otherwise it will be a stand-alone web server.  If USE-APACHE-LOG-P is
+true, log messages will be written to the Apache log file - this
+parameter has no effect if MOD-LISP-P is NIL.
+
+If INPUT-CHUNKING-P is true, the server will accept request bodies
+without a `Content-Length' header if the client uses chunked transfer
+encoding.  If you want to use this feature together with mod_lisp, you
+should make sure that your combination of Apache and mod_lisp can do
+that - see:
+
+  <http://common-lisp.net/pipermail/mod-lisp-devel/2006-December/000104.html>.
+
+On LispWorks 5.0 or higher and AllegroCL, READ-TIMEOUT and
+WRITE-TIMEOUT are the read and write timeouts \(in seconds) of
+the server - use NIL for no timeout at all.  (See the LispWorks
+documentation for STREAM:SOCKET-STREAM for details.)  On
+LispWorks 4.4.6 or lower, SBCL, and CMUCL WRITE-TIMEOUT is
+ignored.  On OpenMCL both parameters are ignored.
+
+On Unix you can use SETUID and SETGID to change the UID and GID of the
+process directly after the server has been started.  \(You might want
+to do this if you're using a privileged port like 80.)  SETUID and
+SETGID can be integers \(the actual IDs) or strings \(for the user and
+group name respectively).
+
+If you want your server to use SSL you must provide the pathname
+designator\(s) SSL-CERTIFICATE-FILE for the certificate file and
+optionally SSL-PRIVATEKEY-FILE for the private key file, both files
+must be in PEM format.  If you only provide the value for
+SSL-CERTIFICATE-FILE it is assumed that both the certificate and the
+private key are in one file.  If your private key needs a password you
+can provide it through the SSL-PRIVATEKEY-PASSWORD keyword argument,
+but this works only on LispWorks - for other Lisps the key must not be
+associated with a password."
+  (declare (ignorable port-provided-p))
+  ;; initialize the session secret if needed
+  (unless (boundp '*session-secret*)
+    (reset-session-secret))
+  (let ((output-chunking-p t))
+    #-:hunchentoot-no-ssl
+    (when ssl-certificate-file
+      ;; disable output chunking for SSL connections
+      (setq output-chunking-p nil)
+      (unless port-provided-p (setq port 443)))
+    ;; no timeouts if behind mod_lisp
+    (when mod-lisp-p
+      (setq read-timeout nil
+            write-timeout nil))
+    ;; use a new process/lock name for each server
+    (atomic-incf *server-counter*)
+    ;; create the SERVER object
+    (let ((server (make-instance 'server
+                                 :port port
+                                 :address address
+                                 :name name
+                                 :dispatch-table dispatch-table
+                                 :output-chunking-p (and output-chunking-p (not mod-lisp-p))
+                                 :input-chunking-p input-chunking-p
+                                 #-:hunchentoot-no-ssl :ssl-certificate-file
+                                 #-:hunchentoot-no-ssl(and ssl-certificate-file
+                                                           (namestring ssl-certificate-file))
+                                 #-:hunchentoot-no-ssl :ssl-privatekey-file
+                                 #-:hunchentoot-no-ssl (and ssl-privatekey-file
+                                                            (namestring ssl-privatekey-file))
+                                 #-:hunchentoot-no-ssl :ssl-privatekey-password
+                                 #-:hunchentoot-no-ssl ssl-privatekey-password
+                                 :mod-lisp-p mod-lisp-p
+                                 :use-apache-log-p (and mod-lisp-p use-apache-log-p)
+                                 :read-timeout read-timeout
+                                 :write-timeout write-timeout)))
+      (multiple-value-bind (process condition)
+          ;; start up the actual server
+          (start-up-server :service port
+                           :address address
+                           :process-name (format nil "hunchentoot-listener-~A" *server-counter*)
+                           ;; this function is called once on
+                           ;; startup - we use it to record the
+                           ;; socket
+                           :announce (lambda (socket &optional condition)
+                                       (cond (socket
+                                              (setf (server-socket server) socket))
+                                             (condition
+                                              (error condition))))
+                           ;; this function is called whenever a
+                           ;; connection is made
+                           :function (lambda (handle)
+                                       (with-lock ((server-lock server))
+                                         (incf *worker-counter*)
+                                         ;; check if we need to
+                                         ;; perform a global GC
+                                         (when (and *cleanup-interval*
+                                                    (zerop (mod *worker-counter* *cleanup-interval*)))
+                                           (when *cleanup-function*
+                                             (funcall *cleanup-function*)))
+                                         ;; start a worker thread
+                                         ;; for this connection
+                                         ;; and remember it
+                                         (push (process-run-function (format nil "hunchentoot-worker-~A"
+                                                                             *worker-counter*)
+                                                                     #'process-connection
+                                                                     server handle)
+                                               (server-workers server))))
+                           ;; wait until the server was
+                           ;; successfully started or an error
+                           ;; condition is returned
+                           :wait t)
+        (cond (process
+               ;; remember the listener so we can kill it later
+               (setf (server-listener server) process))
+              (condition
+               (error condition))))
+      #+(and :unix (not :win32))
+      (when setgid
+        ;; we must make sure to call setgid before we call setuid or
+        ;; suddenly we aren't root anymore...
+        (etypecase setgid
+          (integer (setgid setgid))
+          (string (setgid (get-gid-from-name setgid)))))
+      #+(and :unix (not :win32))
+      (when setuid
+        (etypecase setuid
+          (integer (setuid setuid))
+          (string (setuid (get-uid-from-name setuid)))))
+      server)))
+
+(defun stop-server (server)
+  "Stops the Hunchentoot server SERVER."
+  ;; use lock so that the listener can't start new workers
+  (with-lock ((server-lock server))
+    ;; kill all worker threads
+    (dolist (worker (server-workers server))
+      (ignore-errors (process-kill worker))
+      (process-allow-scheduling))
+    ;; finally, kill main listener
+    (when-let (listener (server-listener server))
+      (process-kill listener)))
+  (values))
+
+(defun process-connection (server handle)
+  "This function is called by the server in a newly-created thread
+with the SERVER object itself and a socket 'handle' from which a
+stream can be created.  It reads the request headers and hands over to
+PROCESS-REQUEST.  This is done in a loop until the stream has to be
+closed or until a read timeout occurs."
+  (handler-bind ((error
+                  ;; abort if there's an error which isn't caught inside
+                  (lambda (cond)
+                    (log-message *lisp-errors-log-level*
+                                 "Error while processing connection: ~A" cond)                    
+                    (return-from process-connection)))
+                 (warning
+                  ;; log all warnings which aren't caught inside
+                  (lambda (cond)
+                    (log-message *lisp-warnings-log-level*
+                                 "Warning while processing connection: ~A" cond))))
+    (with-debugger
+      (let (*hunchentoot-stream* *local-host* *remote-host* *remote-port*)
+        (unwind-protect
+            ;; bind important special variables
+            (let ((*server* server))
+              ;; create binary stream from socket handle
+              (multiple-value-setq (*hunchentoot-stream* *local-host* *remote-host* *remote-port*)
+                  (make-socket-stream handle
+                                      (server-read-timeout server)
+                                      (server-write-timeout server)))
+              ;; attach SSL to the stream if necessary
+              #-:hunchentoot-no-ssl
+              (when (server-ssl-certificate-file server)
+                #+:lispworks
+                (make-ssl-server-stream *hunchentoot-stream*
+                                        :certificate-file (server-ssl-certificate-file server)
+                                        :privatekey-file (server-ssl-privatekey-file server)
+                                        :privatekey-password (server-ssl-privatekey-password server))
+                #-:lispworks
+                (setq *hunchentoot-stream*
+                        (cl+ssl:make-ssl-server-stream *hunchentoot-stream*
+                                                       :certificate (server-ssl-certificate-file server)
+                                                       :key (server-ssl-privatekey-file server))))
+              ;; wrap with chunking-enabled stream if necessary
+              (when (or (server-input-chunking-p server)
+                        (server-output-chunking-p server))
+                (setq *hunchentoot-stream* (make-chunked-stream *hunchentoot-stream*)))
+              ;; now wrap with flexi stream with "faithful" external format
+              (setq *hunchentoot-stream*
+                    (make-flexi-stream *hunchentoot-stream* :external-format +latin-1+))
+              ;; loop until we have to close the stream - as
+              ;; determined by *CLOSE-HUNCHENTOOT-STREAM*
+              (unwind-protect                  
+                  (loop
+                   (let ((*close-hunchentoot-stream* t))
+                     ;; reset to "faithful" format on each iteration
+                     ;; and reset bound of stream as well
+                     (setf (flexi-stream-external-format *hunchentoot-stream*) +latin-1+
+                           (flexi-stream-bound *hunchentoot-stream*) nil)
+                     (multiple-value-bind (headers-in content-stream method url-string server-protocol)
+                         (get-request-data)
+                       (unless (and ;; check if there was a request at all
+                                    (cond ((server-mod-lisp-p server) headers-in)
+                                          (t method))
+                                    (prog1
+                                        (process-request headers-in content-stream method
+                                                         url-string server-protocol)
+                                      ;; always turn chunking off at this point
+                                      (when (or (server-input-chunking-p server)
+                                                (server-output-chunking-p server))
+                                        (setf (chunked-stream-output-chunking-p
+                                               (flexi-stream-stream *hunchentoot-stream*)) nil
+                                              (chunked-stream-input-chunking-p
+                                               (flexi-stream-stream *hunchentoot-stream*)) nil))
+                                      (force-output* *hunchentoot-stream*))
+                                    ;; continue until we have to close
+                                    ;; the stream
+                                    (not *close-hunchentoot-stream*))
+                         (return)))))
+                (ignore-errors (force-output* *hunchentoot-stream*))))
+          (when *hunchentoot-stream*
+            (ignore-errors (close *hunchentoot-stream* :abort t)))
+          (ignore-errors
+            (with-lock ((server-lock server))
+              ;; remove this worker from the list of all workers
+              (setf (server-workers server)
+                    (delete *current-process* (server-workers server))))))))))
+
+(defun process-request (headers-in content-stream method url-string server-protocol)
+  "This function is called by PROCESS-CONNECTION after the incoming
+headers have been read.  It sets up the REQUEST and REPLY objects,
+dispatches to a handler, and finally sends the output to the client
+using START-OUTPUT.  If all goes as planned, the function returns T."
+  (let (*tmp-files* *headers-sent*)
+    (unwind-protect
+        (progn
+          (when (server-input-chunking-p *server*)
+            (let ((transfer-encodings (cdr (assoc :transfer-encoding headers-in))))
+              (when transfer-encodings
+                (setq transfer-encodings
+                      (split "\\s*,\\*" transfer-encodings)))
+              (when (member "chunked" transfer-encodings :test #'equalp)
+                ;; turn chunking on before we read the request body
+                (setf (chunked-stream-input-chunking-p 
+                       (flexi-stream-stream *hunchentoot-stream*)) t))))
+          (let* ((*session* nil)
+                 ;; first create a REPLY object so we can immediately start
+                 ;; logging \(in case we're logging to mod_lisp)
+                 (*reply* (make-instance 'reply))
+                 (*request* (make-instance 'request
+                                           :headers-in headers-in
+                                           :content-stream content-stream
+                                           :method method
+                                           :uri url-string
+                                           :server-protocol server-protocol))
+                 (*dispatch-table* (or (server-dispatch-table *server*)
+                                       (funcall *meta-dispatcher* *server*)))
+                 backtrace)
+            (multiple-value-bind (body error)
+                (catch 'handler-done
+                  (handler-bind ((error
+                                  (lambda (cond)
+                                    ;; only generate backtrace if needed
+                                    (setq backtrace
+                                          (and (or (and *show-lisp-errors-p*
+                                                        *show-lisp-backtraces-p*)
+                                                   (and *log-lisp-errors-p*
+                                                        *log-lisp-backtraces-p*))
+                                               (get-backtrace cond)))
+                                    (when *log-lisp-errors-p*
+                                      (log-message *lisp-errors-log-level*
+                                                   "~A~:[~*~;~%~A~]"
+                                                   cond
+                                                   *log-lisp-backtraces-p*
+                                                   backtrace))
+                                    ;; if the headers were already sent
+                                    ;; the error happens within the body
+                                    ;; and we have to close the stream
+                                    (when *headers-sent*
+                                      (setq *close-hunchentoot-stream* t))
+                                    (throw 'handler-done
+                                           (values nil cond))))
+                                 (warning
+                                  (lambda (cond)
+                                    (when *log-lisp-warnings-p*
+                                      (log-message *lisp-warnings-log-level*
+                                                   "~A~:[~*~;~%~A~]"
+                                                   cond
+                                                   *log-lisp-backtraces-p*
+                                                   backtrace)))))
+                    (with-debugger 
+                      ;; skip dispatch if bad request
+                      (when (eq (return-code) +http-ok+)
+                        ;; now do the work
+                        (dispatch-request *dispatch-table*)))))
+              (when error
+                (setf (return-code *reply*)
+                      +http-internal-server-error+))
+              (start-output (cond ((and error *show-lisp-errors-p*)
+                                   (format nil "<pre>~A~:[~*~;~%~%~A~]</pre>"
+                                           (escape-for-html (format nil "~A" error))
+                                           *show-lisp-backtraces-p*
+                                           (escape-for-html (format nil "~A" backtrace))))
+                                  (error
+                                   "An error has occured")
+                                  (t body))))
+            t))
+      (dolist (path *tmp-files*)
+        (when (and (pathnamep path) (probe-file path))
+          (ignore-errors (delete-file path)))))))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/session.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,286 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/session.lisp,v 1.11 2007/06/04 19:24:12 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(let ((session-id-counter 0))
+  (defun get-next-session-id ()
+    "Returns the next sequential session id."
+    (incf session-id-counter)))
+
+(let ((global-session-usage-counter 0))
+  (defun count-session-usage ()
+    "Counts session usage globally and triggers session gc if necessary." 
+    (when (and *session-gc-frequency*
+               (zerop (mod (incf global-session-usage-counter)
+                           *session-gc-frequency*)))
+      (session-gc))))
+
+
+(defclass session ()
+  ((session-id :initform (get-next-session-id)
+               :reader session-id
+               :type integer
+               :documentation "The unique ID \(an INTEGER) of the session.")
+   (session-string :reader session-string
+                   :documentation "The session strings encodes enough
+data to safely retrieve this session. It is sent to the browser as a
+cookie value or as a GET parameter.")
+   (user-agent :initform (user-agent *request*)
+               :reader session-user-agent
+               :documentation "The incoming 'User-Agent' header that
+was sent when this session was created.")
+   (remote-addr :initform (real-remote-addr *request*)
+              :reader session-remote-addr
+              :documentation "The remote IP address of the client when
+this sessions was started as returned by REAL-REMOTE-ADDR.")
+   (session-start :initform (get-universal-time)
+                  :reader session-start
+                  :documentation "The time this session was started.")
+   (last-click :initform (get-universal-time)
+               :reader session-last-click
+               :documentation "The last time this session was used.")
+   (session-data :initarg :session-data
+                 :initform nil
+                 :reader session-data
+                 :documentation "Data associated with this session -
+see SESSION-VALUE.")
+   (session-counter :initform 0
+                    :reader session-counter
+                    :documentation "The number of times this session
+has been used.")
+   (max-time :initarg :max-time
+             :initform *session-max-time*
+             :accessor session-max-time
+             :type fixnum
+             :documentation "The time \(in seconds) after which this
+session expires if it's not used."))
+  (:documentation "SESSION objects are automatically maintained
+by Hunchentoot. They should not be created explicitly with
+MAKE-INSTANCE but implicitly with START-SESSION. Note that
+SESSION objects can only be created when the special variable
+*REQUEST* is bound to a REQUEST object."))
+
+(defun encode-session-string (id user-agent remote-addr start)
+  "Create a uniquely encoded session string based on the values ID,
+USER-AGENT, REMOTE-ADDR, and START"
+  ;; *SESSION-SECRET* is used twice due to known theoretical
+  ;; vulnerabilities of MD5 encoding
+  (md5-hex (concatenate 'string
+			*session-secret*
+			(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
+                                         *session-secret*
+                                         id
+                                         (and *use-user-agent-for-sessions*
+                                              user-agent)
+                                         (and *use-remote-addr-for-sessions*
+                                              remote-addr)
+                                         start)))))
+
+(defun stringify-session (session)
+  "Creates a string representing the SESSION object SESSION. See
+ENCODE-SESSION-STRING."
+  (encode-session-string (session-id session)
+                         (session-user-agent session)
+                         (session-remote-addr session)
+                         (session-start session)))
+
+(defmethod initialize-instance :after ((session session) &rest init-args)
+  "Set SESSION-STRING slot after the session has been initialized."
+  (declare (ignore init-args))
+  (setf (slot-value session 'session-string) (stringify-session session)))
+
+(defun session-gc ()
+  "Removes sessions from *session-data* which are too old - see
+SESSION-TOO-OLD-P."
+  (with-lock (*session-data-lock*)
+    (setq *session-data*
+            (loop for id-session-pair in *session-data*
+                  for (nil . session) = id-session-pair
+                  when (session-too-old-p session)
+                    do (funcall *session-removal-hook* session)
+                  else
+                    collect id-session-pair)))
+  (values))
+
+(defun session-value (symbol &optional (session *session*))
+  "Returns the value associated with SYMBOL from the session object
+SESSION \(the default is the current session) if it exists."
+  (when session
+    (let ((found (assoc symbol (session-data session))))
+      (values (cdr found) found))))
+
+(defsetf session-value (symbol &optional session)
+    (new-value)
+  "Sets the value associated with SYMBOL from the session object
+SESSION. If there is already a value associated with SYMBOL it will be
+replaced. Will automatically start a session if none was supplied and
+there's no session for the current request."
+  (with-rebinding (symbol)
+    (with-unique-names (place %session)
+      `(with-lock (*session-data-lock*)
+         (let* ((,%session (or ,session (start-session)))
+                (,place (assoc ,symbol (session-data ,%session))))
+           (cond
+             (,place
+              (setf (cdr ,place) ,new-value))
+             (t
+              (push (cons ,symbol ,new-value)
+                    (slot-value ,%session 'session-data))
+              ,new-value)))))))
+
+(defun delete-session-value (symbol &optional (session *session*))
+  "Removes the value associated with SYMBOL from the current session
+object if there is one."
+  (when session
+    (setf (slot-value session 'session-data)
+            (delete symbol (session-data session)
+                    :key #'car :test #'eq)))
+  (values))
+
+(defun session-cookie-value (&optional (session (session *request*)))
+  "Returns a string which can be used to safely restore the
+session if as session has already been established. This is used
+as the value stored in the session cookie or in the corresponding
+GET parameter."
+  (and session
+       (format nil
+               "~A:~A"
+               (session-id session)
+               (session-string session))))
+
+(defun start-session ()
+  "Returns the current SESSION object. If there is no current session,
+creates one and updates the corresponding data structures. In this
+case the function will also send a session cookie to the browser."
+  (count-session-usage)
+  (let ((session (session *request*)))
+    (when session
+      (return-from start-session session))
+    (setf session (make-instance 'session)
+          (session *request*) session)
+    (with-lock (*session-data-lock*)
+      (setq *session-data* (acons (session-id session) session *session-data*)))
+    (set-cookie *session-cookie-name*
+                :value (session-cookie-value session)
+                :path "/")
+    (setq *session* session)))
+
+(defun remove-session (session)
+  "Completely removes the SESSION object SESSION from Hunchentoot's
+internal session database."
+  (with-lock (*session-data-lock*)
+    (funcall *session-removal-hook* session)
+    (setq *session-data*
+            (delete (session-id session) *session-data*
+                    :key #'car :test #'=)))
+  (values))
+
+(defun session-too-old-p (session)
+  "Returns true if the SESSION object SESSION has not been active in
+the last \(SESSION-MAX-TIME SESSION) seconds."
+  (< (+ (session-last-click session) (session-max-time session))
+     (get-universal-time)))
+
+(defun get-stored-session (id)
+  "Returns the SESSION object corresponding to the number ID if the
+session has not expired. Will remove the session if it has expired but
+will not create a new one."
+  (let ((session
+          (cdr (assoc id *session-data* :test #'=))))
+    (when (and session
+               (session-too-old-p session))
+      (when *reply*
+        (log-message :notice "Session with ID ~A too old" id))
+      (remove-session session)
+      (setq session nil))
+    session))
+
+(defun session-verify (request)
+  "Tries to get a session identifier from the cookies \(or
+alternatively from the GET parameters) sent by the client. This
+identifier is then checked for validity against the REQUEST object
+REQUEST. On success the corresponding session object \(if not too old)
+is returned \(and updated). Otherwise NIL is returned."
+  (let ((session-identifier (or (cookie-in *session-cookie-name* request)
+                                (get-parameter *session-cookie-name* request))))
+    (unless (and session-identifier
+                 (stringp session-identifier)
+                 (plusp (length session-identifier)))
+      (return-from session-verify nil))
+    (destructuring-bind (id-string session-string)
+        (split ":" session-identifier :limit 2)
+      (let* ((id (and (scan "^\\d+$" id-string)
+                      (parse-integer id-string
+                                     :junk-allowed t)))
+             (session (and id
+                           (get-stored-session id)))
+             (user-agent (user-agent request))
+             (remote-addr (remote-addr request)))
+        (unless (and session
+                     session-string
+                     (string= session-string
+                              (session-string session))
+                     (string= session-string
+                              (encode-session-string id
+                                                     user-agent
+                                                     (real-remote-addr request)
+                                                     (session-start session))))
+          (when *reply*
+            (cond ((null session)
+                    (log-message :notice "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
+                                 session-identifier user-agent remote-addr))
+                  (t
+                    (log-message :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
+                                 session-identifier user-agent remote-addr))))
+          (when session
+            (remove-session session))
+          (return-from session-verify nil))
+        (incf (slot-value session 'session-counter))
+        (setf (slot-value session 'last-click) (get-universal-time))
+        session))))
+
+(defun reset-sessions ()
+  "Removes ALL stored sessions and creates a new session secret."
+  (reset-session-secret)
+  (with-lock (*session-data-lock*)
+    (loop for (nil . session) in *session-data*
+          do (funcall *session-removal-hook* session))
+    (setq *session-data* nil))
+  (values))
+
+(defmacro do-sessions ((var &optional result-form) &body body)
+  "Executes BODY with VAR bound to each existing SESSION object
+consecutively. Returns the values returned by RESULT-FORM unless
+RETURN is executed. The scope of the binding of VAR does not include
+RESULT-FORM."
+  (let ((=temp= (gensym)))
+    `(dolist (,=temp= *session-data* ,result-form)
+      (let ((,var (cdr ,=temp=)))
+        , at body))))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/specials.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,385 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/specials.lisp,v 1.31 2007/11/08 20:07:58 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+  (defmacro defvar-unbound (name &optional (doc-string ""))
+    "Convenience macro to declare unbound special variables with a
+documentation string."
+    `(progn
+      (defvar ,name)
+      (setf (documentation ',name 'variable) ,doc-string)))
+
+  (defvar *http-reason-phrase-map* (make-hash-table)
+    "Used to map numerical return codes to reason phrases.")
+  
+  (defmacro def-http-return-code (name value reason-phrase)
+    "Shortcut to define constants for return codes.  NAME is a
+Lisp symbol, VALUE is the numerical value of the return code, and
+REASON-PHRASE is the phrase \(a string) to be shown in the
+server's status line."
+    `(eval-when (:compile-toplevel :execute :load-toplevel)
+       (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'."
+                                          value reason-phrase))
+       (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase))))
+
+(defconstant +crlf+ #.(format nil "~C~C" #\Return #\Linefeed)
+  "A constant string consisting of the two ASCII characters CR and LF.")
+
+(def-http-return-code +http-continue+ 100 "Continue")
+(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols")
+(def-http-return-code +http-ok+ 200 "OK")
+(def-http-return-code +http-created+ 201 "Created")
+(def-http-return-code +http-accepted+ 202 "Accepted")
+(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information")
+(def-http-return-code +http-no-content+ 204 "No Content")
+(def-http-return-code +http-reset-content+ 205 "Reset Content")
+(def-http-return-code +http-partial-content+ 206 "Partial Content")
+(def-http-return-code +http-multi-status+ 207 "Multi-Status")
+(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices")
+(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently")
+(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily")
+(def-http-return-code +http-see-other+ 303 "See Other")
+(def-http-return-code +http-not-modified+ 304 "Not Modified")
+(def-http-return-code +http-use-proxy+ 305 "Use Proxy")
+(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect")
+(def-http-return-code +http-bad-request+ 400 "Bad Request")
+(def-http-return-code +http-authorization-required+ 401 "Authorization Required")
+(def-http-return-code +http-payment-required+ 402  "Payment Required")
+(def-http-return-code +http-forbidden+ 403 "Forbidden")
+(def-http-return-code +http-not-found+ 404 "Not Found")
+(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed")
+(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable")
+(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required")
+(def-http-return-code +http-request-time-out+ 408 "Request Time-out")
+(def-http-return-code +http-conflict+ 409 "Conflict")
+(def-http-return-code +http-gone+ 410 "Gone")
+(def-http-return-code +http-length-required+ 411 "Length Required")
+(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed")
+(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large")
+(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large")
+(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type")
+(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable")
+(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed")
+(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency")
+(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error")
+(def-http-return-code +http-not-implemented+ 501 "Not Implemented")
+(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway")
+(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable")
+(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out")
+(def-http-return-code +http-version-not-supported+ 505 "Version not supported")
+
+(defvar *approved-return-codes* '(#.+http-ok+ #.+http-no-content+
+                                              #.+http-multi-status+
+                                              #.+http-not-modified+)
+  "A list of return codes the server should not treat as an error -
+see *HANDLE-HTTP-ERRORS-P*.")
+
+(defconstant +day-names+
+  #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
+  "The three-character names of the seven days of the week - needed
+for cookie date format.")
+
+(defconstant +month-names+
+  #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+  "The three-character names of the twelve months - needed for cookie
+date format.")
+
+(defvar *session-cookie-name* "hunchentoot-session"
+  "The name of the cookie \(or the GET parameter) which is used to
+store the session on the client side.")
+
+(defvar *rewrite-for-session-urls* t
+  "Whether HTML pages should possibly be rewritten for cookie-less
+session-management.")
+
+(defvar *content-types-for-url-rewrite*
+  '("text/html" "application/xhtml+xml")
+  "The content types for which url-rewriting is OK. See
+*REWRITE-FOR-SESSION-URLS*.")
+
+(defparameter *the-random-state* (make-random-state t)
+  "A fresh random state.")
+
+(defvar-unbound *session-secret*
+  "A random value that's used to encode the public session data.")
+
+(defvar-unbound *hunchentoot-stream*
+  "The stream representing the socket Hunchentoot is listening on.")
+
+(defvar *close-hunchentoot-stream* nil
+  "Will be set to T if the Hunchentoot socket stream has to be
+closed at the end of the request.")
+
+(defvar *headers-sent* nil
+  "Used internally to check whether the reply headers have
+already been sent for this request.")
+
+(defvar *file-upload-hook* nil
+  "If this is not NIL, it should be a unary function which will
+be called with a pathname for each file which is uploaded to
+Hunchentoot.  The pathname denotes the temporary file to which
+the uploaded file is written.  The hook is called directly before
+the file is created.")
+
+(defvar *session-data* nil
+  "All sessions of all users currently using Hunchentoot.  An
+alist where the car is the session's ID and the cdr is the
+SESSION object itself.")
+
+(defvar *session-max-time* #.(* 30 60)
+  "The default time \(in seconds) after which a session times out.")
+
+(defvar *session-gc-frequency* 50
+  "A session GC \(see function SESSION-GC) will happen every
+*SESSION-GC-FREQUENCY* requests \(counting only requests which
+use a session) if this variable is not NIL.")
+
+(defvar *use-user-agent-for-sessions* t
+  "Whether the 'User-Agent' header should be encoded into the session
+string.  If this value is true, a session will cease to be accessible
+if the client sends a different 'User-Agent' header.")
+
+(defvar *use-remote-addr-for-sessions* nil
+  "Whether the client's remote IP \(as returned by REAL-REMOTE-ADDR)
+should be encoded into the session string.  If this value is true, a
+session will cease to be accessible if the client's remote IP changes.
+
+This might for example be an issue if the client uses a proxy server
+which doesn't send correct 'X_FORWARDED_FOR' headers.")
+
+(defvar *default-content-type* "text/html; charset=iso-8859-1"
+  "The default content-type header which is returned to the client.")
+
+(defvar *methods-for-post-parameters* '(:post)
+  "A list of the request method types \(as keywords) for which
+Hunchentoot will try to compute POST-PARAMETERS.")
+
+(defvar *header-stream* nil
+  "If this variable is not NIL, it should be bound to a stream to
+which incoming and outgoing headers will be written for debugging
+purposes.")
+
+(defvar *show-lisp-errors-p* nil
+  "Whether Lisp errors should be shown in HTML output.")
+
+(defvar *show-lisp-backtraces-p* nil
+  "Whether Lisp backtraces should be shown in HTML output when an
+error occurs.  Will only have an effect if *SHOW-LISP-ERRORS-P* is
+also true.")
+
+(defvar *log-lisp-errors-p* t
+  "Whether Lisp errors should be logged.")
+
+(defvar *log-lisp-warnings-p* t
+  "Whether Lisp warnings should be logged.")
+
+(defvar *log-lisp-backtraces-p* nil
+  "Whether Lisp backtraces should be logged when an error or warning
+occurs.  Will only have an effect if *LOG-LISP-ERRORS-P* or
+*LOG-LISP-BACKTRACES* are also true.")
+
+(defvar *lisp-errors-log-level* :error
+  "Log level for Lisp errors.")
+
+(defvar *lisp-warnings-log-level* :warning
+  "Log level for Lisp warnings.")
+
+(defvar *show-access-log-messages* t
+  "Whether routine messages about each request should be logged.  This
+will only be done if SERVER-USE-APACHE-LOG-P is NIL.")
+
+(defvar *log-file*
+    (load-time-value
+      (let ((tmp-dir
+              #+:allegro (system:temporary-directory)
+              #+:lispworks (pathname (or (lw:environment-variable "TEMP")
+                                         (lw:environment-variable "TMP")
+                                         #+:win32 "C:/"
+                                         #-:win32 "/tmp/"))
+              #-(or :allegro :lispworks) #p"/tmp/"))
+        (merge-pathnames "hunchentoot.log" tmp-dir)))
+  "The log file to use \(unless the Apache log is used).")
+
+(defvar *log-file-stream* nil
+  "The stream corresponding to the log file.")
+
+(defvar *log-file-lock* (make-lock "log-file-lock")
+  "A lock to prevent two threads from writing to the log file at
+same time.")
+  
+(defvar-unbound *session*
+  "The current SESSION object.")
+
+(defvar-unbound *request*
+  "The current REQUEST object.")
+
+(defvar-unbound *reply*
+  "The current REPLY object.")
+
+(defvar *log-prefix* t
+  "The prefix which is printed in front of Apache log
+messages. This should be a string or T \(for \"Hunchentoot\", the
+default) or NIL \(meaning no prefix).")
+
+(defconstant +implementation-link+
+  #+:cmu "http://www.cons.org/cmucl/"
+  #+:sbcl "http://www.sbcl.org/"
+  #+:allegro "http://www.franz.com/products/allegrocl/"
+  #+:lispworks "http://www.lispworks.com/"
+  #+:openmcl "http://openmcl.clozure.com/"
+  "A link to the website of the underlying Lisp implementation.")
+
+(defvar *dispatch-table* (list 'default-dispatcher)
+  "A list of dispatch functions - see *META-DISPATCHER*.")
+
+(defvar *default-handler* 'default-handler
+  "The name of the function which is always returned by
+DEFAULT-DISPATCHER.")
+
+(defvar *easy-handler-alist* nil
+  "An alist of \(URI server-names function) lists defined by
+DEFINE-EASY-HANDLER.")
+
+(defvar *http-error-handler* nil
+  "Contains NIL \(the default) or a function of one argument which is
+called if the content handler has set a return code which is not in
+*APPROVED-RETURN-CODES* and *HANDLE-HTTP-ERRORS* is true.")
+
+(defvar *handle-http-errors-p* t
+  "A generalized boolean that determines whether return codes which
+are not in *APPROVED-HEADERS* are treated specially.  When its value
+is true \(the default), either a default body for the return code or
+the result of calling *HTTP-ERROR-HANDLER* is used.  When the value is
+NIL, no special action is taken and you are expected to supply your
+own response body to describe the error.")
+
+(defvar *default-log-level* nil
+  "The default log level for LOG-MESSAGE*.")
+
+(defvar *session-data-lock* (make-lock "session-data-lock")
+  "A lock to prevent two threads from modifying *SESSION-DATA* at the
+same time.")
+
+(defvar *session-removal-hook* (constantly nil)
+  "A function of one argument \(a session object) which is called
+whenever a session is garbage-collected.")
+
+(defvar *tmp-directory*
+  #+(or :win32 :mswindows) "c:\\hunchentoot-temp\\"
+  #-(or :win32 :mswindows) "/tmp/hunchentoot/"
+  "Directory for temporary files created by MAKE-TMP-FILE-NAME.")
+
+(defvar *tmp-files* nil
+  "A list of temporary files created while a request was handled.")
+
+(defconstant +latin-1+
+  (make-external-format :latin1 :eol-style :lf)
+  "A FLEXI-STREAMS external format used for `faithful' input and
+output of binary data.")
+
+(defconstant +utf-8+
+  (make-external-format :utf8 :eol-style :lf)
+  "A FLEXI-STREAMS external format used internally for logging and to
+encode cookie values.")
+
+(defvar *hunchentoot-default-external-format* +latin-1+
+  "The external format used to compute the REQUEST object.")
+
+(defconstant +buffer-length+ 8192
+  "Length of buffers used for internal purposes.")
+
+(defvar-unbound *server*
+  "During the execution of dispatchers and handlers this variable
+is bound to the SERVER object which processes the request.")
+
+(defvar *meta-dispatcher* (lambda (server)
+                            (declare (ignore server))
+                            *dispatch-table*)
+  "The value of this variable should be a function of one argument.
+It is called with the current Hunchentoot server instance \(unless the
+server has its own dispatch table) and must return a suitable dispatch
+table.  The initial value is a function which always unconditionally
+returns *DISPATCH-TABLE*.")
+
+(defvar *server-counter* 0
+  "Internal counter used to generate meaningful names for
+listener threads.")
+
+(defvar *worker-counter* 0
+  "Internal counter used to generate meaningful names for worker
+threads.")
+
+(defvar *default-read-timeout* 20
+  "The default read-timeout used when a Hunchentoot server is
+reading from a socket stream.")
+
+(defvar *default-write-timeout* 20
+  "The default write-timeout used when a Hunchentoot server is
+writing to a socket stream.")
+
+(defvar *force-output-timeout* 30
+  "The maximal time Hunchentoot waits for FORCE-OUTPUT to
+return.")
+
+(defvar *cleanup-interval* 100
+  "Should be NIL or a positive integer.  The system calls
+*CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads have
+been created unless the value is NIL.")
+
+(defvar *cleanup-function* 'cleanup-function
+  "The function which is called if *CLEANUP-INTERVAL* is not NIL.")
+
+(defvar-unbound *local-host*
+  "Bound to a string denoting the address at which the current
+request arrived.")
+
+(defvar-unbound *remote-host*
+  "Bound to a string denoting the address the current request
+originated from.")
+
+(defvar-unbound *remote-port*
+  "Bound to an integer denoting the port the current request
+originated from.")
+
+(pushnew :hunchentoot *features*)
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+
+(defvar *hyperdoc-base-uri* "http://weitz.de/hunchentoot/")
+
+(let ((exported-symbols-alist
+       (loop for symbol being the external-symbols of :hunchentoot
+             collect (cons symbol (concatenate 'string "#" (string-downcase symbol))))))
+  (defun hyperdoc-lookup (symbol type)
+    (declare (ignore type))
+    (cdr (assoc symbol exported-symbols-alist :test #'eq))))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/UTF-8-demo.html	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,213 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+    <head><title>UTF-8 test file</title></head>
+    <body>
+    <p>Original by Markus Kuhn, adapted for HTML by Martin D&uuml;rst.</p>
+<pre>
+UTF-8 encoded sample plain-text file
+????????????????????????????????????????????????????????????????????????????????????????????????????????????
+
+Markus Kuhn [??ma??k??s ku??n] &lt;mkuhn at acm.org> ??? 1999-08-20
+
+
+The ASCII compatible UTF-8 encoding of ISO 10646 and Unicode
+plain-text files is defined in RFC 2279 and in ISO 10646-1 Annex R.
+
+
+Using Unicode/UTF-8, you can write in emails and source code things such as
+
+Mathematics and Sciences:
+
+  ??? E???da = Q,  n ??? ???, ??? f(i) = ??? g(i), ???x??????: ???x??? = ?????????x???, ?? ??? ???? = ??(???? ??? ??),
+
+  ??? ??? ?????? ??? ??? ??? ??? ??? ??? ??? ???, ??? &lt; a ??? b ??? c ??? d ??? ??? ??? (A ??? B),
+
+  2H??? + O??? ??? 2H???O, R = 4.7 k??, ??? 200 mm
+
+Linguistics and dictionaries:
+
+  ??i ??nt????n??????n??l f????n??t??k ??so??si??e????n
+  Y [????psil??n], Yen [j??n], Yoga [??jo??g??]
+
+APL:
+
+  ((V???V)=??????V)/V???,V    ????????????????????????????????????
+
+Nicer typography in plain text files:
+
+  ????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????
+  ???                                          ???
+  ???   ??? ???single??? and ???double??? quotes         ???
+  ???                                          ???
+  ???   ??? Curly apostrophes: ???We???ve been here??? ???
+  ???                                          ???
+  ???   ??? Latin-1 apostrophe and accents: '??`  ???
+  ???                                          ???
+  ???   ??? ???deutsche??? ???Anf??hrungszeichen???       ???
+  ???                                          ???
+  ???   ??? ???, ???, ???, ???, 3???4, ???, ???5/+5, ???, ???      ???
+  ???                                          ???
+  ???   ??? ASCII safety test: 1lI|, 0OD, 8B     ???
+  ???                      ?????????????????????????????????         ???
+  ???   ??? the euro symbol: ??? 14.95 ??? ???         ???
+  ???                      ?????????????????????????????????         ???
+  ????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????
+
+Greek (in Polytonic):
+
+  The Greek anthem:
+
+  ????? ??????????????? ???????? ??????? ?????????
+  ??????? ??????????????? ??????? ???????????????,
+  ????? ??????????????? ???????? ??????? ???????
+  ??????? ????? ??????? ??????????????? ????? ?????.
+
+  ?????????? ????? ??????????????? ?????????????????
+  ??????? ?????????????????? ????? ??????????
+  ??????? ??????? ??????????? ????????????????????????
+  ???????????, ??? ???????????, ??????????????????????!
+
+  From a speech of Demosthenes in the 4th century BC:
+
+  ?????????? ???????????? ?????????????????????? ?????? ?????????????????????, ??? ????????????? ????????????????????,
+  ????????? ????? ??????? ????? ????????????????? ?????????????????? ??????? ????????? ????????? ?????????
+  ????????????? ??????? ?????????????? ????????? ??????? ??????? ????????????? ????????? ???????
+  ????????????????????????? ????????????????? ???????? ???????????????????????, ????? ????? ?????????????????? 
+  ??????? ??????????? ???????????????????,  ?????????? ????????? ????? ???????????????????? ????????????
+  ????????????????? ??????????? ??????????????????? ?????????. ???????????? ??????? ????????? ?????? ?????????????????
+  ????? ????? ??????????????? ????????????????? ??? ??????? ??????????????????, ????????? ????? ???????????????????????,
+  ?????????? ??????? ??????????? ??????????????????????? ?????????? ??????????????????????. ???????? ?????, ??????? ???????
+  ????????? ?????????? ????? ??????????? ??????? ????? ???????????? ??????????? ???????????????? ??????? ?????????????????
+  ?????????????????????????, ??????? ?????????? ???????????????? ??????????? ???????? ?????????? ???????, ????? ???????????
+  ??????????????? ???????????? ???????????????????? ??????? ????????????? ??????????????????? ???????????? ??????????????
+  ??????????????????? ?????????? ??????????? ??????? ?????????????, ????????? ????????? ???????????????????
+  ???????????????. ???????? ??????? ??????????? ??????????????? ???????????????, ????????? ??????? ????????? ???????
+  ????????? ???????????????????????? ?????? ??????? ????? ????????????? ???????????????? ????????????????? ????????? ?????
+  ??????? ???????????? ???????????? ????????????????????, ??????????????? ???????????????? ????????? ???????
+  ????????????????? ?????????????????? ??????????????????? ???????????.
+
+  ???????????????????????, ????? ????????????????????????
+
+Georgian:
+
+  From a Unicode conference invitation:
+
+  ?????????????????? ?????????????????? ????????????????????? ????????????????????????????????? Unicode-?????? ??????????????? ????????????????????????????????????
+  ??????????????????????????????????????? ?????????????????????????????????, ????????????????????? ?????????????????????????????? 10-12 ???????????????,
+  ???. ?????????????????????, ??????????????????????????????. ????????????????????????????????? ???????????????????????? ??????????????? ????????????????????????
+  ?????????????????????????????? ???????????? ???????????????????????? ??????????????????????????? ??????????????????????????? ?????? Unicode-???,
+  ????????????????????????????????????????????????????????? ?????? ?????????????????????????????????, Unicode-?????? ??????????????????????????????
+  ??????????????????????????? ??????????????????????????????, ?????? ????????????????????????????????? ?????????????????????????????????, ???????????????????????????,
+  ??????????????????????????? ???????????????????????????????????? ?????? ???????????????????????????????????? ????????????????????????????????? ??????????????????????????????.
+
+Russian:
+
+  From a Unicode conference invitation:
+
+  ?????????????????????????????????? ???????????? ???? ?????????????? ?????????????????????????? ?????????????????????? ????
+  Unicode, ?????????????? ?????????????????? 10-12 ?????????? 1997 ???????? ?? ???????????? ?? ????????????????.
+  ?????????????????????? ?????????????? ?????????????? ???????? ?????????????????? ????  ???????????????? ??????????????????????
+  ?????????????????? ?? Unicode, ?????????????????????? ?? ??????????????????????????????????????, ???????????????????? ??
+  ???????????????????? Unicode ?? ?????????????????? ???????????????????????? ???????????????? ?? ??????????????????????
+  ??????????????????????, ??????????????, ?????????????? ?? ???????????????????????? ???????????????????????? ????????????????.
+
+Thai (UCS Level 2):
+
+  Excerpt from a poetry on The Romance of The Three Kingdoms (a Chinese
+  classic 'San Gua'):
+
+  [----------------------------|------------------------]
+    ??? ??????????????????????????????????????????????????????????????????????????????????????????  ???????????????????????????????????????????????????????????????????????????
+  ???????????????????????????????????????????????????????????????????????????????????????       ??????????????????????????????????????????????????????????????????????????????
+    ???????????????????????????????????????????????????????????????????????????           ????????????????????????????????????????????????????????????????????????????????????
+  ????????????????????????????????????????????????????????????????????????????????????         ?????????????????????????????????????????????????????????????????????
+    ???????????????????????????????????????????????????????????????????????????      ?????????????????????????????????????????????????????????????????????
+  ??????????????????????????????????????????????????????????????????????????????          ?????????????????????????????????????????????????????????????????????????????????
+    ???????????????????????????????????????????????????????????????????????????          ??????????????????????????????????????????????????????????????????????????????
+  ??????????????????????????????????????????????????????????????????           ????????????????????????????????????????????????????????????????????? ???
+
+  (The above is a two-column text. If combining characters are handled
+  correctly, the lines of the second column should be aligned with the
+  | character above.)
+
+Ethiopian:
+
+  Proverbs in the Amharic language:
+
+  ????????? ??????????????? ????????? ??????????????????
+  ?????? ????????? ?????????????????? ??????????????????
+  ?????? ???????????? ???????????? ?????????
+  ?????? ???????????? ?????? ???????????? ????????? ??????????????????
+  ????????? ???????????? ????????? ??????????????????
+  ????????? ????????? ?????? ????????????
+  ??????????????? ??????????????????
+  ?????? ???????????? ??????????????? ???????????? ???????????????
+  ?????? ???????????? ???????????? ????????????
+  ?????? ??????????????? ????????? ????????? ???????????? ????????????????????????
+  ???????????? ?????????????????? ????????? ??????????????? ??????????????????
+  ??????????????? ????????? ???????????? ????????? ???????????? ???????????????
+  ?????? ??????????????? ????????? ???????????????
+  ????????? ???????????? ???????????? ????????? ?????? ???????????????
+  ??????????????? ????????? ?????? ???????????? ????????? ????????????
+  ???????????? ????????? ???????????? ?????????
+  ???????????? ?????? ????????? ???????????? ??????????????????
+  ??????????????? ??????????????? ?????? ????????????
+
+Runes:
+
+  ?????? ???????????? ????????? ?????? ???????????? ?????? ????????? ??????????????? ????????????????????????????????? ????????? ?????? ????????????
+
+  (Old English, which transcribed into Latin reads 'He cwaeth that he
+  bude thaem lande northweardum with tha Westsae.' and means 'He said
+  that he lived in the northern land near the Western Sea.')
+
+Braille:
+
+  ???????????? ?????????  ????????????????????? ?????????
+
+  ??????????????? ????????? ??????????????? ?????? ???????????? ???????????? ????????? ?????? ?????? ????????????
+  ?????????????????? ???????????? ???????????? ?????? ?????????????????? ?????? ????????? ?????????????????? ?????????
+  ??????????????? ?????? ?????? ??????????????????????????? ?????? ??????????????? ?????? ???????????????????????????
+  ????????? ?????? ???????????? ?????????????????? ????????????????????? ??????????????? ????????? ?????????
+  ??????????????????????????? ???????????? ????????? ???????????? ???????????? ????????????????????? ????????? ?????????????????? ?????? 
+  ???????????? ?????? ????????? ????????? ???????????? ?????????
+
+  ????????? ??????????????? ????????? ?????? ???????????? ?????? ??? ??????????????????????????????
+
+  ???????????? ??? ??????????????? ???????????? ?????? ????????? ????????? ??? ???????????? ?????? ??????
+  ?????? ???????????????????????? ????????? ????????? ?????? ?????????????????????????????? ???????????? ????????????
+  ??? ?????????????????????????????? ??? ???????????? ???????????? ????????? ?????????????????? ????????????????????? ??????
+  ??????????????? ??? ?????????????????????????????? ?????? ?????? ?????????????????? ??????????????? ?????? ?????????????????????????????? 
+  ??? ?????? ?????????????????? ????????? ?????? ?????????????????? ?????? ?????? ???????????????????????? 
+  ?????? ??? ?????? ????????????????????? ????????? ?????? ???????????????????????? ???????????????
+  ???????????? ????????? ?????????????????? ????????? ?????? ?????? ???????????????????????? ???????????? ???????????? ??????
+  ???????????? ????????????????????? ??????????????? ?????? ?????? ????????????????????? ??????????????????????????????????????? ?????????
+  ??????????????? ????????? ?????? ???????????? ?????? ??? ??????????????????????????????
+
+  (The first couple of paragraphs of "A Christmas Carol" by Dickens)
+
+Compact font selection example text:
+
+  ABCDEFGHIJKLMNOPQRSTUVWXYZ /0123456789
+  abcdefghijklmnopqrstuvwxyz ??????????????????????
+  ???????????????????????????????????????????? ???????????????????? ????????????????????
+  ???????????????????????? ??????????????? ???????????????????????? ?????????????????????????????????????
+
+Greetings in various languages:
+
+  Hello world, ????????????????? ???????????, ???????????????
+
+Box drawing alignment tests:                                          ???
+                                                                      ???
+  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ????????????   ???  ??? ????????? ?????????    ??? ?????????????????????
+  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ????????????  ??????????????????????????? ?????????    ??? ?????????????????????
+  ????????? ?????????  ??????   ??????  ?????? ??? ??????  ?????? ??? ??????  ?????? ??? ??????  ????????????   ???  ??? ????????? ?????????    ??? ?????????????????????
+  ?????? ??? ??????  ??????   ??????  ?????????????????????  ?????????????????????  ?????????????????????  ????????????     ???????????? ??? ???????????? ??? ??? ?????????????????????
+  ????????? ?????????  ??????   ??????  ?????? ??? ??????  ?????? ??? ??????  ?????? ??? ??????  ???????????????????????? ???  ??? ??? ???  ??? ??? ???
+  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ???????????????????????? ???  ??? ??? ???  ??? ??? ???
+  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????  ?????????????????????           ???????????? ??? ???????????? ???  ????????????????????????
+
+</pre>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/favicon.ico
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/fz.jpg
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/packages.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,37 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/test/packages.lisp,v 1.4 2007/01/01 23:50:32 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :hunchentoot-test
+  (:nicknames :tbnl-test)
+  (:use :cl :cl-who :hunchentoot))
+  
+(defpackage :hunchentoot-test-user
+  (:use :cl :hunchentoot))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/test/test.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,584 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/test/test.lisp,v 1.21 2007/12/29 17:35:05 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot-test)
+
+(defvar *this-file* (load-time-value
+                     (or #.*compile-file-pathname* *load-pathname*)))
+
+(defmacro with-html (&body body)
+  `(with-html-output-to-string (*standard-output* nil :prologue t)
+     , at body))
+
+(defun hunchentoot-link ()
+  (with-html-output (*standard-output*)
+    (:a :href "http://weitz.de/hunchentoot/" "Hunchentoot")))
+
+(defun menu-link ()
+  (with-html-output (*standard-output*)
+    (:p (:hr
+         (:a :href "/hunchentoot/test" "Back to menu")))))
+
+(defmacro with-lisp-output ((var) &body body)
+  `(let ((*package* (find-package :hunchentoot-test-user)))
+     (with-output-to-string (,var #+:lispworks nil
+                                  #+:lispworks :element-type
+                                  #+:lispworks 'lw:simple-char)
+       , at body)))
+
+(defmacro info-table (&rest forms)
+  (let ((=value= (gensym))
+        (=first= (gensym)))
+    `(with-html-output (*standard-output*)
+       (:p (:table :border 1 :cellpadding 2 :cellspacing 0
+            (:tr (:td :colspan 2
+                  "Some Information "
+                  (hunchentoot-link)
+                  " provides about this request:"))
+            ,@(loop for form in forms
+                    collect `(:tr (:td :valign "top"
+                                   (:pre :style "padding: 0px"
+                                    (esc (with-lisp-output (s) (pprint ',form s)))))
+                              (:td :valign "top"
+                               (:pre :style "padding: 0px"
+                                (esc (with-lisp-output (s)
+                                       (loop for ,=value= in (multiple-value-list ,form)
+                                             for ,=first= = t then nil
+                                             unless ,=first=
+                                             do (princ ", " s)
+                                             do (pprint ,=value= s))))))))))
+       (menu-link))))
+
+(defun authorization-page ()
+  (multiple-value-bind (user password)
+      (authorization)
+    (cond ((and (equal user "nanook")
+                (equal password "igloo"))
+           (with-html
+             (:html
+              (:head (:title "Hunchentoot page with Basic Authentication"))
+              (:body
+               (:h2 (hunchentoot-link)
+                " page with Basic Authentication")
+               (info-table (header-in "Authorization")
+                           (authorization))))))
+          (t
+           (require-authorization)))))
+
+(defparameter *test-image*
+  (load-time-value
+   (with-open-file (in (make-pathname :name "fz" :type "jpg" :version nil
+                                      :defaults *this-file*)
+                       :element-type 'flex:octet)
+     (let ((image-data (make-array (file-length in)
+                                   :element-type 'flex:octet)))
+       (read-sequence image-data in)
+       image-data))))
+
+(defun image-ram-page ()
+  (setf (content-type)
+          "image/jpeg")
+  *test-image*)
+
+(let ((count 0))
+  (defun info ()
+    (with-html
+      (:html
+       (:head (:title "Hunchentoot Information"))
+       (:body
+        (:h2 (hunchentoot-link) " Information Page")
+        (:p "This page has been called "
+         (:b
+          (fmt "~[~;once~;twice~:;~:*~R times~]" (incf count)))
+         " since its handler was compiled.")
+        (info-table (host)
+                    (server-address *server*)
+                    (server-addr)
+                    (server-port)
+                    (remote-addr)
+                    (remote-port)
+                    (real-remote-addr)
+                    (request-method)
+                    (script-name)
+                    (query-string)
+                    (get-parameters)
+                    (headers-in)
+                    (cookies-in)
+                    (user-agent)
+                    (referer)
+                    (request-uri)
+                    (server-protocol)
+                    (mod-lisp-id)
+                    (ssl-session-id)))))))
+
+(defun oops ()
+  (with-html
+    (dotimes (i 3)
+      (log-message* "Oops (default) # ~a" i))
+    (log-message :emerg "Oops emergency")
+    (log-message :alert "Oops alert")
+    (log-message :crit "Oops critical")
+    (log-message :error "Oops error")
+    (log-message :warning "Oops warning")
+    (log-message :notice "Oops notice")
+    (log-message :info "Oops info")
+    (log-message :debug "Oops debug")
+    (error "An error was triggered on purpose. Check your ~
+Apache error log. Up to 12 messages where logged depending on ~
+the Apache log level set in httpd.conf.")
+    (:html
+     (:body "You'll never see this sentence..."))))
+
+(defun redir ()
+  (redirect "/hunchentoot/test/info.html?redirected=1"))
+
+(defun forbidden ()
+  (setf (return-code *reply*) +http-forbidden+)
+  nil)
+
+(defun cookie-test ()
+  (set-cookie "pumpkin" :value "barking")
+  (no-cache)
+  (with-html
+    (:html
+     (:head (:title "Hunchentoot cookie test"))
+     (:body
+      (:h2 (hunchentoot-link)
+       " cookie test")
+      (:p "You might have to reload this page to see the cookie value.")
+      (info-table (cookie-in "pumpkin")
+                  (mapcar #'car (cookies-in)))))))
+
+(defun session-test ()
+  (let ((new-foo-value (post-parameter "new-foo-value")))
+    (when new-foo-value
+      (setf (session-value 'foo) new-foo-value)))
+  (let ((new-bar-value (post-parameter "new-bar-value")))
+    (when new-bar-value
+      (setf (session-value 'bar) new-bar-value)))
+  (no-cache)
+  (with-html
+    (:html
+     (:head (:title "Hunchentoot session test"))
+     (:body
+      (:h2 (hunchentoot-link)
+       " session test")
+      (:p "Use the forms below to set new values for "
+       (:code "FOO")
+       " or "
+       (:code "BAR")
+       ". You can later return to this page to check if
+they're still set. Also, try to use another browser at the same
+time or try with cookies disabled.")
+      (:p (:form :method :post
+           "New value for "
+           (:code "FOO")
+           ": "
+           (:input :type :text
+            :name "new-foo-value"
+            :value (or (session-value 'foo) ""))))
+      (:p (:form :method :post
+           "New value for "
+           (:code "BAR")
+           ": "
+           (:input :type :text
+            :name "new-bar-value"
+            :value (or (session-value 'bar) ""))))
+      (info-table *session-cookie-name*
+                  (cookie-in *session-cookie-name*)
+                  (mapcar #'car (cookies-in))
+                  (session-value 'foo)
+                  (session-value 'bar))))))
+
+(defun parameter-test (&key (method :get) (charset :iso-8859-1))
+  (no-cache)
+  (recompute-request-parameters :external-format
+                                (flex:make-external-format charset :eol-style :lf))
+  (setf (content-type)
+        (format nil "text/html; charset=~A" charset))
+  (with-html
+    (:html
+     (:head (:title (fmt "Hunchentoot ~A parameter test" method)))
+     (:body
+      (:h2 (hunchentoot-link)
+       (fmt " ~A parameter test with charset ~A" method charset))
+      (:p "Enter some non-ASCII characters in the input field below
+and see what's happening.")
+      (:p (:form
+           :method method
+           "Enter a value: "
+           (:input :type :text
+            :name "foo")))
+      (case method
+        (:get (info-table (query-string)
+                          (map 'list #'char-code (get-parameter "foo"))
+                          (get-parameter "foo")))
+        (:post (info-table (raw-post-data)
+                           (map 'list #'char-code (post-parameter "foo"))
+                           (post-parameter "foo"))))))))
+
+(defun parameter-test-latin1-get ()
+  (parameter-test :method :get :charset :iso-8859-1))
+
+(defun parameter-test-latin1-post ()
+  (parameter-test :method :post :charset :iso-8859-1))
+
+(defun parameter-test-utf8-get ()
+  (parameter-test :method :get :charset :utf-8))
+
+(defun parameter-test-utf8-post ()
+  (parameter-test :method :post :charset :utf-8))
+
+;; this should not be the same directory as *TMP-DIRECTORY* and it
+;; should be initially empty (or non-existent)
+(defvar *tmp-test-directory*
+    #+(or :win32 :mswindows) #p"c:\\hunchentoot-temp\\test\\"
+    #-(or :win32 :mswindows) #p"/tmp/hunchentoot/test/")
+
+(defvar *tmp-test-files* nil)
+
+(let ((counter 0))
+  (defun handle-file (post-parameter)
+    (when (and post-parameter
+               (listp post-parameter))
+      (destructuring-bind (path file-name content-type)
+          post-parameter
+        (let ((new-path (make-pathname :name (format nil "hunchentoot-test-~A"
+                                                     (incf counter))
+                                       :type nil
+                                       :defaults *tmp-test-directory*)))
+          ;; strip directory info sent by Windows browsers
+          (when (search "Windows" (user-agent) :test #'char-equal)
+            (setq file-name (cl-ppcre:regex-replace ".*\\\\" file-name "")))
+          (rename-file path (ensure-directories-exist new-path))
+          (push (list new-path file-name content-type) *tmp-test-files*))))))
+
+(defun clean-tmp-dir ()
+  (loop for (path . nil) in *tmp-test-files*
+        when (probe-file path)
+        do (ignore-errors (delete-file path)))
+  (setq *tmp-test-files* nil))
+
+(defun upload-test ()
+  (let (post-parameter-p)
+    (when (post-parameter "file1")
+      (handle-file (post-parameter "file1"))
+      (setq post-parameter-p t))
+    (when (post-parameter "file2")
+      (handle-file (post-parameter "file2"))
+      (setq post-parameter-p t))
+    (when (post-parameter "clean")
+      (clean-tmp-dir)
+      (setq post-parameter-p t))
+    (when post-parameter-p
+      ;; redirect so user can safely use 'Back' button
+      (redirect (script-name))))
+  (no-cache)
+  (with-html
+    (:html
+     (:head (:title "Hunchentoot file upload test"))
+     (:body
+      (:h2 (hunchentoot-link)
+       " file upload test")
+      (:form :method :post :enctype "multipart/form-data"
+       (:p "First file: "
+        (:input :type :file
+         :name "file1"))
+       (:p "Second file: "
+        (:input :type :file
+         :name "file2"))
+       (:p (:input :type :submit)))
+      (when *tmp-test-files*
+        (htm
+         (:p
+          (:table :border 1 :cellpadding 2 :cellspacing 0
+           (:tr (:td :colspan 3 (:b "Uploaded files")))
+           (loop for (path file-name nil) in *tmp-test-files*
+                 for counter from 1
+                 do (htm
+                     (:tr (:td :align "right" (str counter))
+                      (:td (:a :href (format nil "files/~A?path=~A"
+                                             (url-encode file-name)
+                                             (url-encode (namestring path)))
+                            (esc file-name)))
+                      (:td :align "right"
+                       (str (ignore-errors
+                              (with-open-file (in path)
+                                (file-length in))))
+                       "&nbsp;Bytes"))))))
+         (:form :method :post
+          (:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
+      (menu-link)))))
+
+(defun send-file ()
+  (let* ((path (get-parameter "path"))
+         (file-info (and path
+                         (find (pathname path) *tmp-test-files*
+                               :key #'first :test #'equal))))
+    (unless file-info
+      (setf (return-code *reply*)
+            +http-not-found+)
+      (return-from send-file))
+    (handle-static-file path (third file-info))))
+
+(defparameter *headline*
+  (load-time-value              
+   (format nil "Hunchentoot test menu (see file <code>~A</code>)"
+           (merge-pathnames (make-pathname :type "lisp") *this-file*))))
+
+(defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf))
+
+(defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*)
+  "Demo file stolen from <http://www.w3.org/2001/06/utf-8-test/>.")
+
+(defun stream-direct ()
+  (setf (content-type) "text/html; charset=utf-8")
+  (let ((stream (send-headers))
+        (buffer (make-array 1024 :element-type 'flex:octet)))
+    #+:clisp
+    (setf (flex:flexi-stream-element-type stream) 'flex:octet)
+    (with-open-file (in *utf-8-file*
+                        :element-type 'flex:octet)
+      (loop for pos = (read-sequence buffer in)
+            until (zerop pos) 
+            do (write-sequence buffer stream :end pos)))))
+
+(defun stream-direct-utf-8 ()
+  (setf (content-type) "text/html; charset=utf-8")
+  (let ((stream (send-headers)))
+    (setf (flex:flexi-stream-external-format stream) *utf-8*)
+    (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
+                        :element-type 'flex:octet)
+      (setq in (flex:make-flexi-stream in :external-format *utf-8*))
+      (loop for line = (read-line in nil nil)
+            while line
+            do (write-line line stream)))))
+
+(defun stream-direct-utf-8-string ()
+  (setf (content-type) "text/html; charset=utf-8"
+        (reply-external-format) *utf-8*)
+  (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
+                      :element-type 'flex:octet)
+    (let ((string (make-array (file-length in)
+                              :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char
+                              :fill-pointer t)))
+      (setf in (flex:make-flexi-stream in :external-format *utf-8*)
+            (fill-pointer string) (read-sequence string in))
+      string)))
+
+(define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html"
+                                :default-request-type :post)
+    (first-name last-name
+                (age :parameter-type 'integer)
+                (implementation :parameter-type 'keyword)
+                (meal :parameter-type '(hash-table boolean))
+                (team :parameter-type 'list))
+  (with-html
+    (:html
+     (:head (:title "Hunchentoot \"easy\" handler example"))
+     (:body
+      (:h2 (hunchentoot-link)
+       " \"Easy\" handler example")
+      (:p (:form :method :post
+           (:table :border 1 :cellpadding 2 :cellspacing 0
+            (:tr
+             (:td "First Name:")
+             (:td (:input :type :text
+                   :name "first-name"
+                   :value (or first-name "Donald"))))
+            (:tr
+             (:td "Last name:")
+             (:td (:input :type :text
+                   :name "last-name"
+                   :value (or last-name "Duck"))))
+            (:tr
+             (:td "Age:")
+             (:td (:input :type :text
+                   :name "age"
+                   :value (or age 42))))
+            (:tr
+             (:td "Implementation:")
+             (:td (:select :name "implementation"
+                   (loop for (value option) in '((:lispworks "LispWorks")
+                                                 (:allegro "AllegroCL")
+                                                 (:cmu "CMUCL")
+                                                 (:sbcl "SBCL")
+                                                 (:openmcl "OpenMCL"))
+                         do (htm
+                             (:option :value value
+                              :selected (eq value implementation)
+                              (str option)))))))
+            (:tr
+             (:td :valign :top "Meal:")
+             (:td (loop for choice in '("Burnt weeny sandwich"
+                                        "Canard du jour"
+                                        "Easy meat"
+                                        "Muffin"
+                                        "Twenty small cigars"
+                                        "Yellow snow")
+                        do (htm
+                            (:input :type "checkbox"
+                             :name (format nil "meal{~A}" choice)
+                             :checked (gethash choice meal)
+                             (esc choice))
+                            (:br)))))
+            (:tr
+             (:td :valign :top "Team:")
+             (:td (loop for player in '("Beckenbauer"
+                                        "Cruyff"
+                                        "Maradona"
+                                        ;; without accent (for SBCL)
+                                        "Pele"
+                                        "Zidane")
+                        do (htm
+                            (:input :type "checkbox"
+                             :name "team"
+                             :value player
+                             :checked (member player team :test #'string=)
+                             (esc player))
+                            (:br)))))
+            (:tr
+             (:td :colspan 2
+              (:input :type "submit"))))))
+      (info-table first-name
+                  last-name
+                  age
+                  implementation
+                  (loop :for choice :being :the :hash-keys :of meal :collect choice)
+                  (gethash "Yellow snow" meal)
+                  team)))))
+                
+
+(defun menu ()
+  (with-html
+    (:html
+     (:head
+      (:link :rel "shortcut icon"
+       :href "/hunchentoot/test/favicon.ico" :type "image/x-icon")
+      (:title "Hunchentoot test menu"))
+     (:body
+      (:h2 (str *headline*))
+      (:table :border 0 :cellspacing 4 :cellpadding 4
+       (:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar"
+                  "Info provided by Hunchentoot")))
+       (:tr (:td (:a :href "/hunchentoot/test/cookie.html"
+                  "Cookie test")))
+       (:tr (:td (:a :href "/hunchentoot/test/session.html"
+                  "Session test")))
+       (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html"
+                  "GET parameter handling with LATIN-1 charset")))
+       (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html"
+                  "POST parameter handling with LATIN-1 charset")))
+       (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html"
+                  "GET parameter handling with UTF-8 charset")))
+       (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html"
+                  "POST parameter handling with UTF-8 charset")))
+       (:tr (:td (:a :href "/hunchentoot/test/redir.html"
+                  "Redirect \(302) to info page above")))
+       (:tr (:td (:a :href "/hunchentoot/test/authorization.html"
+                  "Authorization")
+             " (user 'nanook', password 'igloo')"))
+       (:tr (:td (:a :href "/hunchentoot/code/test.lisp"
+                  "The source code of this test")))
+       (:tr (:td (:a :href "/hunchentoot/test/image.jpg"
+                  "Binary data, delivered from file")
+             " \(a picture)"))
+       (:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg"
+                  "Binary data, delivered from RAM")
+             " \(same picture)"))
+       (:tr (:td (:a :href "/hunchentoot/test/easy-demo.html"
+                  "\"Easy\" handler example")))
+       (:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt"
+                  "UTF-8 demo")
+             " \(writing octets directly to the stream)"))
+       (:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt"
+                  "UTF-8 demo")
+             " \(writing UTF-8 characters directly to the stream)"))
+       (:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt"
+                  "UTF-8 demo")
+             " \(returning a string)"))
+       (:tr (:td (:a :href "/hunchentoot/test/upload.html"
+                  "File uploads")))
+       (:tr (:td (:a :href "/hunchentoot/test/forbidden.html"
+                  "Forbidden \(403) page")))
+       (:tr (:td (:a :href "/hunchentoot/test/oops.html"
+                  "Error handling")
+             " \(output depends on settings like "
+             (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*"
+              (:code "*SHOW-LISP-ERRORS-P*"))
+             (fmt " \(currently ~S) and " *show-lisp-errors-p*)
+             (:a :href "http://weitz.de/hunchentoot/#*show-lisp-backtraces-p*"
+              (:code "*SHOW-LISP-BACKTRACES-P*"))
+             (fmt " \(currently ~S)" *show-lisp-backtraces-p*)
+             ")"))
+       (:tr (:td (:a :href "/hunchentoot/foo"
+                  "URI handled by")
+             " "
+             (:a :href "http://weitz.de/hunchentoot/#*default-handler*"
+              (:code "*DEFAULT-HANDLER*")))))))))
+
+(setq *dispatch-table*
+      (nconc
+       (list 'dispatch-easy-handlers
+             (create-static-file-dispatcher-and-handler
+              "/hunchentoot/test/image.jpg"
+              (make-pathname :name "fz" :type "jpg" :version nil
+                             :defaults *this-file*)
+              "image/jpeg")
+             (create-static-file-dispatcher-and-handler
+              "/hunchentoot/test/favicon.ico"
+              (make-pathname :name "favicon" :type "ico" :version nil
+                             :defaults *this-file*))
+             (create-folder-dispatcher-and-handler
+              "/hunchentoot/code/"
+              (make-pathname :name nil :type nil :version nil
+                             :defaults *this-file*)
+              "text/plain"))
+       (mapcar (lambda (args)
+                 (apply #'create-prefix-dispatcher args))
+               '(("/hunchentoot/test/form-test.html" form-test)
+                 ("/hunchentoot/test/forbidden.html" forbidden)
+                 ("/hunchentoot/test/info.html" info)
+                 ("/hunchentoot/test/authorization.html" authorization-page)
+                 ("/hunchentoot/test/image-ram.jpg" image-ram-page)
+                 ("/hunchentoot/test/cookie.html" cookie-test)
+                 ("/hunchentoot/test/session.html" session-test)
+                 ("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get)
+                 ("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post)
+                 ("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get)
+                 ("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post)
+                 ("/hunchentoot/test/upload.html" upload-test)
+                 ("/hunchentoot/test/redir.html" redir)
+                 ("/hunchentoot/test/oops.html" oops)
+                 ("/hunchentoot/test/utf8-binary.txt" stream-direct)
+                 ("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8)
+                 ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string)
+                 ("/hunchentoot/test/files/" send-file)
+                 ("/hunchentoot/test" menu)))
+       (list #'default-dispatcher)))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-acl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,53 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-acl.lisp,v 1.5 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "osi"))
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (excl.osi:setuid uid))
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (excl.osi:setgid gid))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (excl.osi:pwent-uid  (or (excl.osi:getpwnam name)
+                           (error "User ~S not found." name))))
+
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (excl.osi:grent-gid (or (excl.osi:getgrnam name)
+                          (error "Group ~S not found." name))))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-clisp.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,51 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10; -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-clisp.lisp,v 1.1 2007/12/29 17:35:01 edi Exp $
+
+;;; Copyright (c) 2006, Lu?s Oliveira <loliveira at common-lisp.net>.
+;;; Copyright (c) 2007, Anton Vodonosov <avodonosov at yandex.ru>.
+;;; Copyright (c) 2007, Dr. Edmund Weitz.
+;;; All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (setf (posix:getuid) uid))
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (setf (posix:getgid) gid))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (posix:user-info-uid (posix:user-info name)))
+
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (posix:user-info-gid (posix:user-info name)))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-cmu.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,54 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-cmu.lisp,v 1.5 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (multiple-value-bind (return-value errno)
+      (unix:unix-setuid uid)
+    (unless (and return-value (zerop return-value))
+      (error "setuid failed: ~A" (unix:get-unix-error-msg errno)))))
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (multiple-value-bind (return-value errno)
+      (unix:unix-setgid gid)
+    (unless (and return-value (zerop return-value))
+      (error "setgid failed: ~A" (unix:get-unix-error-msg errno)))))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (unix:user-info-uid (unix:unix-getpwnam name)))
+
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (unix:group-info-gid (unix:unix-getgrnam name)))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-lw.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,93 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-lw.lisp,v 1.4 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(fli:define-foreign-function (%setuid "setuid")
+    ((uid :int))
+  :result-type :int)
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (unless (zerop (%setuid uid))
+    (error "setuid failed: ~A" (lw:get-unix-error (lw:errno-value)))))
+
+(fli:define-foreign-function (%setgid "setgid")
+    ((gid :int))
+  :result-type :int)
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (unless (zerop (%setgid gid))
+    (error "setgid failed: ~A" (lw:get-unix-error (lw:errno-value)))))
+
+(fli:define-c-struct passwd
+  (name (:pointer :char))
+  (passwd (:pointer :char))
+  (uid :int)
+  (gid :int)
+  (gecos (:pointer :char))
+  (dir (:pointer :char))
+  (shell (:pointer :char)))
+
+(fli:define-foreign-function (getpwnam "getpwnam")
+    ((name (:reference-pass :ef-mb-string)))
+  :result-type (:pointer passwd))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (let ((passwd (getpwnam name)))
+    (when (fli:null-pointer-p passwd)
+      (let ((errno (lw:errno-value)))
+        (cond ((zerop errno)
+               (error "User ~S not found." name))
+              (t (error "getpwnam failed: ~A" (lw:get-unix-error errno))))))
+    (fli:foreign-slot-value passwd 'uid)))
+
+(fli:define-c-struct group
+  (name (:pointer :char))
+  (passwd (:pointer :char))
+  (gid :int)
+  (mem (:pointer (:pointer :char))))
+
+(fli:define-foreign-function (getgrnam "getgrnam")
+    ((name (:reference-pass :ef-mb-string)))
+  :result-type (:pointer group))
+
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (let ((group (getgrnam name)))
+    (when (fli:null-pointer-p group)
+      (let ((errno (lw:errno-value)))
+        (cond ((zerop errno)
+               (error "Group ~S not found." name))
+              (t (error "getgrnam failed: ~A" (lw:get-unix-error errno))))))
+    (fli:foreign-slot-value group 'gid)))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-mcl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,54 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-mcl.lisp,v 1.6 2007/01/01 23:50:30 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (let ((errno (ccl::setuid uid)))
+    (unless (zerop errno)
+      (error "setuid failed with errno ~A." errno))))
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (let ((errno (ccl::setgid gid)))
+    (unless (zerop errno)
+      (error "setgid failed with errno ~A." errno))))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (declare (ignore name))
+  (error "GET-UID-FROM-NAME not yet implemented for OpenMCL.  Please send patches..."))
+  
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (declare (ignore name))
+  (error "GET-GID-FROM-NAME not yet implemented for OpenMCL.  Please send patches..."))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/unix-sbcl.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,57 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/unix-sbcl.lisp,v 1.7 2007/10/06 22:44:06 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (and (eq (nth-value 1 (find-symbol "GETGRNAM" :sb-posix)) :external)
+             (eq (nth-value 1 (find-symbol "GROUP-GID" :sb-posix)) :external))
+    (pushnew :sb-posix-has-getgrnam *features*)))
+
+(defun setuid (uid)
+  "Sets the effective user ID of the current process to UID - see
+setuid\(2)."
+  (sb-posix:setuid uid))
+
+(defun setgid (gid)
+  "Sets the effective group ID of the current process to GID -
+see setgid\(2)."
+  (sb-posix:setgid gid))
+
+(defun get-uid-from-name (name)
+  "Returns the UID for the user named NAME."
+  (sb-posix:passwd-uid (sb-posix:getpwnam name)))
+
+(defun get-gid-from-name (name)
+  "Returns the GID for the group named NAME."
+  (declare (ignorable name))
+  #+:sb-posix-has-getgrnam
+  (sb-posix:group-gid (sb-posix:getgrnam name))
+  #-:sb-posix-has-getgrnam
+  (error "You need a version of SBCL with SB-POSIX:GETGRNAM \(1.0.10.31 or higher)."))

Added: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/util.lisp	Thu Feb  7 03:16:29 2008
@@ -0,0 +1,406 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.33 2007/12/29 17:35:02 edi Exp $
+
+;;; Copyright (c) 2004-2007, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :hunchentoot)
+
+#-:lispworks
+(defmacro when-let ((var form) &body body)
+  "Evaluates FORM and binds VAR to the result, then executes BODY
+if VAR has a true value."
+  `(let ((,var ,form))
+     (when ,var , at body)))
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+  "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;; <cy3bshuf30f.fsf at ljosa.com> by Vebjorn Ljosa - see also
+  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+  `(let ,(mapcar #'(lambda (binding)
+                     (check-type binding (or cons symbol))
+                     (if (consp binding)
+                       (destructuring-bind (var x) binding
+                         (check-type var symbol)
+                         `(,var (gensym ,(etypecase x
+                                          (symbol (symbol-name x))
+                                          (character (string x))
+                                          (string x)))))
+                       `(,binding (gensym ,(symbol-name binding)))))
+                 bindings)
+         , at body))
+
+#+:lispworks
+(defmacro with-rebinding (bindings &body body)
+  "Renaming LW:REBINDING for better indentation."
+  `(lw:rebinding ,bindings , at body))
+
+#-:lispworks
+(defmacro with-rebinding (bindings &body body)
+  "Syntax: WITH-REBINDING ( { var | (var prefix) }* ) form*
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;; <cy3wv0fya0p.fsf at ljosa.com> by Vebjorn Ljosa - see also
+  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+  (loop for binding in bindings
+        for var = (if (consp binding) (car binding) binding)
+        for name = (gensym)
+        collect `(,name ,var) into renames
+        collect ``(,,var ,,name) into temps
+        finally (return `(let ,renames
+                          (with-unique-names ,bindings
+                            `(let (,, at temps)
+                              ,, at body))))))
+
+(defun starts-with-p (seq subseq &key (test 'eql))
+  "Tests whether the sequence SEQ starts with the sequence
+SUBSEQ.  Individual elements are compared with TEST."
+  (let* ((length (length subseq))
+         (mismatch (mismatch subseq seq
+                             :test test)))
+    (or (null mismatch)
+        (<= length mismatch))))
+
+(defun starts-with-one-of-p (seq subseq-list &key (test 'eql))
+  "Tests whether the sequence SEQ starts with one of the
+sequences in SUBSEQ-LIST.  Individual elements are compared with
+TEST."
+  (some (lambda (subseq)
+          (starts-with-p seq subseq :test test))
+        subseq-list))
+
+(defun create-random-string (&optional (n 10) (base 16))
+  "Returns a random number \(as a string) with base BASE and N
+digits."
+  (with-output-to-string (s)
+    (dotimes (i n)
+      (format s "~VR" base
+              (random base *the-random-state*)))))
+
+(defun reset-session-secret ()
+  "Sets *SESSION-SECRET* to a new random value. All old sessions will
+cease to be valid."
+  (setq *session-secret* (create-random-string 10 36)))
+
+(defun reason-phrase (return-code)
+  "Returns a reason phrase for the HTTP return code RETURN-CODE
+\(which should be an integer) or NIL for return codes Hunchentoot
+doesn't know."
+  (gethash return-code *http-reason-phrase-map*))
+
+(defun make-keyword (string &key (destructivep t))
+  "Interns the upcased version of STRING into the KEYWORD package.
+Uses NSTRING-UPCASE if DESTRUCTIVEP is true.  Returns NIL if STRING is
+not a string."
+  (and (stringp string)
+       (intern (if destructivep
+                 (nstring-upcase string)
+                 (string-upcase string)) :keyword)))
+
+(defgeneric assoc (thing alist &key &allow-other-keys)
+  (:documentation "LIKE CL:ASSOC, but \'does the right thing\' if
+THING is a string or a symbol."))
+
+(defmethod assoc ((thing symbol) alist &key &allow-other-keys)
+  "Version of ASSOC for symbols, always uses EQ as test function."
+  (cl:assoc thing alist :test #'eq))
+
+(defmethod assoc ((thing string) alist &key (test #'string-equal))
+  "Version of ASSOC for strings, uses STRING-EQUAL as default test
+function."
+  (cl:assoc thing alist :test test))
+
+(defmethod assoc (thing alist &key (test #'eql))
+  "Default method - uses EQL as default test like CL:ASSOC."
+  (cl:assoc thing alist :test test))
+
+(defun md5-hex (string)
+  "Calculates the md5 sum of the string STRING and returns it as a hex string."
+  (with-output-to-string (s)
+    (loop for code across (md5:md5sum-sequence string)
+	  do (format s "~2,'0x" code))))
+
+(defun escape-for-html (string)
+  "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output."
+  (with-output-to-string (out)
+    (with-input-from-string (in string)
+      (loop for char = (read-char in nil nil)
+            while char
+            do (case char
+                 ((#\<) (write-string "&lt;" out))
+                 ((#\>) (write-string "&gt;" out))
+                 ((#\") (write-string "&quot;" out))
+                 ((#\') (write-string "&#039;" out))
+                 ((#\&) (write-string "&amp;" out))
+                 (otherwise (write-char char out)))))))
+
+(defun http-token-p (token)
+  "Tests whether TOKEN is a string which is a valid 'token'
+according to HTTP/1.1 \(RFC 2068)."
+  (and (stringp token)
+       (plusp (length token))
+       (every (lambda (char)
+                (and ;; CHAR is US-ASCII but not control character or ESC
+                     (< 31 (char-code char) 127)
+                     ;; CHAR is not 'tspecial'
+                     (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=))))
+              token)))
+
+
+(defun rfc-1123-date (&optional (time (get-universal-time)))
+  "Generates a time string according to RFC 1123.  Default is current time."
+  (multiple-value-bind
+        (second minute hour date month year day-of-week)
+      (decode-universal-time time 0)
+    (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
+            (svref +day-names+ day-of-week)
+            date
+            (svref +month-names+ (1- month))
+            year
+            hour
+            minute
+            second)))
+
+(defun iso-time (&optional (time (get-universal-time)))
+  "Returns the universal time TIME as a string in full ISO format."
+  (multiple-value-bind (second minute hour date month year)
+      (decode-universal-time time)
+    (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
+            year month date hour minute second)))
+
+(let ((counter 0))
+  (declare (ignorable counter))
+  (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
+    "Generates a unique name for a temporary file.  This function is
+called from the RFC2388 library when a file is uploaded."
+    (let ((tmp-file-name
+           #+:allegro
+           (pathname (system:make-temp-file-name prefix *tmp-directory*))
+           #-:allegro
+           (loop for pathname = (make-pathname :name (format nil "~A-~A"
+                                                             prefix (incf counter))
+                                               :type nil
+                                               :defaults *tmp-directory*)
+                 unless (probe-file pathname)
+                 return pathname)))
+      (push tmp-file-name *tmp-files*)
+      ;; maybe call hook for file uploads
+      (when *file-upload-hook*
+        (funcall *file-upload-hook* tmp-file-name))
+      tmp-file-name)))
+
+(defun quote-string (string)
+  "Quotes string according to RFC 2616's definition of `quoted-string'."
+  (with-output-to-string (out)
+    (with-input-from-string (in string)
+      (loop for char = (read-char in nil nil)
+            while char
+            unless (or (char< char #\Space)
+                       (char= char #\Rubout))
+              do (case char
+                   ((#\\) (write-string "\\\\" out))
+                   ((#\") (write-string "\\\"" out))
+                   (otherwise (write-char char out)))))))
+
+(defun url-decode (string &optional (external-format *hunchentoot-default-external-format*))
+  "Decodes a URL-encoded STRING which is assumed to be encoded using
+the external format EXTERNAL-FORMAT."
+  (let ((vector (make-array (length string)
+                            :element-type 'octet
+                            :fill-pointer 0)))
+    (loop with percent-p and buff
+          for char of-type character across string
+          for i from 0
+          when buff do
+            (vector-push (parse-integer string
+                                        :start (1- i)
+                                        :end (1+ i)
+                                        :radix 16)
+                         vector)
+            (setq buff nil)
+          else when percent-p
+                 do (setq buff t
+                          percent-p nil)
+          else when (char= char #\%)
+                 do (setq percent-p t)
+          else do (vector-push (char-code (case char
+                                            ((#\+) #\Space)
+                                            (otherwise char)))
+                         vector))
+    (octets-to-string vector :external-format external-format)))
+
+(defun form-url-encoded-list-to-alist (form-url-encoded-list
+                                       &optional (external-format *hunchentoot-default-external-format*))
+  "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
+alist.  Both names and values are url-decoded while doing this."
+  (mapcar #'(lambda (entry)
+              (destructuring-bind (name &optional value)
+                  (split "=" entry :limit 2)
+                (cons (string-trim " " (url-decode name external-format))
+                      (url-decode (or value "") external-format))))
+          form-url-encoded-list))
+
+(defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
+  "URL-encodes a string using the external format EXTERNAL-FORMAT."
+  (with-output-to-string (s)
+    (loop for c across string
+          for index from 0
+          do (cond ((or (char<= #\0 c #\9)
+                        (char<= #\a c #\z)
+                        (char<= #\A c #\Z)
+                        ;; note that there's no comma in there - because of cookies
+                        (find c "$-_.!*'()" :test #'char=))
+                     (write-char c s))
+                   (t (loop for octet across (string-to-octets string
+                                                               :start index
+                                                               :end (1+ index)
+                                                               :external-format external-format)
+                            do (format s "%~2,'0x" octet)))))))
+
+(defun force-output* (stream)
+  "Like FORCE-OUTPUT but aborts execution after
+*FORCE-OUTPUT-TIMEOUT* seconds."
+  (with-timeout (*force-output-timeout*
+                 (warn "FORCE-OUTPUT didn't return after ~A seconds."
+                       *force-output-timeout*))
+    (force-output stream)))
+
+(defun parse-content-type (content-type-header &optional want-external-format-p)
+  "Reads and parses a `Content-Type' header and returns it as three
+values - the type, the subtype, and an external format corresponding
+to the 'charset' parameter in the header \(or
+*HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*), if there is one and if the
+content type is \"text\" or WANT-EXTERNAL-FORMAT-P is true.
+CONTENT-TYPE-HEADER is supposed to be the corresponding header value
+as a string."
+  (with-input-from-string (stream content-type-header)
+    (let* ((*current-error-message* "Corrupted Content-Type header:")
+           (type (read-token stream))
+           (subtype (and (or (ignore-errors (assert-char stream #\/))
+                             (return-from parse-content-type
+                               ;; try to return something meaningful
+                               (values "application" "octet-stream"
+                                       (and want-external-format-p
+                                            *hunchentoot-default-external-format*))))
+                         (read-token stream)))
+           (parameters (read-name-value-pairs stream))
+           (charset (cdr (assoc "charset" parameters)))
+           (external-format
+            (and (or want-external-format-p
+                     (string-equal type "text"))
+                 (or (when charset
+                       (handler-case
+                           (make-external-format (make-keyword charset) :eol-style :lf)
+                         (error (condition)
+                           (warn "Ignoring external format of name ~S~
+because of error:~%~A"
+                                 charset condition))))
+                     *hunchentoot-default-external-format*))))
+      (values type subtype external-format))))
+
+(defun get-token-and-parameters (header)
+  (with-input-from-string (stream header)
+    (let* ((*current-error-message* (format nil "Corrupted header ~S:" header))
+           (token (read-token stream))
+           (parameters (read-name-value-pairs stream)))
+      (values token parameters))))
+
+(defun keep-alive-p ()
+  "Returns a true value unless the incoming request obviates a
+keep-alive reply.  The second return value denotes whether the client
+has explicitly asked for a persistent connection."
+  (let ((connection-values
+         ;; the header might consist of different values separated by commas
+         (when-let (connection-header (header-in :connection))
+           (split "\\s*,\\s*" connection-header))))
+    (flet ((connection-value-p (value)
+             "Checks whether the string VALUE is one of the
+values of the `Connection' header."
+             (member value connection-values :test #'string-equal)))
+      (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
+        (values (and (or (and (eq (server-protocol) :http/1.1)
+                              (not (connection-value-p "close")))
+                         (and (eq (server-protocol) :http/1.0)
+                              keep-alive-requested-p)))
+                keep-alive-requested-p)))))
+
+(defun address-string ()
+  "Returns a string with information about Hunchentoot suitable for
+inclusion in HTML output."
+  (format nil "<address>~:[~3*~;<a href='http://httpd.apache.org/'>~A</a> / <a href='http://www.fractalconcept.com/asp/html/mod_lisp.html'>mod_lisp~A~@[/~A~]</a> / ~]<a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
+          (server-mod-lisp-p *server*)
+          (or (header-in :server-baseversion) "Apache")
+          (or (header-in :modlisp-major-version) "")
+          (header-in :modlisp-version)
+          *hunchentoot-version*
+          +implementation-link+
+          (escape-for-html (lisp-implementation-type))
+          (escape-for-html (lisp-implementation-version))
+          (or (host *request*) (server-address *server*))
+          (scan ":\\d+$" (or (host *request*) ""))
+          (server-port)))
+
+(defun server-name-header ()
+  "Returns a string which can be used for 'Server' headers."
+  (format nil "Hunchentoot ~A" *hunchentoot-version*))
+
+(defun input-chunking-p ()
+  "Whether input chunking is currently switched on for \(the socket
+stream underlying) *HUNCHENTOOT-STREAM* - note that this will return
+NIL if the underlying stream of the flexi stream is not a chunked
+stream."
+  (chunked-stream-input-chunking-p (flexi-stream-stream *hunchentoot-stream*)))
+
+(defun cleanup-function ()
+  "The default for *CLEANUP-FUNCTION*.  Invokes a GC on 32-bit
+LispWorks and does nothing on other Lisps."
+  #+(and :lispworks (not :lispworks-64bit))
+  (hcl:mark-and-sweep 2))


From hhubner at common-lisp.net  Thu Feb  7 08:21:53 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu,  7 Feb 2008 03:21:53 -0500 (EST)
Subject: [bknr-cvs] r2450 - in branches/trunk-reorg/thirdparty/acl-compat: .
	allegro clisp cmucl lispworks mcl sbcl scl
Message-ID: <20080207082153.3EC933C047@common-lisp.net>

Author: hhubner
Date: Thu Feb  7 03:21:48 2008
New Revision: 2450

Added:
   branches/trunk-reorg/thirdparty/acl-compat/
   branches/trunk-reorg/thirdparty/acl-compat/CREDITS
   branches/trunk-reorg/thirdparty/acl-compat/ChangeLog
   branches/trunk-reorg/thirdparty/acl-compat/README
   branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system
   branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd
   branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp
   branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/allegro/
   branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp
   branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/acl-compat/clisp/
   branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/cmucl/
   branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/lispworks/
   branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/
   branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp
   branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp
   branches/trunk-reorg/thirdparty/acl-compat/packages.lisp
   branches/trunk-reorg/thirdparty/acl-compat/sbcl/
   branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/scl/
   branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp
   branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp
   branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp
   branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp
   branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp   (contents, props changed)
Log:
add acl-compat

Added: branches/trunk-reorg/thirdparty/acl-compat/CREDITS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/CREDITS	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,59 @@
+-*- text -*-
+
+CREDITS; a.k.a. the history of Portable AllegroServe
+
+This was written by Rudi Schlatte, who (knowing himself) is sure he
+forgot some important contributors.  Please mail me (rudi at
+constantly.at) to point out any inconsistencies, don't be shy!
+
+* Corman Lisp
+
+The code that started it all.  Chris Double took Allegro's
+open-sourced code, got it to run on Corman Lisp and released the
+code..  After Portable AllegroServe got off the ground, he re-arranged
+his port so that it fit in the structure of acl-compat.
+
+* Xanalys LispWorks
+
+Jochen Schmidt ported Chris Double's AllegroServe port to LispWorks,
+laid the groundwork for the "Portable" part of paserve and started
+the SourceForge project.
+
+* cmucl
+
+cmucl was the third Lisp implementation to run Portable
+AllegroServe.  The port was done by Rudi Schlatte during his military
+service out of sheer boredom.
+
+* Digitool MCL 
+
+John DeSoi contributed this port and kept it working when the antics
+of other developers broke his code once again.
+
+* OpenMCL
+
+Also done by John DeSoi.  Gary Byers himself later contributed code to
+support OpenMCL's OS-level threads (OpenMCL version 14 and up) in an
+efficient way.
+
+* sbcl
+
+This port was done by Rudi Schlatte, using Daniel Barlow's sbcl
+multiprocessing code in the McCLIM GUI project as inspiration.
+
+* clisp
+
+Also by Rudi Schlatte.  Since clisp has no support for threads,
+neither does acl-compat on this platform.  Code can still be
+compiled, however.
+
+* Scieneer Common Lisp
+
+This port was contributed by Douglas Crosher.
+
+* Allegro Common Lisp
+
+It may seem strange to implement an API on top of itself, but Kevin
+Rosenberg's implementation makes it possible to run systems that use
+acl-compat on ACL itself without source changes.
+

Added: branches/trunk-reorg/thirdparty/acl-compat/ChangeLog
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/ChangeLog	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,354 @@
+2006-01-22  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-mp.lisp (defun/sb-thread): silence compilation style
+	warning on single-threaded sbcl
+
+	* sbcl/acl-excl.lisp (filesys-type): Fix bogus variable name :(
+
+2006-01-21  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-excl.lisp (filesys-type, filesys-inode): use sb-posix
+	instead of sbcl internals
+
+2005-08-05  Gabor Melis  <mega at hotpop.com>
+
+	* sbcl/acl-mp.lisp: updated to use the thread object api
+	  available since sbcl 0.9.2
+
+2004-02-17  Rudi Schlatte  <rudi at SLAW40.kfunigraz.ac.at>
+
+	* acl-excl-common.lisp (match-regexp): Make :return :index return
+	values same as ACL
+
+2004-02-16  Rudi Schlatte  <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+	* acl-compat.asd: 
+	- Add some meta-information to system definition
+	- Fix bug: all but the first :depends-on arguments are silently
+	ignored.  :/
+
+2004-02-16  Rudi Schlatte  <rudi at constantly.at>
+
+	* packages.lisp: Remove references to nregex package.
+
+	* acl-excl-common.lisp (match-regexp, compile-regexp): Implement
+	using cl-ppcre.
+
+	* acl-compat.asd: Eliminate meta and nregex, use cl-ppcre instead.
+
+2004-02-14  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd: Make Gray streams loading on cmucl a little bit
+	saner (but only a little bit)
+
+	* chunked-stream-mixin.lisp: Don't add to *features*, remove
+	provide form.
+
+2004-02-08  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd: Introduce dependency on puri, remove meta and
+	uri.lisp
+
+2004-02-02  Rudi Schlatte  <rudi at constantly.at>
+
+	* cmucl/acl-mp.lisp (process-run-function): Give the new process
+	a run reason, so that it doesn't hang from the start.
+
+	* cmucl/acl-socket.lisp (get-fd): Added method for server-socket.
+
+2004-01-28  Rudi Schlatte  <rudi at constantly.at>
+
+	* packages.lisp: excl -> acl-compat.excl
+
+	* lispworks/acl-socket.lisp: ditto.
+
+2004-01-27  Rudi Schlatte  <rudi at constantly.at>
+
+	* chunked-stream-mixin.lisp: replace excl: package prefix with
+	acl-compat.excl:
+
+2004-01-26  Rudi Schlatte  <rudi at constantly.at>
+
+	* mcl/acl-excl.lisp (fixnump): new function.
+
+	* packages.lisp (:acl-compat.excl): Remove "excl" nickname.
+
+	* clisp/acl-excl.lisp (fixnump): new function.
+
+2004-01-24  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-excl-common.lisp (string-to-octets): null-terminate vector
+	when asked to.
+
+	* cmucl/acl-excl.lisp, lispworks/acl-excl.lisp, mcl/acl-excl.lisp,
+	sbcl/acl-excl.lisp, scl/acl-excl.lisp: Move write-vector,
+	string-to-octets to commmon file.
+
+	* acl-excl-common.lisp: Moved write-vector, string-to-octets from
+	implementation-specific files.
+
+2004-01-19  Rudi Schlatte  <rudi at constantly.at>
+
+	* scl/acl-excl.lisp, sbcl/acl-excl.lisp, mcl/acl-excl.lisp,
+	lispworks/acl-excl.lisp, cmucl/acl-excl.lisp,
+	clisp/acl-excl.lisp: Remove common functionality from
+	implementation-specific files, dammit!
+
+	* acl-compat.asd: Added acl-excl-common.
+
+	* acl-excl-common.lisp: New file.
+
+2004-01-18  Rudi Schlatte  <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+	* acl-excl-corman.lisp (intern*), sbcl/acl-excl.lisp (intern*),
+	mcl/acl-excl.lisp (intern*), lispworks/acl-excl.lisp (intern*),
+	cmucl/acl-excl.lisp (intern*), clisp/acl-excl.lisp (intern*),
+	scl/acl-excl.lisp (intern*): Don't upcase symbol before interning
+	(thanks to Marco Baringer, whose code was broken by this).  Now
+	I'm motivated to factor out common code from all the backends ...
+
+	* cmucl/acl-mp.lisp (apply-with-bindings): Fix "How did this ever
+	work" typo; thanks to Marco Baringer.
+
+2004-01-11  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-socket.lisp (make-socket): Handle :local-port nil,
+	don't bind socket in that case (let os choose a port)
+
+2004-01-11  Rudi Schlatte  <rudi at constantly.at>
+
+	* packages.lisp (defpackage acl-compat.excl): Export some symbols
+	for mcl, too
+
+	* mcl/acl-excl.lisp (run-shell-command): Implement (largely
+	untested for now, needed for cgi support)
+
+	* mcl/acl-sys.lisp (command-line-argument,
+	command-line-arguments): Implement for OpenMCL
+
+	* mcl/acl-mp.lisp (wait-for-input-available): Implement.  Needed
+	for cgi support.
+
+	* mcl/acl-socket-openmcl.lisp (server-socket): Remove :type slot
+	argument.
+
+	* sbcl/acl-socket.lisp (make-socket): Add reuse-address argument.
+
+	* cmucl/acl-socket.lisp (make-socket): Add reuse-address argument.
+
+	* acl-compat.asd: Load sb-posix for sbcl.
+
+2003-12-15  Rudi Schlatte  <rudi at constantly.at>
+
+	NOTE: this checkin has a reasonable chance of breaking (and mcl
+	(not openmcl))
+	
+	* mcl/acl-socket-openmcl.lisp: Remove package definition,
+	implement chunked transfer encoding (accepting a speed loss in the
+	process)
+
+	* mcl/acl-excl.lisp, mcl/acl-mp.lisp, mcl/acl-sys.lisp: remove
+	package definitions
+
+	* uri.lisp: deftype also at load time; openmcl breaks otherwise
+
+	* packages.lisp: mcl doesn't have stream-(read,write)-sequence
+
+	* lw-buffering.lisp: formatting frobs.
+
+	* acl-compat.asd: Merge mcl defsystem with the others.
+
+	* sbcl/acl-socket.lisp: Use acl-compat.socket package name.
+	
+2003-12-02  Rudi Schlatte  <rudi at SLAW40.kfunigraz.ac.at>
+
+	* meta.lisp (enable-meta-syntax): Save current readtable before
+	installing *meta-readtable*.
+
+2003-12-01  Rudi Schlatte  <rudi at constantly.at>
+
+	* chunked-stream-mixin.lisp: Merge Lispworks patch from Edi Weitz
+	(paserve-help 2003-11-28)
+
+2003-11-27  Rudi Schlatte  <rudi at constantly.at>
+
+	* chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer):
+	LispWorks refill-buffer does not always return the amount of
+	bytes read (reported by Edi Weitz to paserve-discuss
+	2003-11-26).  Treat its return value as a boolean.
+
+	* lw-buffering.lisp (stream-fill-buffer): Remove cmucl-specific
+	read-n-bytes call because it does block after all :(
+
+	* chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Fix
+	for Lispworks client mode contributed by Edi Weitz to
+	paserve-discuss list on 2003-11-25
+
+	* sbcl/acl-mp.lisp: Single-threaded "implementation" of process-name
+
+2003-09-19  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-mp.lisp: Merged threading patch from Brian Downing
+	(posted to portableaserve-discuss 2003-09-12)
+
+	* clisp/acl-excl.lisp, clisp/acl-socket.lisp: Eliminate compile
+	failures, activate chunked support for clisp (forwarded by Kevin
+	M. Rosenberg from Debian)
+
+2003-08-31  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd: Remove old cmu-read-sequence cruft, bug is fixed
+	in reasonably recent cmucl
+
+	* lw-buffering.lisp (stream-fill-buffer): Use package-external
+	symbol that doesn't break on CVS cmucl
+
+2003-08-30  Rudi Schlatte  <rudi at 62-99-252-74.C-GMITTE.Xdsl-line.inode.at>
+
+	* cmucl/acl-socket.lisp (make-socket): set reuse-address option.
+
+	* lw-buffering.lisp (stream-fill-buffer): Implement b/nb semantics
+	for cmucl as well.  client mode should now neither hang trying to
+	read closed streams nor give spurious errors for slow servers.
+
+2003-08-17  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-mp.lisp (with-timeout): Eliminate unused-variable
+	warning.
+
+2003-05-13  Rudi Schlatte  <rudi at constantly.at>
+
+	* cmucl/acl-sys.lisp, cmucl/acl-socket.lisp, cmucl/acl-excl.lisp:
+	Use correct package names in in-package forms (Reported by Johan
+	Parin)
+
+	* packages.lisp (acl-compat.system): Add nickname acl-compat.sys,
+	remove commented-out nicknames.
+
+	* lispworks/acl-sys.lisp: push MSWINDOWS onto *features* if
+	appropriate (Thanks to Alain Picard for the report).
+
+2003-05-11  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd: Don't load read-/write-sequence patches on cmucl
+	18e.
+
+2003-05-06  Rudi Schlatte  <rudi at constantly.at>
+
+	* lw-buffering.lisp (stream-fill-buffer): Implement
+	blocking/non-blocking semantics (read at least one byte per
+	fill-buffer call).  Otherwise we'd get spurious EOFs with slow
+	servers.
+
+	* chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer):
+	Return a sensible value (amount of bytes that can be read before
+	next call to fill-buffer).
+
+2003-05-03  Rudi Schlatte  <rudi at constantly.at>
+
+	* chunked-stream-mixin.lisp (gray-stream:stream-fill-buffer): Make
+	input-chunking work, refactor somewhat to make all slot changes in
+	one place.
+
+2003-05-02  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd (acl-compat): Current cmucl versions handle Gray
+	streams in (read,write)-sequence -- remove hack
+
+2003-04-30  Rudi Schlatte  <rudi at constantly.at>
+
+	* sbcl/acl-mp.lisp (with-timeout): Use timeout symbols from the
+	ext package; latest cvs exports them
+
+	* cmucl/acl-mp.lisp: Use acl-compat.mp package name.
+
+	* acl-compat.asd et al: The Great Renaming: begin move of
+	implementation-dependent files into subdirectories
+
+2003-04-27  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-socket-sbcl.lisp: Implemented peername lookup (by storing
+	the socket in the plist of the bivalent stream object for now)
+
+2003-04-26  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-mp-sbcl.lisp: Add initial support for multi-threaded sbcl
+
+2003-04-08  Rudi Schlatte  <rudi at constantly.at>
+
+	* uri.lisp (render-uri): Reinstate with-output-to-string logic;
+	render-uri has to handle nil as a stream value.
+
+2003-04-03  Rudi Schlatte  <rudi at constantly.at>
+
+	* uri.lisp (render-uri, print-object): Further frob printing of
+	URIs, inspired by patch of Harley Gorrell
+
+2003-04-02  Rudi Schlatte  <rudi at constantly.at>
+
+	* uri.lisp (render-uri): Fix printing URIs in the presence of #\~
+	(Thanks to Harley Gorrell)
+
+2003-03-24  Rudi Schlatte  <rudi at constantly.at>
+
+	* lw-buffering.lisp (stream-write-buffer, stream-flush-buffer):
+	Eliminate "wait" parameter to regain api-compatibility with lispworks
+	(stream-finish-output, stream-force-output): Call (finish|force)-output
+	here instead of using "wait" parameter of stream-flush-buffer
+
+	* chunked-stream-mixin.lisp: some documentation added, formatting,
+	eliminate use of "wait" parameter on stream-write-buffer etc.
+
+2003-02-28  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-socket-sbcl.lisp: 
+	(remote-host, remote-port, local-host, local-port): Change return
+	value to something convertible to an (invalid) inet address
+
+	* acl-compat.asd, packages.lisp: Support sbcl 0.7.13 single-threaded
+
+2002-12-26  Rudi Schlatte  <rudi at constantly.at>
+
+	* lw-buffering.lisp (write-elements): end argument value can be
+	nil (fix contributed by Simon Andras 2002-12-24)
+
+	* meta.lisp: Switch to new-style eval-when times
+
+	* lw-buffering.lisp: Switch to new-style eval-when times
+	(defstruct buffer-state): Add type declarations
+	(stream-fill-buffer): Remove bug for non-cmucl case (need
+	unblocking read-sequence)
+
+	* chunked-stream-mixin.lisp: Add defgeneric forms
+
+	* acl-socket-sbcl.lisp: Enable chunked transfer encoding support
+
+2002-12-23  Rudi Schlatte  <rudi at constantly.at>
+
+	* packages.lisp, acl-sys-sbcl.lisp: Various sbcl fixes
+
+2002-12-18  Rudi Schlatte  <rudi at constantly.at>
+
+	* packages.lisp: Add package definition of
+	de.dataheaven.chunked-stream-mixin, remove nicknames for
+	acl-compat.system
+
+2002-12-17  Rudi Schlatte  <rudi at constantly.at>
+
+	*  (Module): Added first stab at sbcl support (some stub
+	functions, basic page serving works)
+
+2002-12-13  Rudi Schlatte  <rudi at constantly.at>
+
+	* lw-buffering.lisp (stream-write-sequence): Make publish-multi
+	work (provide default value for start arg).
+
+	* acl-excl-cmu.lisp (write-vector): ditto.
+
+2002-12-03  Rudi Schlatte  <rudi at constantly.at>
+
+	* acl-compat.asd: load lw-buffering in every implementation except
+	lispworks
+
+	* packages.lisp: define gray-stream package for every
+	implementation

Added: branches/trunk-reorg/thirdparty/acl-compat/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/README	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,33 @@
+-*- text -*-
+
+acl-compat is a library that implements parts of the Allegro Common
+Lisp (ACL) API for areas that are not covered by the ANSI Common Lisp
+standard itself (e.g. sockets, threading).  The motivation for
+creating and maintaining acl-compat is to get the web server
+AllegroServe (that was released by Franz Inc under the LLGPL) running
+on a wide range of Lisp implementations, with as few source changes to
+its core code as possible.
+
+acl-compat names its packages by prepending the corresponding ACL
+package name with the string "ACL-COMPAT.".  For example, the ACL
+threading API symbols are exported from the package ACL-COMPAT.MP.
+Ideally, ACL-specific code could run on any supported Lisp
+implementation only by changing package references.  
+
+Of course, the present situation is not ideal.  :( Functionality is
+only implemented on an as-needed basis, implemented functions don't
+handle all argument combinations properly, etc.  On the other hand,
+enough is implemented to support a web and application server that
+exercises a wide range of functionality (client and server sockets,
+threading, etc.).
+
+
+To load acl-compat:
+
+- install asdf (see < http://www.cliki.net/asdf >) and make sure it's
+  loaded.
+
+- load acl-compat.asd
+
+- evaluate (asdf:operate 'asdf:load-op :acl-compat)
+

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-cmu.system	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,36 @@
+;;; -*- mode: lisp -*-
+
+(in-package :CL-USER)
+
+;; Stig: we're a debian-package if clc is present
+;; Rudi: Not if kludge-no-cclan is also present
+#+(and common-lisp-controller (not kludge-no-cclan))
+(setf (logical-pathname-translations "acl-compat")
+      '(("**;*.*.*" "cl-library:;acl-compat;**;*.*.*")))
+
+(mk:defsystem "ACL-COMPAT"
+    :source-pathname (make-pathname :directory
+                                    (pathname-directory *load-truename*)) ;"acl-compat:"
+;    :source-extension "lisp"
+;    :binary-pathname nil
+;    :binary-extension nil
+    :components ((:file "nregex")
+                 (:file "packages" :depends-on ("nregex"))
+                 (:file "lw-buffering" :depends-on ("packages"))
+                 (:file "acl-mp-cmu" :depends-on ("packages"))
+                 (:file "acl-excl-cmu" :depends-on ("packages" "nregex"))
+                 (:file "cmu-read-sequence")
+                 (:file "acl-socket-cmu"
+                        :depends-on ("packages" "acl-excl-cmu"
+                                     "chunked-stream-mixin"
+                                     "cmu-read-sequence"))
+                 (:file "acl-sys-cmu" :depends-on ("packages"))
+                 (:file "meta")
+                 (:file "uri" :depends-on ("meta"))
+                 (:file "chunked-stream-mixin"
+                        :depends-on ("packages" "acl-excl-cmu"
+                                     "lw-buffering")))
+    ;; Stig: if we're CMU and a debian-package, we need graystreams
+    #+(and cmu common-lisp-controller)
+    :depends-on
+    #+(and cmu common-lisp-controller) (cmucl-graystream))

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-common-lisp-lw.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,21 @@
+(defpackage acl-compat-common-lisp
+  (:use common-lisp)
+  (:shadow make-hash-table)
+  (:export make-hash-table))
+
+(in-package :acl-compat-common-lisp)
+
+(defun make-hash-table (&rest args &key test size rehash-size rehash-threshold (hash-function nil h-f-p) 
+                              (values t) weak-keys)
+  (declare (ignore hash-function))
+  (when h-f-p (error "User defined hash-functions are not supported."))
+  (let ((table (apply #'cl:make-hash-table :allow-other-keys t args)))
+    (hcl:set-hash-table-weak table
+                             (if weak-keys
+                                 (if (eq values :weak)
+                                     :both
+                                   :key)
+                               (if (eq values :weak)
+                                   :value
+                                 nil)))
+    table))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat-corman.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,13 @@
+(require 'gray-streams)
+(in-package :cl-user)
+
+(defvar *acl-compat-directory* "d:/projects/lisp/portableaserve/acl-compat/")
+(load (concatenate 'string *acl-compat-directory* "nregex.lisp"))
+(load (concatenate 'string *acl-compat-directory* "meta.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-excl-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-mp-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "acl-socket-corman.lisp"))
+(load (concatenate 'string *acl-compat-directory* "uri.lisp"))
+(load (concatenate 'string *acl-compat-directory* "packages.lisp"))
+
+(pushnew :acl-compat *features*)
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-compat.asd	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,182 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; This as an ASDF system for ACL-COMPAT, meant to replace
+;;;; acl-compat-cmu.system, but could replace all other systems, too.
+;;;; (hint, hint)
+
+(defpackage #:acl-compat-system
+  (:use #:cl #:asdf))
+(in-package #:acl-compat-system)
+
+;;;; gray stream support for cmucl: Debian/common-lisp-controller has
+;;;; a `cmucl-graystream' system; if this is not found, we assume a
+;;;; cmucl downloaded from cons.org, where Gray stream support resides
+;;;; in the subsystems/ directory.
+
+
+#+cmu
+(progn
+
+(defclass precompiled-file (static-file)
+  ())
+
+(defmethod perform ((operation load-op) (c precompiled-file))
+  (load (component-pathname c)))
+
+(defmethod operation-done-p ((operation load-op) (c precompiled-file))
+  nil)
+
+#-gray-streams
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (asdf:find-system :cmucl-graystream nil)
+    (asdf:defsystem cmucl-graystream
+        :pathname (make-pathname
+                   :name nil :type nil :version nil
+                   :defaults (truename "library:subsystems/gray-streams-library.x86f"))
+      :components ((:precompiled-file "gray-streams-library.x86f")))))
+)
+
+;;;; ignore warnings
+;;;;
+;;;; FIXME: should better fix warnings instead of ignoring them
+;;;; FIXME: (perform legacy-cl-sourcefile) duplicates ASDF code
+
+(defclass legacy-cl-source-file (cl-source-file)
+    ()
+  (:documentation
+   "Common Lisp source code module with (non-style) warnings.
+In contrast to CL-SOURCE-FILE, this class does not think that such warnings
+indicate failure."))
+
+(defmethod perform ((operation compile-op) (c legacy-cl-source-file))
+  (let ((source-file (component-pathname c))
+	(output-file (car (output-files operation c)))
+	(warnings-p nil)
+	(failure-p nil))
+    (setf (asdf::component-property c 'last-compiled) nil)
+    (handler-bind ((warning (lambda (c)
+			      (declare (ignore c))
+			      (setq warnings-p t)))
+		   ;; _not_ (or error (and warning (not style-warning)))
+		   (error (lambda (c)
+			    (declare (ignore c))
+			    (setq failure-p t))))
+      (compile-file source-file
+		    :output-file output-file))
+    ;; rest of this method is as for CL-SOURCE-FILE
+    (setf (asdf::component-property c 'last-compiled) (file-write-date output-file))
+    (when warnings-p
+      (case (asdf::operation-on-warnings operation)
+	(:warn (warn "COMPILE-FILE warned while performing ~A on ~A"
+		     c operation))
+	(:error (error 'compile-warned :component c :operation operation))
+	(:ignore nil)))
+    (when failure-p
+      (case (asdf::operation-on-failure operation)
+	(:warn (warn "COMPILE-FILE failed while performing ~A on ~A"
+		     c operation))
+	(:error (error 'compile-failed :component c :operation operation))
+	(:ignore nil)))))
+
+;;;
+;;; This is thought to reduce reader-conditionals in the system definition
+;;;
+(defclass unportable-cl-source-file (cl-source-file) ()
+  (:documentation
+   "This is for files which contain lisp-system dependent code. Until now those
+are marked by a -system postfix but we could later change that to a directory per
+lisp-system"))
+
+(defmethod perform ((op load-op) (c unportable-cl-source-file))
+  (#+cmu ext:without-package-locks
+   #-(or cmu) progn
+     (call-next-method)))
+
+(defmethod perform ((op compile-op) (c unportable-cl-source-file))
+  (#+cmu ext:without-package-locks
+   #-(or cmu) progn
+     (call-next-method)))
+
+(defmethod source-file-type ((c unportable-cl-source-file) (s module))
+  "lisp")
+
+
+(defun lisp-system-shortname ()
+  #+allegro :allegro #+lispworks :lispworks #+cmu :cmucl
+  #+(or mcl openmcl) :mcl #+clisp :clisp #+scl :scl #+sbcl :sbcl) ;mcl/openmcl use the same directory
+
+(defmethod component-pathname ((component unportable-cl-source-file))
+  (let ((pathname (call-next-method))
+        (name (string-downcase (lisp-system-shortname))))
+    (merge-pathnames
+     (make-pathname :directory (list :relative name))
+     pathname)))
+
+;;;; system
+
+#+(and mcl (not openmcl)) (require :ansi-make-load-form)
+
+(defsystem acl-compat
+    :name "acl-compat"
+    :author "The acl-compat team"
+    :version "0.1.1"
+    :description
+    "A reimplementation of parts of the ACL API, mainly to get
+    AllegroServe running on various machines, but might be useful
+    in other projects as well."
+    :properties
+    ((("system" "author" "email") . "portableaserve-discuss at lists.sourceforge.net")
+     (("albert" "presentation" "output-dir") . "docs/")
+     (("albert" "presentation" "formats") . "docbook")
+     (("albert" "docbook" "dtd") . "/Users/Shared/DocBook/lib/docbook/docbook-dtd-412/docbookx.dtd")
+     (("albert" "docbook" "template") . "book"))
+    :components
+    (
+     ;; packages
+     (:file "packages")
+     ;; Our stream class; support for buffering, chunking and (in the
+     ;; future) unified stream exceptions
+     #-(or lispworks (and mcl (not openmcl)))
+     (:file "lw-buffering" :depends-on ("packages"))
+     #-(or allegro (and mcl (not openmcl)))
+     (:legacy-cl-source-file "chunked-stream-mixin"
+                             :depends-on ("packages" "acl-excl"
+                                                     #-lispworks "lw-buffering"))
+     ;; Multiprocessing
+     #+(or mcl openmcl) (:unportable-cl-source-file "mcl-timers")
+     (:unportable-cl-source-file "acl-mp"
+                                 :depends-on ("packages" #+(or mcl openmcl) "mcl-timers"))
+     ;; Sockets, networking; TODO: de-frob this a bit
+     #-(or mcl openmcl)
+     (:unportable-cl-source-file
+      "acl-socket" :depends-on ("packages" "acl-excl"
+                                           #-(or allegro (and mcl (not openmcl))) "chunked-stream-mixin"))
+     #+(and mcl (not openmcl))
+     (:unportable-cl-source-file "acl-socket-mcl" :depends-on ("packages"))
+     #+(and mcl (not openmcl) (not carbon-compat)) 
+     (:unportable-cl-source-file
+      "mcl-stream-fix" :depends-on ("acl-socket-mcl"))
+     #+openmcl
+     (:unportable-cl-source-file
+      "acl-socket-openmcl" :depends-on ("packages" "chunked-stream-mixin"))
+     ;; Diverse macros, utility functions
+     #-allegro (:file "acl-excl-common" :depends-on ("packages"))
+     (:unportable-cl-source-file "acl-excl" :depends-on
+                                 #-allegro ("acl-excl-common")
+                                 #+allegro ("packages"))
+     (:unportable-cl-source-file "acl-sys" :depends-on ("packages"))
+     ;; SSL
+     #+(and ssl-available (not (or allegro mcl openmcl clisp)))
+     (:file "acl-ssl" :depends-on ("acl-ssl-streams" "acl-socket"))
+     #+(and ssl-available (not (or allegro mcl openmcl clisp)))
+     (:file "acl-ssl-streams" :depends-on ("packages")))
+    ;; Dependencies
+    :depends-on (:puri
+                 :cl-ppcre
+                 #+sbcl :sb-bsd-sockets
+                 #+sbcl :sb-posix
+                 #+(and cmu (not gray-streams)) :cmucl-graystream
+                 #+(and (or cmu lispworks) ssl-available) :cl-ssl
+                 )
+    :perform (load-op :after (op acl-compat)
+                      (pushnew :acl-compat cl:*features*)))

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-common.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,194 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; This is a modified version of Chris Doubles ACL excl wrapper library
+;;;; As stated in the changelogs of his original this file includes the 
+;;;; IF* macro placed in the public domain by John Foderaro. 
+;;;; See: http://www.franz.com/~jkf/ifstar.txt
+;;;;
+
+;;;; This file was made by Rudi Schlatte to gather
+;;;; not-implementation-specific parts of acl-compat in one place.
+
+;;;; This is the header of Chris Doubles original file. (but without Changelog)
+;;;;
+;;;; ACL excl wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;; 
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;;    not claim that you wrote the original software. If you use this
+;;;;    software in a product, an acknowledgment in the product documentation
+;;;;    would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;;    not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source 
+;;;;    distribution.
+;;;;
+
+(in-package :acl-compat.excl)
+
+(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
+
+;this is not used in aserve, but is needed to use the franz xmlutils package with acl-compat
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(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 , at 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 , at 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) , at col) totalcol))))
+	     ((eq state :compl)
+	      (cond ((not (string-equal lookat "elseif"))
+		     (error "if*: missing elseif clause ")))
+	      (setq state :init)))))
+
+(defvar *initial-terminal-io* *terminal-io*)
+(defvar *cl-default-special-bindings* nil)
+
+(defun filesys-size (stream)
+  (file-length stream))
+
+(defun filesys-write-date (stream)
+  (file-write-date stream))
+
+(defun frob-regexp (regexp)
+  "This converts from ACL regexps to Perl regexps.  The escape
+  status of (, ) and | is toggled."
+  (let ((escapees '(#\) #\( #\| )))
+    (with-input-from-string (in regexp)
+      (with-output-to-string (out)
+        (loop for c = (read-char in nil nil nil)
+             while c
+             do (cond ((and (char= c #\\)
+                            (member (peek-char nil in nil nil nil) escapees))
+                       (setf c (read-char in)))
+                      ((member c escapees)
+                       (princ #\\ out)))
+             (princ c out))))))
+
+;; TODO: a compiler macro for constant string regexps would be nice,
+;; so that the create-scanner call at runtime can be evaded.
+(defun match-regexp (string-or-regexp string-to-match
+                     &key newlines-special case-fold return
+                     (start 0) end shortest)
+  "Note: if a regexp compiled with compile-regexp is passed, the
+  options newlines-special and case-fold shouldn't be used, since
+  the underlying engine uses them when generating the scanner,
+  not when executing it."
+  (when shortest (error "match-regexp: shortest option not supported yet."))
+  (unless end (setf end (length string-to-match)))
+  (let ((scanner (cl-ppcre:create-scanner (frob-regexp string-or-regexp)
+                                          :case-insensitive-mode case-fold
+                                          :single-line-mode newlines-special)))
+      (ecase return
+        (:string                        ; return t, list of strings
+         (multiple-value-bind (match regs)
+             (cl-ppcre:scan-to-strings scanner string-to-match
+                                       :start start :end end)
+           (if match
+               (apply #'values t match (coerce regs 'list))
+               nil)))
+        (:index                         ; return (cons start end)
+         (multiple-value-bind (start end reg-starts reg-ends)
+             (cl-ppcre:scan scanner string-to-match :start start :end end)
+           (and start (apply #'values t (cons start end)
+                             (map 'list #'cons reg-starts reg-ends)))))
+        ((nil)                          ; return t
+         (not (not (cl-ppcre:scan scanner string-to-match
+                                  :start start :end end)))))))
+
+
+;; Caution Incompatible APIs!  cl-ppcre has options case-insensitive,
+;; single-line for create-scanner, ACL has it in match-regexp.
+(defun compile-regexp (regexp)
+  "Note: Take care when using scanners compiled with this option
+  to not depend on options case-fold and newlines-special in match-regexp."
+  (cl-ppcre:create-scanner (frob-regexp regexp)))
+
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(defun intern* (s len package)
+  (intern (subseq s 0 len) package))
+
+(defmacro errorset (form &optional (announce nil) (catch-breaks nil))
+  "This macro is incomplete.  It was hacked to get AllegroServe
+running, but the announce and catch-breaks arguments are ignored.  See
+documentation at
+http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm
+An implementation of the catch-breaks argument will necessarily be
+implementation-dependent, since Ansi does not allow any
+program-controlled interception of a break."
+  (declare (ignore announce catch-breaks))
+  `(let* ((ok nil)
+          (results (ignore-errors
+                     (prog1 (multiple-value-list ,form)
+                       (setq ok t)))))
+     (if ok
+         (apply #'values t results)
+         nil)))
+
+(defmacro fast (&body forms)
+  `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
+	    , at forms))
+
+#-cmu
+(defun write-vector (sequence stream &key (start 0) end endian-swap)
+  (declare (ignore endian-swap))
+  (check-type sequence (or string (array (unsigned-byte 8) 1)
+                           (array (signed-byte 8) 1)))
+  (write-sequence sequence stream :start start :end end))
+

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-excl-corman.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,233 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; This is a modified version of Chris Doubles ACL excl wrapper library
+;;;; As stated in the changelogs of his original this file includes the 
+;;;; IF* macro placed in the public domain by John Foderaro. 
+;;;; See: http://www.franz.com/~jkf/ifstar.txt
+;;;;
+;;;; It is not clear to this point if future releases will lead to a combined
+;;;; effort - So you may find newer versions of *this* file at 
+;;;; http://www.dataheaven.de
+;;;;
+
+;;;; This is the header of Chris Doubles original file. (but without Changelog)
+;;;;
+;;;; ACL excl wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;; 
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;;    not claim that you wrote the original software. If you use this
+;;;;    software in a product, an acknowledgment in the product documentation
+;;;;    would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;;    not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source 
+;;;;    distribution.
+;;;;
+;;;; Notes
+;;;; =====
+;;;; A simple implementation of some of the EXCL package from Allegro
+;;;; Common Lisp. Intended to be used for porting various ACL packages,
+;;;; like AllegroServe. 
+;;;;
+;;;; More recent versions of this software may be available at:
+;;;;   http://www.double.co.nz/cl
+;;;;
+;;;; Comments, suggestions and bug reports to the author, 
+;;;; Christopher Double, at: chris at double.co.nz
+
+(require 'nregex)
+(require 'mp)
+
+(defpackage :excl
+	(:use :common-lisp :nregex)
+        (:import-from :common-lisp "FIXNUMP")
+	(:export 
+		"IF*"
+		"*INITIAL-TERMINAL-IO*"
+		"*CL-DEFAULT-SPECIAL-BINDINGS*"
+		"FILESYS-SIZE"
+		"FILESYS-WRITE-DATE"
+		"STREAM-INPUT-FN"
+		"MATCH-REGEXP"
+		"COMPILE-REGEXP"
+		"*CURRENT-CASE-MODE*"
+		"INTERN*"
+		"FILESYS-TYPE"
+		"ERRORSET"
+		"ATOMICALLY"
+		"FAST"
+                "WITHOUT-PACKAGE-LOCKS"
+		"SOCKET-ERROR"
+                "RUN-SHELL-COMMAND"
+                "FIXNUMP"
+		))
+
+(in-package :excl)
+
+(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 , at 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 , at 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) , at col) totalcol))))
+	     ((eq state :compl)
+	      (cond ((not (string-equal lookat "elseif"))
+		     (error "if*: missing elseif clause ")))
+	      (setq state :init)))))
+
+(defvar *initial-terminal-io* *terminal-io*)
+(defvar *cl-default-special-bindings* nil)
+
+(defun filesys-size (stream)
+	(file-length stream))
+
+(defun filesys-write-date (stream)
+	(file-write-date stream))
+
+#+obsolete
+(defun stream-input-fn (stream)
+  stream)
+
+(defmethod stream-input-fn ((stream stream))
+  stream)
+	
+
+(defun match-regexp (pattern string &key (return :string))
+  (let ((res (cond ((stringp pattern)
+		    (regex pattern string))
+		   ((functionp pattern) (funcall pattern string))
+		   (t (error "Wrong type for pattern")))))
+    (case return
+      (:string
+       (values-list (cons (not (null res))
+                          res)))
+      (:index (error "REGEXP: INDEX Not implemented"))
+      (otherwise (not (null res))))))
+
+(defun compile-regexp (regexp)
+  (compile nil (regex-compile regexp)))
+
+(defvar *current-case-mode* :case-insensitive-upper)
+
+(defun intern* (s len package)
+  (intern (subseq s 0 len) package))
+
+(defun filesys-type (file-or-directory-name)
+	(if (ccl::directory-p file-or-directory-name)
+		:directory
+		(if (probe-file file-or-directory-name)
+			:file
+			nil)))
+
+(defmacro errorset (form &optional (announce nil) (catch-breaks nil))
+  "This macro is incomplete.  It was hacked to get AllegroServe
+running, but the announce and catch-breaks arguments are ignored.  See
+documentation at
+http://franz.com/support/documentation/6.1/doc/pages/operators/excl/errorset.htm
+An implementation of the catch-breaks argument will necessarily be
+implementation-dependent, since Ansi does not allow any
+program-controlled interception of a break."
+  (declare (ignore announce catch-breaks))
+  `(let* ((ok nil)
+          (results (ignore-errors
+                     (prog1 (multiple-value-list ,form)
+                       (setq ok t)))))
+     (if ok
+         (apply #'values t results)
+         nil)))
+
+
+(defmacro atomically (&body forms)
+  `(mp:without-scheduling , at forms))
+
+(defmacro fast (&body forms)
+  `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
+	    , at forms))
+
+(defmacro without-package-locks (&body forms)
+  `(progn , at forms))
+
+(define-condition socket-error (error)
+  ((stream :initarg :stream)
+   (code :initarg :code :initform nil)
+   (action :initarg :action)
+   (identifier :initarg :identifier :initform nil))
+  (:report (lambda (e s)
+	     (with-slots (identifier code action stream) e
+	       (format s "~S (errno ~A) occured while ~A"
+		       (case identifier
+			 (:connection-refused "Connection refused")
+			 (t identifier))
+		       code action)
+	       (when stream
+		 (prin1 stream s))
+	       (format s ".")))))
+
+#|
+(defun run-shell-command ()
+  (with-open-stream (s (open-pipe "/bin/sh"
+                                  :direction :io
+                                  :buffered nil))
+    (loop for var in environment
+          do (format stream "~A=~A~%" (car var) (cdr var)))
+|#
+  
+
+(provide 'acl-excl)

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-corman.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,52 @@
+;;; This file implements the process functions for AllegroServe in Corman Lisp.
+
+(require 'mp)
+
+(defpackage :acl-compat-mp
+  (:use :common-lisp :mp :sys)
+  (:export
+   #:process-interrrupt
+   #:make-process
+   #:make-process-lock
+   #:process-add-run-reason
+   #:process-kill
+   #:process-property-list
+   #:process-revoke-run-reason
+   #:process-run-function
+   #:with-process-lock
+   #:with-timeout
+   #:without-scheduling
+   #:*current-process*
+   #:lock
+   #:process-allow-schedule
+   #:process-name
+   #:process-preset
+   #:process-run-reasons
+   #:process-wait
+   #:without-interrupts
+   ))
+
+(in-package :acl-compat-mp)
+
+; existing stuff from ccl we can reuse directly
+;; The following process-property-list implementation was taken from
+;; the acl-mp-scl.lisp implementation.
+(defvar *process-plists* (make-hash-table :test #'eq)
+  "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+  (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+  (setf (gethash process *process-plists*) new-value))
+
+;; Dummy implementation of process-wait
+(defun process-wait (whostate function &rest args)
+    "This function suspends the current process (the value of sys:*current-process*) 
+    until applying function to arguments yields true. The whostate argument must be a 
+    string which temporarily replaces the process' whostate for the duration of the wait. 
+    This function returns nil."
+    (loop until (apply function args) do (sleep 0))
+    nil)
+    

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-mp-package.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,80 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;;										;
+;;;; (c) 2001 by Jochen Schmidt.
+;;;;
+;;;; File:            acl-mp-package.lisp
+;;;; Revision:        1.0.0
+;;;; Description:     Package definition for ACL-COMPAT-MP
+;;;; Date:            02.02.2002
+;;;; Authors:         Jochen Schmidt
+;;;; Tel:             (+49 9 11) 47 20 603
+;;;; Email:           jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer in the
+;;;;    documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER 
+;;;; EXPRESSED NOR IMPLIED WARRANTIES -  THIS INCLUDES, BUT 
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS			; OR BUSINESS INTERRUPTION)
+;;;; 
+;;;; For further details contact the authors of this software.
+;;;;
+;;;;  Jochen Schmidt        
+;;;;  Zuckmantelstr. 11     
+;;;;  91616 Neusitz         
+;;;;  GERMANY               
+;;;;
+;;;;
+
+(defpackage :acl-compat-mp
+  (:use :common-lisp)
+  (:export 
+   #:*current-process*         ;*
+   #:process-kill              ;*
+   #:process-preset            ;*
+   #:process-name              ;*
+
+   #:process-wait-function
+   #:process-run-reasons 
+   #:process-arrest-reasons
+   #:process-whostate
+   #:without-interrupts
+   #:process-wait
+   #:process-enable
+   #:process-disable
+   #:process-reset
+   #:process-interrupt
+   
+   #:process-run-function      ;*
+   #:process-property-list     ;*
+   #:without-scheduling        ;*
+   #:process-allow-schedule    ;*
+   #:make-process              ;*
+   #:process-add-run-reason    ;*
+   #:process-revoke-run-reason ;*
+   #:process-add-arrest-reason    ;*
+   #:process-revoke-arrest-reason ;*
+   #:process-allow-schedule    ;*
+   #:with-timeout              ;*
+   #:make-process-lock         ;*
+   #:with-process-lock         ;*
+   #:process-active-p          ; required by webactions
+   #:current-process
+   #:process-name-to-process
+   #:process-wait-with-timeout
+   #:wait-for-input-available
+   )
+  (:nicknames :acl-mp))
+
+;; * marked ones are used in Portable Allegroserve

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-socket-corman.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,194 @@
+;;;; ACL socket wrapper library for Corman Lisp - Version 1.1
+;;;;
+;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
+;;;; 
+;;;; License
+;;;; =======
+;;;; This software is provided 'as-is', without any express or implied
+;;;; warranty. In no event will the author be held liable for any damages
+;;;; arising from the use of this software.
+;;;;
+;;;; Permission is granted to anyone to use this software for any purpose,
+;;;; including commercial applications, and to alter it and redistribute
+;;;; it freely, subject to the following restrictions:
+;;;;
+;;;; 1. The origin of this software must not be misrepresented; you must
+;;;;    not claim that you wrote the original software. If you use this
+;;;;    software in a product, an acknowledgment in the product documentation
+;;;;    would be appreciated but is not required.
+;;;;
+;;;; 2. Altered source versions must be plainly marked as such, and must
+;;;;    not be misrepresented as being the original software.
+;;;;
+;;;; 3. This notice may not be removed or altered from any source 
+;;;;    distribution.
+;;;;
+;;;; Notes
+;;;; =====
+;;;; A simple wrapper around the SOCKETS package to present an interface
+;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package
+;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET
+;;;; package see:
+;;;;
+;;;;   http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm
+;;;;
+;;;; More recent versions of this software may be available at:
+;;;;   http://www.double.co.nz/cl
+;;;;
+;;;; Comments, suggestions and bug reports to the author, 
+;;;; Christopher Double, at: chris at double.co.nz
+;;;;
+;;;; 17/09/2000 - 1.0 
+;;;;              Initial release.
+;;;;
+;;;; 20/09/2000 - 1.1
+;;;;              Added SOCKET-CONTROL function.
+;;;;
+;;;; 27/02/2001 - 1.2
+;;;;              Added ability to create SSL sockets. Doesn't use
+;;;;              same interface as Allegro 6 - need to look into
+;;;;              how that works.
+;;;;
+;;;; 03/01/2003 - 1.3
+;;;;              Added to PortableAllegroServe.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sockets)
+  (require :ssl-sockets))
+
+(sockets:start-sockets)
+(ssl-sockets:start-ssl-sockets)
+
+(defpackage socket
+  (:use "COMMON-LISP")
+  (:export 
+		"MAKE-SOCKET"
+		"ACCEPT-CONNECTION"
+		"DOTTED-TO-IPADDR"
+		"IPADDR-TO-DOTTED"
+		"IPADDR-TO-HOSTNAME"
+		"LOOKUP-HOSTNAME"
+		"REMOTE-HOST"
+		"LOCAL-HOST"
+		"LOCAL-PORT"
+		"SOCKET-CONTROL"
+		))
+
+(in-package :socket)
+
+(defmethod accept-connection ((server-socket sockets::server-socket)
+			      &key (wait t))
+	(unless wait
+		(error "WAIT keyword to ACCEPT-CONNECTION not implemented."))
+	(sockets:make-socket-stream 
+		(sockets:accept-socket server-socket)))
+
+(defun make-socket (&key 
+        (remote-host "0.0.0.0") ;;localhost?
+		type
+		local-port
+		remote-port 
+		(connect :active)
+		(format :text)
+		ssl
+        &allow-other-keys)
+    (check-type remote-host string)
+	(when (eq type :datagram)
+		(error ":DATAGRAM keyword to MAKE-SOCKET not implemented."))
+	(when (eq format :binary)
+		(warn ":BINARY keyword to MAKE-SOCKET partially implemented."))
+	
+	(ecase connect
+		(:passive
+			(sockets:make-server-socket 
+				:host remote-host
+				:port local-port))
+		(:active			
+			(sockets:make-socket-stream
+				(if ssl
+					(ssl-sockets:make-client-ssl-socket
+						:host remote-host
+						:port remote-port)
+					(sockets:make-client-socket
+						:host remote-host
+						:port remote-port))))))
+					
+
+(defun dotted-to-ipaddr (dotted &key errorp)
+	(when errorp
+		(warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported."))
+	(sockets:host-to-ipaddr dotted))
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+	(when values
+		(error ":VALUES keyword to IPADDR-TO-DOTTED not supported."))
+	(sockets:ipaddr-to-dotted ipaddr))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+	(when ignore-cache
+		(warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
+	(sockets:ipaddr-to-name ipaddr))
+
+(defun lookup-hostname (host &key ignore-cache)
+	(when ignore-cache
+		(warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
+	(if (stringp host)
+		(sockets:host-to-ipaddr host)
+		(dotted-to-ipaddr (ipaddr-to-dotted host))))	
+
+(defun remote-host (socket-or-stream)
+	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+					socket-or-stream
+					(sockets:stream-socket-handle socket-or-stream))))
+		(sockets::remote-socket-ipaddr socket)))
+
+(defun local-host (socket-or-stream)
+	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+					socket-or-stream
+					(sockets:stream-socket-handle socket-or-stream))))
+        (if (not (typep socket 'sockets:local-socket))
+            16777343
+            (sockets::socket-host-ipaddr socket))))
+
+(defun local-port (socket-or-stream)
+	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
+					socket-or-stream
+					(sockets:stream-socket-handle socket-or-stream))))
+		(sockets:socket-port socket)))
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+	(declare (ignore stream output-chunking output-chunking-eof input-chunking))
+	(warn "SOCKET-CONTROL function not implemented."))
+
+;; Some workarounds to get combined text/binary socket streams working
+(defvar old-read-byte #'cl::read-byte)
+
+(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil))
+	"Replacement for Corman Lisp READ-BYTE to work with socket streams correctly."
+	(if (eq (cl::stream-subclass stream) 'sockets::socket-stream)
+        (char-int (read-char stream eof-error-p eof-value))
+		(funcall old-read-byte stream eof-error-p eof-value)))
+
+(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte)
+
+(in-package :cl)
+
+(defun write-sequence (sequence stream &key start end)
+	(let ((element-type (stream-element-type stream))
+			(start (if start start 0))
+			(end (if end end (length sequence))))
+		(if (eq element-type 'character)
+			(do ((n start (+ n 1)))
+				((= n end))
+				(write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream))
+			(do ((n start (+ n 1)))
+				((= n end))
+				(write-byte (elt sequence n) stream))))		;; recoded to avoid LOOP, because it isn't loaded yet
+			;(loop for n from start below end do
+			;	(write-char (elt sequence n) stream))
+			;(loop for n from start below end do
+			;	(write-byte (elt sequence n) stream))
+	(force-output stream))
+
+(provide 'acl-socket)
+

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl-streams.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,293 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;
+;;; Filename:    gray-streams-integration.lisp
+;;; Author:      Jochen Schmidt <jsc at dataheaven.de>
+;;; Description: Integrate ssl-sockets with the lisp
+;;;              stream system using gray-streams.
+;;;              
+
+(in-package :ssl)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Gray Streams integration ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass ssl-stream-mixin ()
+  ((ssl-socket :accessor ssl-socket :initarg :ssl-socket)))
+
+(defclass binary-ssl-stream 
+          (ssl-stream-mixin
+           gray-stream:fundamental-binary-input-stream
+           gray-stream:fundamental-binary-output-stream)
+  ())
+
+(defclass character-ssl-stream
+          (ssl-stream-mixin
+           gray-stream:fundamental-character-input-stream
+           gray-stream:fundamental-character-output-stream)
+  ())
+
+(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream binary-ssl-stream))
+  '(unsigned-byte 8))
+
+(defmethod #-cormanlisp gray-stream::stream-element-type #+cormanlisp gray-stream::stream-stream-element-type ((socket-stream character-ssl-stream))
+  'character)
+
+(defmethod gray-stream:stream-line-column ((socket-stream character-ssl-stream))
+  nil)
+
+(defmethod gray-stream:stream-line-column ((socket-stream binary-ssl-stream))
+  nil)
+
+(defmethod gray-stream:stream-listen ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (> (ssl-internal:ssl-pending (ssl-internal:ssl-socket-handle ssl-socket)) 0)))
+
+(defmethod gray-stream:stream-read-byte ((socket-stream binary-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-read-byte ssl-socket)))
+
+(defmethod gray-stream:stream-write-byte ((socket-stream binary-ssl-stream) byte)
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-write-byte byte ssl-socket)))
+
+#|
+(defmethod gray-stream:stream-read-char ((socket-stream character-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-read-char ssl-socket)))
+
+(defmethod gray-stream:stream-read-char ((socket-stream binary-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-read-char ssl-socket)))
+|#
+
+; Bivalent
+(defmethod gray-stream:stream-read-char ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-read-char ssl-socket)))
+
+
+(defmethod gray-stream:stream-read-char-no-hang ((socket-stream character-ssl-stream))
+  (when (listen socket-stream)
+    (with-slots (ssl-socket) socket-stream
+      (ssl-internal:ssl-socket-read-char ssl-socket))))
+
+#|
+(defmethod gray-stream:stream-write-char ((socket-stream character-ssl-stream) char)
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-write-char char ssl-socket)))
+
+(defmethod gray-stream:stream-write-char ((socket-stream binary-ssl-stream) char)
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-write-char char ssl-socket)))
+|#
+
+; Bivalent
+(defmethod gray-stream:stream-write-char ((socket-stream ssl-stream-mixin) char)
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:ssl-socket-write-char char ssl-socket)))
+
+
+
+; Bivalent
+(defmethod gray-stream:stream-force-output ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-finish-output ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-clear-output ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (with-slots (ssl-internal::output-offset) ssl-socket
+      (setf ssl-internal::output-offset 0))))
+
+(defmethod gray-stream:stream-clear-input ((socket-stream ssl-stream-mixin))
+  (with-slots (ssl-socket) socket-stream
+    (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
+      (setf ssl-internal::input-avail 0)
+      (setf ssl-internal::input-offset 0))))
+
+(defmethod #-cormanlisp common-lisp:close #+cormanlisp gray-stream:stream-close ((socket-stream ssl-stream-mixin) &key abort)
+  (with-slots (ssl-socket) socket-stream
+    (unless abort
+      (ssl-internal:flush-output-buffer ssl-socket))
+    (ssl-internal:close-ssl-socket ssl-socket)))
+
+#|
+(defmethod gray-stream:stream-force-output ((socket-stream character-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-finish-output ((socket-stream character-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (ssl-internal:flush-output-buffer ssl-socket)))
+
+(defmethod gray-stream:stream-clear-output ((socket-stream character-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (with-slots (ssl-internal::output-offset) ssl-socket
+      (setf ssl-internal::output-offset 0))))
+
+(defmethod gray-stream:stream-clear-input ((socket-stream character-ssl-stream))
+  (with-slots (ssl-socket) socket-stream
+    (with-slots (ssl-internal::input-avail ssl-internal::input-offset) ssl-socket
+      (setf ssl-internal::input-avail 0)
+      (setf ssl-internal::input-offset 0))))
+
+(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+    (loop for i upfrom start
+          repeat chars
+          for char = (progn ;(format t "Read char on index ~A~%" i)
+                       ;(force-output t)
+                       (let ((c (gray-streams:stream-read-char socket-stream)))
+                         ;(format t "The element read was ~A~%" c) 
+			 c))
+          if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
+                                 ;(force-output t)
+                                 (return-from gray-streams:stream-read-sequence i))
+          do (setf (elt sequence i) char))
+    ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+    (+ start chars)))
+
+|#
+
+;;
+;; Why this argument ordering in CMUCL? LW has (stream sequence start end)
+;; It would be interesting to know why it is a particular good idea to
+;; reinvent APIs every second day in an incompatible way.... *grrr*
+;;
+
+#+cmu
+(defmethod gray-stream:stream-read-sequence ((socket-stream character-ssl-stream) (sequence sequence) &optional start end)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    (loop for i upfrom start
+          repeat chars
+          for char = (gray-stream:stream-read-char socket-stream)
+          if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
+          do (setf (elt sequence i) char))
+    (+ start chars)))
+
+#+cmu
+(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) (sequence sequence) &optional start end)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    (loop for i upfrom start
+          repeat chars
+          for char = (gray-stream:stream-read-byte socket-stream)
+          if (eq char :eof) do (return-from gray-stream:stream-read-sequence i)
+          do (setf (elt sequence i) char))
+    (+ start chars)))
+
+#|
+(defmethod gray-stream:stream-read-sequence ((socket-stream binary-ssl-stream) sequence start end)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    ;(format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+    (loop for i upfrom start
+          repeat chars
+          for char = (progn ;(format t "Read char on index ~A~%" i)
+                       ;(force-output t)
+                       (let ((c (gray-streams:stream-read-byte socket-stream)))
+                         ;(format t "The element read was ~A~%" c) 
+			 c))
+          if (eq char :eof) do (progn ;(format t "premature return on index ~A~%" i)
+                                 ;(force-output t)
+                                 (return-from gray-streams:stream-read-sequence i))
+          do (setf (elt sequence i) char))
+    ;(format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+    (+ start chars)))
+|#
+
+#| Alternative implementation?
+(defmethod stream:stream-read-sequence ((socket-stream character-ssl-stream) sequence start end)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    (format t "Read ~A chars from index ~A on.~%" chars start) (force-output t)
+    (loop for i upfrom start
+          repeat chars
+          for char = (progn (format t "Read char on index ~A~%" i)
+                       (force-output t)
+                       (let ((c (stream:stream-read-char socket-stream)))
+                         (format t "The element read was ~A~%" c) c))
+          if (eq char :eof) do (progn (format t "premature return on index ~A~%" i)
+                                 (force-output t)
+                                 (return-from stream:stream-read-sequence i))
+          do (setf (elt sequence i) char))
+    (format t "Normal return on index ~A~%" (+ start chars)) (force-output t)
+    (+ start chars)))
+|#
+
+#|
+(defmethod common-lisp:close ((socket-stream character-ssl-stream) &key abort)
+  (with-slots (ssl-socket) socket-stream
+    (unless abort
+      (ssl-internal:flush-output-buffer ssl-socket))
+    (ssl-internal:close-ssl-socket ssl-socket)))
+|#
+
+#+lispworks
+(declaim (inline %reader-function-for-sequence))
+#+lispworks
+(defun %reader-function-for-sequence (sequence)
+  (typecase sequence
+    (string #'read-char)
+    ((array unsigned-byte (*)) #'read-byte)
+    ((array signed-byte (*)) #'read-byte)
+    (otherwise #'read-byte)))
+
+#+lispworks
+(declaim (inline %writer-function-for-sequence))
+#+lispworks
+(defun %writer-function-for-sequence (sequence)
+  (typecase sequence
+    (string #'write-char)
+    ((array unsigned-byte (*)) #'write-byte)
+    ((array signed-byte (*)) #'write-byte)
+    (otherwise #'write-byte)))
+
+;; Bivalent socket support for READ-SEQUENCE / WRITE-SEQUENCE
+#+lispworks
+(defmethod gray-stream:stream-read-sequence ((stream ssl-stream-mixin) sequence start end)
+  (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+#+lispworks
+(defmethod gray-stream:stream-write-sequence ((stream ssl-stream-mixin) sequence start end)
+  (stream::write-elements stream sequence start end (typecase sequence
+                                                      (string t)
+                                                      ((array unsigned-byte (*)) nil)
+                                                      ((array signed-byte (*)) nil)
+                                                      (otherwise nil))))
+
+#+lispworks
+(in-package :acl-socket)
+
+#+lispworks
+(defmethod remote-host ((socket ssl::ssl-stream-mixin))
+  (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket))))
+
+#+lispworks
+(defmethod remote-port ((socket ssl::ssl-stream-mixin))
+  (multiple-value-bind (host port)
+      (comm:get-socket-peer-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+    (declare (ignore host))
+    port))
+
+#+lispworks
+(defmethod local-host ((socket ssl::ssl-stream-mixin))
+  (multiple-value-bind (host port)
+      (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+    (declare (ignore port))
+    host))
+
+#+lispworks
+(defmethod local-port ((socket ssl::ssl-stream-mixin))
+  (multiple-value-bind (host port)
+      (comm:get-socket-address (ssl-internal::ssl-socket-fd (ssl::ssl-socket socket)))
+    (declare (ignore host))
+    port))
+    

Added: branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/acl-ssl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,58 @@
+(in-package :ssl)
+;;;;;;;;;;;;;;;;;;;;;
+;;; ACL style API ;;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod make-ssl-client-stream ((socket integer) &rest options)
+  (destructuring-bind (&key (format :binary)) options
+    (when (minusp socket)
+      (error "not a proper socket descriptor"))
+    (let ((ssl-socket (make-instance 'ssl-internal:ssl-client-socket :fd socket)))
+      (case format
+        (:binary (make-instance 'binary-ssl-stream 
+                                :ssl-socket ssl-socket))
+        (:text (make-instance 'character-ssl-stream
+                              :ssl-socket ssl-socket))
+        (otherwise (error "Unknown ssl-stream format"))))))
+
+#+lispworks
+(defmethod make-ssl-client-stream ((lw-socket-stream comm:socket-stream) &rest options)
+  (apply #'make-ssl-client-stream (comm:socket-stream-socket lw-socket-stream) options))
+
+#+cormanlisp
+(defmethod make-ssl-client-stream (stream  &rest options)
+  (apply #'make-ssl-client-stream (sockets:socket-descriptor (cl::stream-handle stream)) options))
+
+(defmethod make-ssl-server-stream ((socket integer) &rest options)
+  (destructuring-bind (&key certificate key other-certificates (format :binary)) options
+    (when (minusp socket)
+      (error "not a proper socket descriptor"))
+        (let ((ssl-socket (make-instance 'ssl-internal:ssl-server-socket
+                                         :fd socket
+                                         :rsa-privatekey-file (or key certificate)
+                                         :certificate-file (or certificate key))))
+      (case format
+        (:binary (make-instance 'binary-ssl-stream 
+                                :ssl-socket ssl-socket))
+        (:text (make-instance 'character-ssl-stream
+                              :ssl-socket ssl-socket))
+        (otherwise (error "Unknown ssl-stream format"))))))
+
+(defmethod make-ssl-server-stream ((socket ssl-stream-mixin) &rest options)
+  (warn "SSL socket ~A reused" socket)
+  socket)
+
+#+lispworks
+(defmethod make-ssl-server-stream ((lw-socket-stream comm:socket-stream) &rest options)
+  (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options))
+
+
+#+ignore
+(defmethod make-ssl-server-stream ((acl-socket acl-socket::server-socket) &rest options)
+  (apply #'make-ssl-server-stream 
+         (comm::get-fd-from-socket (acl-socket::passive-socket acl-socket)) options))
+
+#+ignore
+(defmethod make-ssl-server-stream ((lw-socket-stream acl-socket::chunked-socket-stream) &rest options)
+  (apply #'make-ssl-server-stream (comm:socket-stream-socket lw-socket-stream) options))
+

Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,3 @@
+;;;; ACL-COMPAT - EXCL
+;;;;
+;;;; Nothing needs to be done

Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,3 @@
+;;; This file implements the process functions for AllegroServe in MCL.
+
+(in-package :acl-compat.mp)

Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,6 @@
+;;; Allegro layer for ACL sockets.
+;;;
+(in-package :acl-compat.socket)
+
+
+

Added: branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/allegro/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,4 @@
+;;; Allegro System Package Compatibility file
+
+;;; Nothing to do
+(in-package :acl-compat.system)

Added: branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/chunked-stream-mixin.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,275 @@
+;;;;										;
+;;;; (c) 2002 by Jochen Schmidt.
+;;;;
+;;;; File:            chunked-stream-mixin.lisp
+;;;; Revision:        0.1
+;;;; Description:     ACL style HTTP1.1 I/O chunking
+;;;; Date:            08.04.2002
+;;;; Authors:         Jochen Schmidt
+;;;; Tel:             (+49 9 11) 47 20 603
+;;;; Email:           jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer in the
+;;;;    documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER 
+;;;; EXPRESSED NOR IMPLIED WARRANTIES -  THIS INCLUDES, BUT 
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION)
+;;;; 
+;;;; For further details contact the authors of this software.
+;;;;
+;;;;  Jochen Schmidt        
+;;;;  Zuckmantelstr. 11     
+;;;;  91616 Neusitz         
+;;;;  GERMANY               
+;;;;
+;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt
+;;;;
+
+(in-package :de.dataheaven.chunked-stream-mixin)
+
+(defun buffer-ref (buffer index)
+  #+lispworks (schar buffer index)
+  #-lispworks (aref buffer index))
+
+(defun (setf buffer-ref) (new-value buffer index)
+  #-lispworks (setf (aref buffer index) (char-code new-value))
+  #+lispworks (setf (schar buffer index) new-value))
+
+(defclass chunked-stream-mixin ()
+  ((output-chunking-p :initform nil :accessor output-chunking-p)
+   (chunk-input-avail :initform nil
+                      :documentation
+                      "Number of octets of the current chunk that are
+not yet read into the buffer, or nil if input chunking is disabled")
+   (real-input-limit :initform 0
+                     :documentation
+                     "Index of last octet read into buffer
+(input-limit points to index of last octet in the current chunk)")))
+
+(defgeneric input-chunking-p (stream))
+(defmethod input-chunking-p ((stream chunked-stream-mixin))
+  (not (null (slot-value stream 'chunk-input-avail))))
+
+(defgeneric (setf input-chunking-p) (new-value stream))
+(defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin))
+  (setf (slot-value stream 'chunk-input-avail) (and new-value 0)))
+
+(define-condition acl-compat.excl::socket-chunking-end-of-file (condition)
+  ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments)
+   (acl-compat.excl::format-control :initform "A chunking end of file occured"
+                                    :initarg :format-control)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; Input chunking ;;;
+;;;;;;;;;;;;;;;;;;;;;;
+
+;; Input chunking is not tested so far!
+
+(defgeneric initialize-input-chunking (stream))
+(defmethod initialize-input-chunking ((stream chunked-stream-mixin))
+  "This method initializes input chunking. The real-input-limit is nil
+in the beginnings because it got not saved yet. Chunk-input-avail is
+obviously 0 because no chunk-data got read so far."
+  (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit)
+      stream
+    (with-slots (real-input-limit chunk-input-avail) stream
+      (setf
+       ;; Bytes read from stream (valid data in buffer up to here)
+       real-input-limit input-limit
+       ;; Bytes available in current chunk block after buffer contents
+       ;; runs out (trivially zero before first chunk block read)
+       chunk-input-avail 0
+       ;; Last buffer position that can be read before new data has to
+       ;; be fetched from stream (we must begin with parsing a chunk
+       ;; immediately; hence set to a value that guarantees this)
+       input-limit 0                    ; or input-index?
+       ))))
+
+;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28)
+#+lispworks
+(defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body)
+  `(with-slots ((,input-buffer stream::input-buffer)
+                (,input-index stream::input-index)
+                (,input-limit stream::input-limit))
+      (slot-value ,stream 'stream::buffer-state)
+    , at body))
+
+(defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin))
+  "Refill buffer from stream."
+  ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no
+  ;; more data (the index is bigger than the limit). We call out to
+  ;; the real buffer filling mechanism by calling the next specialized
+  ;; method. This method is responsible to update the buffer state in
+  ;; coordination with the chunk-header.
+  (with-slots (chunk-input-avail real-input-limit) stream
+    (#-lispworks gray-stream:with-stream-input-buffer
+     #+lispworks %with-stream-input-buffer
+     (input-buffer input-index input-limit) stream
+       (labels
+          ((pop-char ()
+             (when (and (>= input-index input-limit) ; need new data
+                        (not (call-next-method))) ; couldn't get it
+               (error "Unexpected end-of-file while reading chunk block"))
+             (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index))
+                    #+lispworks (buffer-ref input-buffer input-index)
+                    (incf input-index)))
+           (read-chunk-header ()
+             (let ((chunk-length 0))
+               (tagbody
+                initial-crlf (let ((char (pop-char)))
+                               (cond ((digit-char-p char 16)
+                                      (decf input-index) ; unread char
+                                      (go chunk-size))
+                                     ((eq #\Return char)
+                                      (if (eq (pop-char) #\Linefeed)
+                                          (go chunk-size)
+                                        (error "End of chunk-header corrupted: Expected Linefeed")))
+                                     (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit"))))
+
+                chunk-size (let ((char (pop-char)))
+                             (cond ((digit-char-p char 16)
+                                    (setf chunk-length
+                                          (+ (* 16 chunk-length)
+                                             (digit-char-p char 16)))
+                                    (go chunk-size))
+                                   (t (decf input-index) ; unread char
+                                      (go skip-rest))))
+
+                skip-rest (if (eq #\Return (pop-char))
+                              (go check-linefeed)
+                            (go skip-rest))
+
+                check-linefeed (let ((char (pop-char)))
+                                 (case char
+                                   (#\Linefeed (go accept))
+                                   (t (error "End of chunk-header corrupted: LF expected, ~A read." char))))
+
+                accept)
+               chunk-length)))
+
+         (cond ((not (input-chunking-p stream))
+                ;; Chunking not active; just fill buffer normally
+                (call-next-method))
+               ((zerop chunk-input-avail)
+                ;; We are at the beginning of a new chunk.
+                (when real-input-limit (setf input-limit real-input-limit))
+                (let* ((chunk-length (read-chunk-header))
+                       (end-of-chunk (+ input-index chunk-length)))
+                  (if (zerop chunk-length)
+                      ;; rfc2616 indicates that input chunking is
+                      ;; turned off after zero-length chunk is read
+                      ;; (see section 19.4.6) -- turn off chunking
+                      (progn (signal 'acl-compat.excl::socket-chunking-end-of-file
+                                     :format-arguments stream)
+                             (setf (input-chunking-p stream) nil)
+                             ;; TODO: whoever handles
+                             ;; socket-chunking-end-of-file (client.cl
+                             ;; in AllegroServe's case) should read the
+                             ;; trailer (see section 3.6).  All we can
+                             ;; reasonably do here is turn off
+                             ;; chunking, or throw information away.
+                             )
+                    ;; Now set up stream attributes so that read methods
+                    ;; call refill-buffer both at end of chunk and end of
+                    ;; buffer
+                    (progn
+                      (setf real-input-limit input-limit
+                            input-limit (min real-input-limit end-of-chunk)
+                            chunk-input-avail (max 0 (- end-of-chunk
+                                                        real-input-limit)))
+                      input-limit))))
+               (t
+                ;; We are in the middle of a chunk; re-fill buffer
+                (if (call-next-method)
+                    (progn
+                      (setf real-input-limit input-limit)
+                      (setf input-limit
+                            (min real-input-limit chunk-input-avail))
+                      (setf chunk-input-avail
+                            (max 0 (- chunk-input-avail real-input-limit)))
+                      input-limit)
+                    (error "Unexpected end-of-file in the middle of a chunk"))))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;;; Output chunking ;;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This constant is the amount of bytes the system reserves for the chunk-header
+;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed
+;; by a LF
+(defconstant +chunk-header-buffer-offset+ 6)
+
+(defgeneric initialize-output-chunking (stream))
+(defmethod initialize-output-chunking ((stream chunked-stream-mixin))
+  "This method initializes output chunking. Actual contents in the output-buffer
+   get flushed first. A chunk has a header at the start and a CRLF at the end.
+   The header is the length of the (data) content in the chunk as a string in hexadecimal
+   digits and a trailing CRLF before the real content begins. We assume that the content
+   of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning
+   of the buffer for the header. We reduce the buffer limit by 2 so that we have always
+   room left in the buffer to attach a CRLF."
+  (unless (output-chunking-p stream)
+    (force-output stream)
+    (gray-stream:with-stream-output-buffer (buffer index limit) stream
+      (setf index +chunk-header-buffer-offset+)
+      (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return
+            (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed)
+      (decf limit 2)
+      (setf (output-chunking-p stream) t))))
+
+(defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin))
+  "When there is pending content in the output-buffer then compute the chunk-header and flush
+   the buffer"
+  (if (output-chunking-p stream)
+      (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream
+        (when (> output-index +chunk-header-buffer-offset+)
+          (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+)))
+                 (start (- +chunk-header-buffer-offset+ 2 (length chunk-header))))
+            (loop for c across chunk-header
+                  for i upfrom start
+                  do (setf (buffer-ref output-buffer i) c))
+            (setf (buffer-ref output-buffer output-index) #\Return
+                  (buffer-ref output-buffer (1+ output-index)) #\Linefeed)
+            (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2))
+            (setf output-index +chunk-header-buffer-offset+))))
+    (call-next-method)))
+
+
+(defmethod close ((stream chunked-stream-mixin) &key abort)
+  (unless abort
+    (disable-output-chunking stream))
+  (call-next-method))
+
+
+(defgeneric disable-output-chunking (stream))
+(defmethod disable-output-chunking ((stream chunked-stream-mixin))
+  "When we disable chunking we first try to write out a last pending chunk and after that
+   reset the buffer-state to normal mode. To end the game we write out a chunk-header with
+   a chunk-size of zero to notify the peer that chunking ends."
+  (when (output-chunking-p stream)
+    (force-output stream)
+    (gray-stream:with-stream-output-buffer (buffer index limit) stream
+      (setf index 0)
+      (incf limit 2))
+    (setf (output-chunking-p stream) nil
+          (input-chunking-p stream) nil)
+    (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed)
+    (force-output stream)))
+
+
+
+

Added: branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/chunked.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,211 @@
+;;;
+;;; Streams with support for "chunked" transfer coding.  This module
+;;; emulates the support for chunking found in Allegro Common Lisp's
+;;; streams.  See RFC 2616 for a description of the "chunked" transfer
+;;; coding.
+;;;
+;;; TODO:
+;;;  - 
+
+(defpackage :com.ljosa.chunked
+  (:use :common-lisp #+LISPWORKS :stream)
+  (:export :chunked-mixin :make-chunked-stream :*buffer-size* 
+           :output-chunking :input-chunking :close-chunk))
+
+(in-package :com.ljosa.chunked)
+
+(defparameter *buffer-size* 1024 "Maximum chunk size")
+
+(defvar *recursive* nil)
+
+(defclass chunked-mixin ()
+  ((output-chunking :initform nil :accessor output-chunking)
+   (input-chunking :initform nil :accessor input-chunking)
+   (output-buffer)
+   (remaining-input :initform nil)))
+
+(defmethod shared-initialize :after ((stream chunked-mixin) slots-for-initform
+				     &rest initargs)
+  (declare (ignore initargs slots-for-initform))
+  (with-slots (output-buffer) stream
+    (setf output-buffer (make-array (list *buffer-size*)
+				    :element-type 'unsigned-byte
+				    :fill-pointer 0))))
+
+(define-condition excl::socket-chunking-end-of-file (condition)
+  ((excl::format-arguments :initform nil)
+   (excl::format-control :initform "~1@<The stream ~s had a chunking end of file~:@>")))
+
+;; (defmethod stream-element-type ((stream chunked-mixin))
+;;  (call-next-method))
+
+(defun read-chunk-header (stream &aux (x 0) (*recursive* t))
+  (tagbody
+   s0 (let ((char (read-char stream)))
+        (cond ((digit-char-p char 16) (setf x (+ (* 16 x) (digit-char-p char 16)))
+                                      (go s0))
+              ((eq #\; char) (go s1))
+              ((eq #\; char) (go s2))
+              (t (error "Parse error in state s0: ~S." char))))
+   s1 (if (eq #\Return (read-char stream))
+          (go s2)
+        (go s1))
+   s2 (let ((char (read-char stream)))
+        (case char
+          (#\Linefeed (go accept))
+          (t (error "Parse error in state s2: ~S." char))))
+   accept)
+  x)
+
+;; FIXME: What do do when the chunked input stream can't be parsed?
+
+(defun gobble-crlf (stream &aux (*recursive* t))
+  (flet ((expect (expected-char)
+	   (let ((char (read-char stream)))
+	     (unless (eq expected-char char)
+	       (error "Expected ~C, got ~C." expected-char char)))))
+    (expect #\Return)
+    (expect #\Linefeed)))
+
+(defmethod stream-read-char ((stream chunked-mixin))
+  (with-slots (input-chunking remaining-input output-chunking) stream
+    (cond (*recursive* (call-next-method))
+          ((not input-chunking) (call-next-method))
+          ((not remaining-input) (handler-case 
+                                     (progn
+                                       (setf remaining-input (read-chunk-header stream))
+                                       (stream-read-char stream))
+                                   (end-of-file () :eof)))
+          ((> remaining-input 0) (decf remaining-input)
+                                 (call-next-method))
+          ((zerop remaining-input) (handler-case
+                                       (progn
+					 (gobble-crlf stream)
+                                         (setf remaining-input (read-chunk-header stream))
+                                         (cond ((zerop remaining-input)
+						(setf input-chunking nil
+						      output-chunking nil)
+                                                (signal 'excl::socket-chunking-end-of-file :format-arguments stream)
+                                                :eof)
+                                               (t (stream-read-char stream))))
+                                     (end-of-file () :eof))))))
+
+(defmethod stream-unread-char ((stream chunked-mixin) character)
+  (with-slots (input-chunking remaining-input) stream
+      (cond (*recursive* (call-next-method))
+            (input-chunking (incf remaining-input)
+                            (call-next-method))
+            (t (call-next-method)))))
+
+(defmethod stream-read-line ((stream chunked-mixin))
+  (loop
+   with chars = nil
+   for char = (stream-read-char stream)
+   until (eq char #\Linefeed)
+   do
+   (if (eq char :eof)
+     (if (null chars)
+	 (error 'end-of-file :stream stream)
+	 (return (coerce chars 'string)))
+     (push char chars))
+   finally (return (coerce (nreverse chars) 'string))))
+
+(defmethod stream-read-sequence ((stream chunked-mixin) sequence start end)
+  (loop
+   for i from start below end
+   do
+   (let ((char (stream-read-char stream)))
+     (case char
+       (:eof (return i))
+       (t (setf (elt sequence i) char))))
+   finally (return i)))
+
+(defmethod stream-clear-input ((stream chunked-mixin))
+  (with-slots (input-chunking) stream
+    (cond (*recursive* (call-next-method))
+          (input-chunking nil)
+          (t (call-next-method)))))
+
+(defmethod stream-write-byte ((stream chunked-mixin) byte)
+  (check-type byte unsigned-byte)
+  (if *recursive*
+      (call-next-method)
+      (with-slots (output-buffer) stream
+	(or (vector-push byte output-buffer)
+	    (progn
+	      (stream-force-output stream)
+	      (stream-write-byte stream byte))))))
+
+(defmethod stream-write-char ((stream chunked-mixin) character)
+  (if *recursive*
+      (call-next-method)
+      (stream-write-byte stream (char-code character))))
+
+(defmethod stream-write-sequence ((stream chunked-mixin) sequence start end)
+  (loop
+   for i from start below end
+   do
+   (let ((e (elt sequence i)))
+     (etypecase e
+       (integer (stream-write-byte stream e))
+       (character (stream-write-char stream e))))))
+
+(defmethod stream-write-string ((stream chunked-mixin) string &optional
+				(start 0) (end (length string)))
+  (stream-write-sequence stream string start end))
+
+(defmethod write-crlf ((stream stream))
+  (let ((*recursive* t))
+    (write-char #\Return stream)
+    (write-char #\Linefeed stream)))
+
+(defmethod stream-force-output ((stream chunked-mixin))
+  (with-slots (output-chunking output-buffer) stream
+    (when (> (fill-pointer output-buffer) 0)
+      (let ((*recursive* t))
+	(when output-chunking
+	  (let ((*print-base* 16))
+	    (princ (fill-pointer output-buffer) stream))
+	  (write-crlf stream))
+	(write-sequence output-buffer stream)
+	(setf (fill-pointer output-buffer) 0)
+	(when output-chunking
+	  (write-crlf stream)))))
+  (call-next-method))
+
+(defmethod stream-finish-output ((stream chunked-mixin))
+  (unless *recursive*
+    (force-output stream))
+  (call-next-method))
+
+(defmethod stream-clear-output ((stream chunked-mixin))
+  (with-slots (output-chunking output-buffer) stream
+    (if (and output-chunking (not *recursive*))
+        (setf (fill-pointer output-buffer) 0)
+      (call-next-method))))
+
+(defmethod close ((stream chunked-mixin) &key abort)
+  (unless abort
+    (finish-output stream))
+  (with-slots (output-chunking output-buffer) stream
+    (when (and output-chunking
+	       (> (fill-pointer output-buffer) 0))
+      (close-chunk stream)))
+  (call-next-method))
+
+(defmethod close-chunk ((stream chunked-mixin))
+  (finish-output stream)
+  (with-slots (output-chunking input-chunking) stream
+    (if output-chunking
+	(let ((*recursive* t))
+	  (princ 0 stream)
+	  (write-crlf stream)
+	  (write-crlf stream)
+	  (finish-output stream)
+	  (setf output-chunking nil
+		input-chunking nil))
+	(error "Chunking is not enabled for output on this stream: ~S."
+	       stream))))
+
+(provide :com.ljosa.chunked)
+

Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,70 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun fixnump (x)
+  (sys::fixnump x))
+
+(defun stream-input-fn (stream)
+  stream)
+
+(defun filesys-type (file-or-directory-name)
+  ;; Taken from clocc's port library, with thanks to Sam Steingold
+  (if (values
+       (ignore-errors
+         (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
+                    file-or-directory-name)))
+      :directory
+      (if (probe-file file-or-directory-name)
+          :file
+          nil)))
+
+(defmacro atomically (&body forms)
+  ;; No multiprocessing here, move along...
+  `(progn , at forms))
+
+(defun unix-signal (signal pid)
+  (declare (ignore signal pid))
+  (error "clisp unix-signal not implemented yet."))
+
+(defmacro without-package-locks (&body forms)
+  `(ext:without-package-lock ,(list-all-packages) , at forms))
+
+(defun fixnump (x)
+  (sys::fixnump x))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+                         end mb-vector make-mb-vector?
+                         (external-format :default))
+  "This function returns a lisp-usb8-vector and the number of bytes copied."
+  (declare (ignore external-format))
+  ;; The end parameter is different in ACL's lambda list, but this
+  ;; variant lets us give an argument :end nil explicitly, and the
+  ;; right thing will happen
+  (unless end (setf end (length string)))
+  (let* ((number-of-octets (if null-terminate (1+ (- end start))
+                               (- end start)))
+         (mb-vector (cond
+                      ((and mb-vector (>= (length mb-vector) number-of-octets))
+                       mb-vector)
+                      ((or (not mb-vector) make-mb-vector?)
+                       (make-array (list number-of-octets)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element 0))
+                      (t (error "Was given a vector of length ~A, ~
+                                 but needed at least length ~A."
+                                (length mb-vector) number-of-octets)))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+    (loop for from-index from start below end
+       for to-index upfrom 0
+       do (progn
+            (setf (aref mb-vector to-index)
+                  (char-code (aref string from-index)))))
+    (when null-terminate
+      (setf (aref mb-vector (1- number-of-octets)) 0))
+    (values mb-vector number-of-octets)))

Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,74 @@
+;; Stubs for multiprocessing functions under clisp.  Clisp does not
+;; provide threads at the time of writing, so these functions are here
+;; only to compile aserve with a minimum of changes in the main code.
+;;
+;; Written by Rudi Schlatte
+
+
+(in-package :acl-compat-mp)
+
+(defvar *current-process*)
+
+(defun process-allow-schedule ()
+  (values))
+
+(defun process-allow-scheduling ()
+  (values))
+
+(defun process-plist (process)
+  (declare (ignore process))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun (setf process-plist) (new-value process)
+  (declare (ignore new-value process))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun process-run-reasons (process)
+  (declare (ignore process))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun (setf process-run-reasons) (new-value process)
+  (declare (ignore new-value process))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun process-revoke-run-reason (process object)
+  (declare (ignore process object))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun process-add-run-reason (process object)
+  (declare (ignore process object))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun process-run-function (name function &rest arguments)
+  (declare (ignore name function arguments))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun process-kill (process)
+  (declare (ignore process))
+  (error "Attempting to use multithreading with clisp."))
+
+(defmacro with-gensyms (syms &body body)
+  "Bind symbols to gensyms.  First sym is a string - `gensym' prefix.
+Inspired by Paul Graham, <On Lisp>, p. 145."
+  `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms)))
+    , at body))
+
+(defun interrupt-process (process function &rest args)
+  (declare (ignore process function args))
+  (error "Attempting to use multithreading with clisp."))
+
+(defun make-process-lock (&key name)
+  (declare (ignore name))
+  (error "Attempting to use multithreading with clisp."))
+
+(defmacro with-process-lock ((lock &key norecursive whostate timeout)
+			     &body forms)
+  (declare (ignore lock norecursive whostate timeout))
+  `(progn , at forms))
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  (declare (ignore seconds timeout-forms))
+  `(progn , at body))
+
+(defmacro without-scheduling (&body body)
+  `(progn , at body))

Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,174 @@
+;; This package is designed for clisp.  It implements the
+;; ACL-style socket interface on top of clisp.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package :acl-socket)
+
+(defclass server-socket ()
+  ((port :type fixnum
+	 :initarg :port
+	 :reader port)
+   (stream-type :type (member :text :binary :bivalent)
+                :initarg :stream-type
+                :reader stream-type
+                :initform (error "No value supplied for stream-type"))
+   (clisp-socket-server :initarg :clisp-socket-server
+                        :reader clisp-socket-server)))
+
+(defmethod print-object ((server-socket server-socket) stream)
+  (print-unreadable-object (server-socket stream :type t :identity nil)
+    (format stream "@port ~d" (port server-socket))))
+
+(defun %get-element-type (format)  
+  (ecase format
+    (:text 'character)
+    (:binary '(unsigned-byte 8))
+    (:bivalent '(unsigned-byte 8))) )
+
+(defgeneric accept-connection (server-socket &key wait))
+(defmethod accept-connection ((server-socket server-socket)
+			      &key (wait t))
+  "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+  (when (cond ((numberp wait)
+               (socket-wait (clisp-socket-server server-socket) wait))
+              (wait (socket-wait (clisp-socket-server server-socket)))
+              (t (socket-wait (clisp-socket-server server-socket) 0)))
+    (let ((stream (socket-accept (clisp-socket-server server-socket)
+                                 :element-type (%get-element-type 
+                                                 (stream-type server-socket))
+                                 )))
+      (if (eq (stream-type server-socket) :bivalent)
+          (make-bivalent-stream stream)
+          stream))))
+
+
+(defun make-socket (&key (remote-host "localhost")
+			 local-port
+			 remote-port 
+			 (connect :active)
+			 (format :text)
+			 &allow-other-keys)
+  "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive."
+  (check-type remote-host string)
+  (ecase connect 
+    (:passive
+      (make-instance 'server-socket
+                     :port local-port
+                     :clisp-socket-server (socket-server local-port)
+                     :stream-type format))
+    (:active
+      (let ((stream (socket-connect
+                      remote-port remote-host
+                      :element-type (%get-element-type format)
+                      )))
+        (if (eq format :bivalent)
+          (make-bivalent-stream stream)
+          stream)))))
+
+(defmethod close ((server-socket server-socket) &key abort)
+  "Kill a passive (listening) socket.  (Active sockets are actually
+streams and handled by their close methods."
+  (declare (ignore abort))
+  (socket-server-close (clisp-socket-server server-socket)))
+
+(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+		ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (if values
+	(values a b c d)
+      (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+                      (let ((pos2 (position #\Space str :start pos1)))
+                        (if (not pos2)
+                            (nreverse acc)
+                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                         acc))))))
+    (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (values (unsigned-byte 32)))
+		dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors 
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
+
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+  (posix::hostent-name (posix:resolve-host-ipaddr ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (car (posix::hostent-addr-list (posix:resolve-host-ipaddr host)))
+      (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-clisp-stream (stream))
+
+(defmethod get-clisp-stream ((stream gray-stream::native-lisp-stream-mixin))
+  (gray-stream::native-lisp-stream stream))
+
+(defmethod get-clisp-stream ((stream t))
+  (the stream stream))
+
+(defun remote-host (socket-stream)
+  (dotted-to-ipaddr
+   (nth-value 0 (socket-stream-peer (get-clisp-stream socket-stream) t))))
+
+(defun remote-port (socket-stream)
+  (nth-value 1 (socket-stream-peer (get-clisp-stream socket-stream) t)))
+
+(defun local-host (socket-stream)
+  (dotted-to-ipaddr
+   (nth-value 0 (socket-stream-local (get-clisp-stream socket-stream) t))))
+
+(defun local-port (socket-stream)
+  (nth-value 1 (socket-stream-local (get-clisp-stream socket-stream) t)))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+                          gray-stream::buffered-bivalent-stream)
+  ((plist :initarg :plist :accessor stream-plist)))
+
+
+(defun make-bivalent-stream (lisp-stream &key plist)
+  (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+  (when oc-p
+    (when output-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+          output-chunking))
+  (when output-chunking-eof
+    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+  (when ic-p
+    (when input-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+          input-chunking)))
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/clisp/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,22 @@
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+    (ext:without-package-lock ()
+      (let ((sys-package (find-package "SYSTEM")))
+        (export (list (intern "COMMAND-LINE-ARGUMENTS" sys-package)
+                      (intern "COMMAND-LINE-ARGUMENT" sys-package)
+                      (intern "REAP-OS-SUBPROCESS" sys-package))
+                sys-package))))
+
+(ext:without-package-lock ()
+  (defun sys:command-line-arguments ()
+    ext:*args*))
+
+(ext:without-package-lock ()
+  (defun sys:command-line-argument (n)
+    (nth n ext:*args*)))
+
+(ext:without-package-lock ()
+  (defun sys:reap-os-subprocess (&key (wait nil))
+    (declare (ignore wait))
+    nil))
+

Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,71 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+  stream)
+
+(defun filesys-type (file-or-directory-name)
+       (if (eq :directory (unix:unix-file-kind
+                           (namestring file-or-directory-name)))
+           :directory
+         (if (probe-file file-or-directory-name)
+             :file
+           nil)))
+
+(defmacro atomically (&body forms)
+  `(mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+  ;; fixxme: did I get the arglist right?  only invocation I have seen
+  ;; is (excl::unix-signal 15 0) in net.aserve:start
+  (unix:unix-kill pid signal))
+
+(defmacro without-package-locks (&body forms)
+  `(progn , at forms))
+
+(defun filesys-inode (path)
+  (multiple-value-bind (found ign inode)
+      (unix:unix-lstat path)
+    (if found
+        inode
+        (error "path ~s does not exist" path))))
+
+(defun cl-internal-real-time ()
+  (round (/ (get-internal-real-time) internal-time-units-per-second)))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+                         end mb-vector make-mb-vector?
+                         (external-format :default))
+  "This function returns a lisp-usb8-vector and the number of bytes copied."
+  (declare (ignore external-format))
+  ;; The end parameter is different in ACL's lambda list, but this
+  ;; variant lets us give an argument :end nil explicitly, and the
+  ;; right thing will happen
+  (unless end (setf end (length string)))
+  (let* ((number-of-octets (if null-terminate (1+ (- end start))
+                               (- end start)))
+         (mb-vector (cond
+                      ((and mb-vector (>= (length mb-vector) number-of-octets))
+                       mb-vector)
+                      ((or (not mb-vector) make-mb-vector?)
+                       (make-array (list number-of-octets)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element 0))
+                      (t (error "Was given a vector of length ~A, ~
+                                 but needed at least length ~A."
+                                (length mb-vector) number-of-octets)))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+    (loop for from-index from start below end
+       for to-index upfrom 0
+       do (progn
+            (setf (aref mb-vector to-index)
+                  (char-code (aref string from-index)))))
+    (when null-terminate
+      (setf (aref mb-vector (1- number-of-octets)) 0))
+    (values mb-vector number-of-octets)))

Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,170 @@
+;; This package is designed for cmucl.  It implements ACL-style
+;; multiprocessing on top of cmucl (basically, process run reasons and
+;; some function renames).
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks.
+
+(in-package :acl-compat.mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the CMU MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(mp:*current-process*
+                    ;; mp::process-preset
+                    mp::process-reset
+                    mp:process-interrupt
+                    mp::process-name
+                    mp::process-wait-function
+                    mp:process-run-reasons
+                    mp:process-add-run-reason
+                    mp:process-revoke-run-reason
+                    mp:process-arrest-reasons
+                    mp:process-add-arrest-reason
+                    mp:process-revoke-arrest-reason
+                    mp:process-whostate
+                ;    mp:without-interrupts
+                    mp:process-wait
+                    mp:with-timeout
+		    mp:without-scheduling
+		    mp:process-active-p 
+                    ))
+
+(export '(*current-process*
+          ;; process-preset
+          process-reset
+          process-interrupt
+          process-name
+          process-wait-function
+          process-whostate
+          process-wait
+          with-timeout
+          without-scheduling
+          process-run-reasons
+          process-add-run-reason
+          process-revoke-run-reason
+          process-arrest-reasons
+          process-add-arrest-reason
+          process-revoke-arrest-reason
+	  process-active-p
+          ))
+
+
+(defun process-allow-schedule ()
+  (mp:process-yield))
+
+(defvar *process-plists* (make-hash-table :test #'eq)
+  "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+  (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+  (setf (gethash process *process-plists*) new-value))
+
+#||
+
+;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim
+;;; Moore who added run reasons to cmucl's multithreading.  Left in
+;;; for the time being just in case someone wants to get acl-compat
+;;; running on older cmucl's.  Can be deleted safely.
+
+(defvar *process-run-reasons* (make-hash-table :test #'eq)
+  "maps processes to their run-reasons.
+See the functions process-run-reasons, (setf process-run-reasons),
+process-add-run-reason, process-revoke-run-reason.")
+
+(defun process-run-reasons (process)
+  (gethash process *process-run-reasons*))
+
+(defun (setf process-run-reasons) (new-value process)
+  (mp:without-scheduling
+   (prog1
+       (setf (gethash process *process-run-reasons*) new-value)
+     (if new-value
+         (mp:enable-process process)
+       (mp:disable-process process)))))
+
+(defun process-revoke-run-reason (process object)
+  (without-scheduling
+   (setf (process-run-reasons process)
+	 (remove object (process-run-reasons process))))
+  (when (and (eq process mp:*current-process*))
+    (mp:process-yield)))
+
+(defun process-add-run-reason (process object)
+  (setf (process-run-reasons process)
+        (pushnew object (process-run-reasons process))))
+||#
+
+(defun process-run-function (name-or-options preset-function
+                             &rest preset-arguments)
+  (let ((process (etypecase name-or-options
+                   (string (make-process :name name-or-options
+                                         :run-reasons '(t)))
+                   (list (apply #'make-process :run-reasons '(t)
+                                name-or-options)))))
+    (apply #'acl-mp::process-preset process preset-function preset-arguments)
+    process))
+
+(defun process-preset (process preset-function &rest arguments)
+  (mp:process-preset process
+                     #'(lambda ()
+                         (apply-with-bindings preset-function
+                                              arguments
+                                              (process-initial-bindings process)))))
+
+(defvar *process-initial-bindings* (make-hash-table :test #'eq))
+
+(defun process-initial-bindings (process)
+  (gethash process *process-initial-bindings*))
+
+(defun (setf process-initial-bindings) (bindings process)
+  (setf (gethash process *process-initial-bindings*) bindings))
+
+
+;;;                          ;;;
+;;; Contributed by Tim Moore ;;;
+;;;	                     ;;;
+(defun apply-with-bindings (function args bindings)
+  (if bindings
+      (progv
+	  (mapcar #'car bindings)
+	  (mapcar #'(lambda (binding)
+		      (eval (cdr binding)))
+                  bindings)
+	(apply function args))
+      (apply function args)))
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+                     arrest-reasons (priority 0) quantum resume-hook
+                     suspend-hook initial-bindings run-immediately)
+  (declare (ignore priority quantum reset-action resume-hook suspend-hook
+                   run-immediately))
+  (mp:make-process nil :name name
+                   :run-reasons run-reasons
+                   :arrest-reasons arrest-reasons
+                   :initial-bindings initial-bindings))
+
+(defun process-kill (process)
+  (mp:destroy-process process))
+
+
+(defun make-process-lock (&key name)
+  (mp:make-lock name))
+
+(defun process-lock (lock)
+  (mp::lock-wait lock (mp:process-whostate mp:*current-process*)))
+
+(defun process-unlock (lock)
+  (setf (mp::lock-process lock) nil))
+
+
+(defmacro with-process-lock ((lock &key norecursive whostate timeout) &body forms)
+  (declare (ignore norecursive))
+  `(mp:with-lock-held (,lock
+		  ,@(when whostate (list :whostate whostate))
+		  ,@(when timeout (list :timeout timeout)))
+    , at forms))

Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,208 @@
+;; This package is designed for cmucl.  It implements the
+;; ACL-style socket interface on top of cmucl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package acl-compat.socket)
+
+(defclass socket ()
+  ((fd :type fixnum
+       :initarg :fd
+       :reader fd)))
+
+(defmethod print-object ((socket socket) stream)
+  (print-unreadable-object (socket stream :type t :identity t)
+    (format stream "@~d" (fd socket))))
+
+(defclass server-socket (socket)
+  ((element-type :type (member signed-byte unsigned-byte base-char)
+		 :initarg :element-type
+		 :reader element-type
+                 :initform (error "No value supplied for element-type"))
+   (port :type fixnum
+	 :initarg :port
+	 :reader port
+         :initform (error "No value supplied for port"))
+   (stream-type :type (member :text :binary :bivalent)
+                :initarg :stream-type
+                :reader stream-type
+                :initform (error "No value supplied for stream-type"))))
+
+#+cl-ssl
+(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream)
+                                   &rest options)
+  (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options))
+
+(defmethod print-object ((socket server-socket) stream)
+  (print-unreadable-object (socket stream :type t :identity nil)
+    (format stream "@~d on port ~d" (fd socket) (port socket))))
+
+(defmethod accept-connection ((server-socket server-socket)
+			      &key (wait t))
+  "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+  ;; fixxme: perhaps check whether we run multiprocessing and use
+  ;; sys:wait-until-fd-usable instead of
+  ;; mp:process-wait-until-fd-usable here?
+
+  ;; api pipe fitting: wait t ==> timeout nil
+  (when (mp:process-wait-until-fd-usable (fd server-socket) :input
+                                         (if wait nil 0))
+    (let ((stream (sys:make-fd-stream
+                   (ext:accept-tcp-connection (fd server-socket))
+                   :input t :output t
+                   :element-type (element-type server-socket)
+                   :auto-close t)))
+      (if (eq (stream-type server-socket) :bivalent)
+          (make-bivalent-stream stream)
+          stream))))
+
+(defun make-socket (&key (remote-host "localhost")
+			 local-port
+			 remote-port
+			 (connect :active)
+			 (format :text)
+                         (reuse-address t)
+			 &allow-other-keys)
+  "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe.  Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+  (check-type remote-host string)
+  (let ((element-type (ecase format
+			(:text 'base-char)
+			(:binary 'signed-byte)
+                        (:bivalent 'unsigned-byte))))
+    (ecase connect
+      (:passive
+         (make-instance 'server-socket
+		        :port local-port
+                        :fd (ext:create-inet-listener local-port :stream :reuse-address reuse-address)
+                        :element-type element-type
+                        :stream-type format))
+      (:active
+       (let ((stream (sys:make-fd-stream
+                      (ext:connect-to-inet-socket remote-host remote-port)
+                      :input t :output t :element-type element-type)))
+         (if (eq :bivalent format)
+             (make-bivalent-stream stream)
+             stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+  "Kill a passive (listening) socket.  (Active sockets are actually
+streams and handled by their close methods."
+  (declare (ignore abort))
+  (unix:unix-close (fd server)))
+
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+                          (values simple-string))
+		ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (if values
+	(values a b c d)
+      (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+                      (let ((pos2 (position #\Space str :start pos1)))
+                        (if (not pos2)
+                            (nreverse acc)
+                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                         acc))))))
+    (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (values (unsigned-byte 32)))
+		dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+  (ext:host-entry-name (ext:lookup-host-entry ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (car (ext:host-entry-addr-list (ext:lookup-host-entry host)))
+      (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-fd (stream))
+
+(defmethod get-fd ((stream gray-stream::native-lisp-stream-mixin))
+  (system:fd-stream-fd (gray-stream::native-lisp-stream stream)))
+
+(defmethod get-fd ((stream system:lisp-stream))
+  (system:fd-stream-fd stream))
+
+(defmethod get-fd ((stream server-socket))
+  (fd stream))
+
+(defun remote-host (socket-stream)
+  (ext:get-peer-host-and-port (get-fd socket-stream)))
+
+(defun remote-port (socket-stream)
+    (multiple-value-bind (host port)
+        (ext:get-peer-host-and-port (get-fd socket-stream))
+      (declare (ignore host))
+      port))
+
+(defun local-host (socket-stream)
+  (ext:get-socket-host-and-port (get-fd socket-stream)))
+
+(defun local-port (socket-stream)
+  (if (typep socket-stream 'socket::server-socket)
+      (port socket-stream)
+      (multiple-value-bind (host port)
+          (ext:get-socket-host-and-port (get-fd socket-stream))
+        (declare (ignore host))
+        port)))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+                          gray-stream::buffered-bivalent-stream)
+  ())
+
+
+(defun make-bivalent-stream (lisp-stream)
+  (make-instance 'chunked-stream :lisp-stream lisp-stream))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+  (when oc-p
+    (when output-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+          output-chunking))
+  (when output-chunking-eof
+    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+  (when ic-p
+    (when input-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+          input-chunking)))
+
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/cmucl/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,18 @@
+(in-package :acl-compat.system)
+
+(ignore-errors
+(export 'command-line-arguments)
+(export 'command-line-argument)
+(export 'reap-os-subprocess)
+
+(defun command-line-arguments ()
+  ext:*command-line-strings*)
+
+(defun command-line-argument (n)
+  (nth n ext:*command-line-strings*))
+
+(defun reap-os-subprocess (&key (wait nil))
+  (declare (ignore wait))
+  nil)
+
+)

Added: branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/defsys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,50 @@
+(in-package "CL-USER")
+
+(defsystem "ACL-COMPAT"
+  (:default-pathname "ACL-COMPAT:")
+  :members
+  ("acl-compat-common-lisp-lw"
+   "nregex"
+   "acl-excl-lw"
+   "acl-mp-package"
+   "acl-mp-lw"
+   "gray-stream-package"
+   "acl-socket-lw"
+   "acl-sys-lw"
+   "meta"
+   "uri"
+   "chunked-stream-mixin")
+  
+  :rules
+  ((:in-order-to :compile "acl-excl-lw"
+    (:caused-by (:compile "nregex"))
+    (:requires (:load "nregex")))
+   (:in-order-to :load "acl-excl-lw"
+    (:requires (:load "nregex")))
+   
+   (:in-order-to :compile "acl-mp-lw"
+    (:caused-by (:compile "acl-mp-package" "acl-socket-lw"))
+    (:requires (:load "acl-mp-package" "acl-socket-lw")))
+   (:in-order-to :load "acl-mp-lw"
+    (:requires (:load "acl-mp-package" "acl-socket-lw")))
+   
+   (:in-order-to :compile "acl-socket-lw"
+    (:caused-by (:compile "chunked-stream-mixin"))
+    (:requires (:load "chunked-stream-mixin")))
+   (:in-order-to :load "acl-socket-lw"
+    (:requires (:load "chunked-stream-mixin")))
+   
+   (:in-order-to :compile "chunked-stream-mixin"
+    (:caused-by (:compile "acl-excl-lw" "gray-stream-package"))
+    (:requires (:load "acl-excl-lw" "gray-stream-package")))
+   (:in-order-to :load "chunked-stream-mixin"
+    (:requires (:load "acl-excl-lw" "gray-stream-package")))
+   
+   (:in-order-to :compile "uri"
+    (:caused-by (:compile "meta"))
+    (:requires (:load "meta")))
+   (:in-order-to :load "uri"
+    (:requires (:load "meta")))))
+
+(eval-when (:load-toplevel :execute)
+  (pushnew :acl-compat *features*))

Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,85 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+#+obsolete
+(defun stream-input-fn (stream)
+  stream)
+
+(defmethod stream-input-fn ((stream stream))
+  stream)
+	
+(defun filesys-type (file-or-directory-name)
+	(if (lw::file-directory-p file-or-directory-name)
+		:directory
+		(if (probe-file file-or-directory-name)
+			:file
+			nil)))
+
+#-:win32
+(defun filesys-inode (path)
+  (let ((checked-path (probe-file path)))
+    (cond
+      (checked-path (let ((stat (system:get-file-stat checked-path)))
+		      (system:file-stat-inode stat)))
+      (t (error "path ~a does not exist." path)))))
+
+(defmacro atomically (&body forms)
+  `(mp:without-preemption , at forms))
+
+(defmacro without-package-locks (&body forms)
+  `(progn , at forms))
+
+
+#|
+(defun run-shell-command ()
+  (with-open-stream (s (open-pipe "/bin/sh"
+                                  :direction :io
+                                  :buffered nil))
+    (loop for var in environment
+          do (format stream "~A=~A~%" (car var) (cdr var)))
+|#
+  
+;; NDL 2004-06-04 -- Missing definition & a package, to allow LispWorks to load webactions
+
+(defun cl-internal-real-time ()
+  (round (/ (get-internal-real-time) 1000)))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+                         end mb-vector make-mb-vector?
+                         (external-format :default))
+  "This function returns a lisp-usb8-vector and the number of bytes copied."
+  (declare (ignore external-format))
+  ;; The end parameter is different in ACL's lambda list, but this
+  ;; variant lets us give an argument :end nil explicitly, and the
+  ;; right thing will happen
+  (unless end (setf end (length string)))
+  (let* ((number-of-octets (if null-terminate (1+ (- end start))
+                               (- end start)))
+         (mb-vector (cond
+                      ((and mb-vector (>= (length mb-vector) number-of-octets))
+                       mb-vector)
+                      ((or (not mb-vector) make-mb-vector?)
+                       (make-array (list number-of-octets)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element 0))
+                      (t (error "Was given a vector of length ~A, ~
+                                 but needed at least length ~A."
+                                (length mb-vector) number-of-octets)))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+    (loop for from-index from start below end
+       for to-index upfrom 0
+       do (progn
+            (setf (aref mb-vector to-index)
+                  (char-code (aref string from-index)))))
+    (when null-terminate
+      (setf (aref mb-vector (1- number-of-octets)) 0))
+    (values mb-vector number-of-octets)))
+
+
+(provide 'acl-excl)

Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,209 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;;;										;
+;;;; (c) 2001 by Jochen Schmidt.
+;;;;
+;;;; File:            acl-mp-lw.lisp
+;;;; Revision:        1.0.0
+;;;; Description:     LispWorks implementation for ACL-COMPAT-MP
+;;;; Date:            02.02.2002
+;;;; Authors:         Jochen Schmidt
+;;;; Tel:             (+49 9 11) 47 20 603
+;;;; Email:           jsc at dataheaven.de
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer in the
+;;;;    documentation and/or other materials provided with the distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER 
+;;;; EXPRESSED NOR IMPLIED WARRANTIES -  THIS INCLUDES, BUT 
+;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
+;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
+;;;; LOSS OF USE, DATA, OR PROFITS			; OR BUSINESS INTERRUPTION)
+;;;; 
+;;;; For further details contact the authors of this software.
+;;;;
+;;;;  Jochen Schmidt        
+;;;;  Zuckmantelstr. 11     
+;;;;  91616 Neusitz         
+;;;;  GERMANY               
+;;;;
+;;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "comm"))
+
+(in-package :acl-compat-mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the LispWorks MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(
+                    mp:*current-process*
+                    mp:process-kill
+                    mp:process-enable
+                    mp:process-disable
+                    mp::process-preset
+                    mp:process-reset
+                    mp:process-interrupt
+                    mp::process-name
+                    mp:process-wait-function
+                    mp:process-run-reasons
+                    mp:process-arrest-reasons
+                    mp:process-whostate
+                    mp:without-interrupts
+                    mp:process-wait
+		    mp::process-active-p
+                    ))
+
+(export '(          *current-process*
+                    process-kill
+                    process-enable
+                    process-disable
+                    process-preset
+                    process-reset
+                    process-interrupt
+                    process-name
+                    process-wait-function
+                    process-run-reasons
+                    process-arrest-reasons
+                    process-whostate
+                    without-interrupts
+                    process-wait
+	            process-active-p
+                    ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implement missing (and differing) functions ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum
+                          resume-hook suspend-hook initial-bindings run-immediately)
+  (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately))
+  (let ((mp:*process-initial-bindings* initial-bindings))
+    (mp:create-process name :run-reasons run-reasons :arrest-reasons arrest-reasons)))
+
+(defun process-run-function (name-or-options preset-function &rest preset-arguments)
+  (let ((process (ctypecase name-or-options
+                   (string (make-process :name name-or-options))
+                   (list (apply #'make-process name-or-options)))))
+    (apply #'mp::process-preset process preset-function preset-arguments)
+    (push :enable (mp:process-run-reasons process))
+    process))
+
+(defun process-property-list (process)
+  (mp:process-plist process))
+
+(defun (setf process-property-list) (new-value process)
+  (setf (mp:process-plist process) new-value))
+
+(defun process-name-to-process (name &optional abbrev)
+  (if abbrev
+      (let ((length (length name)))
+        (dolist (process (mp:list-all-processes))
+          (when (and (>= (length (process-name process)) length)
+                     (string= name (process-name process) :end2 length))
+            (return process))))
+    (mp:find-process-from-name (ctypecase name
+                                 (symbol (symbol-name name))
+                                 (string name)))))
+
+(defun process-wait-with-timeout (whostate seconds function &rest args)
+  (apply #'mp:process-wait-with-timeout whostate seconds function args))
+
+(defun wait-for-input-available (streams &key (wait-function #'socket::stream-input-available) whostate timeout)
+  (let ((collected-fds nil))
+    (flet ((fd (stream-or-fd)
+             (typecase stream-or-fd
+               (comm:socket-stream (comm:socket-stream-socket stream-or-fd))
+               (socket::passive-socket (socket::socket-os-fd stream-or-fd))
+               (fixnum stream-or-fd)))
+           (collect-fds ()
+             (setf collected-fds
+                   (remove-if-not wait-function streams))))
+      
+      #+unix
+      (unwind-protect
+          (progn
+            (dolist (stream-or-fd streams)
+              (mp:notice-fd (fd stream-or-fd)))
+            (if timeout
+                (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+              (mp:process-wait (or whostate "Waiting for input") #'collect-fds)))
+        (dolist (stream-or-fd streams)
+          (mp:unnotice-fd (fd stream-or-fd))))
+      #-unix
+      (if timeout
+          (mp:process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+        (mp:process-wait (or whostate "Waiting for input") #'collect-fds)))
+    collected-fds))
+
+(defmacro without-scheduling (&body forms)
+  `(mp:without-preemption , at forms))
+
+(defun process-allow-schedule (&optional process)
+  (declare (ignore process))
+  (mp:process-allow-scheduling))
+
+(defun process-revoke-run-reason (process object)
+  (mp:without-preemption
+   (setf (mp:process-run-reasons process)
+         (remove object (mp:process-run-reasons process))))
+  (when (and (eq process mp:*current-process*)
+             (not mp:*inhibit-scheduling-flag*))
+    (mp:process-allow-scheduling)))
+
+(defun process-add-run-reason (process object)
+  (setf (mp:process-run-reasons process) (pushnew object (mp:process-run-reasons process))))
+
+;revised version from alain picard
+(defun invoke-with-timeout (timeout bodyfn timeoutfn)
+  (block timeout
+    (let* ((process mp:*current-process*)
+           (unsheduled? nil)
+           (timer (mp:make-timer
+                   #'(lambda ()
+                       (mp:process-interrupt process
+                                             #'(lambda ()
+                                                 (unless unsheduled?
+                                                   (return-from timeout
+                                                     (funcall timeoutfn)))))))))
+      (mp:schedule-timer-relative timer timeout)
+      (unwind-protect (funcall bodyfn)
+        (without-interrupts
+         (mp:unschedule-timer timer)
+         (setf unsheduled? t))))))
+
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Execute BODY; if execution takes more than SECONDS seconds, terminate
+and evaluate TIMEOUT-FORMS."
+  `(invoke-with-timeout ,seconds #'(lambda () , at body)
+                        #'(lambda () , at timeout-forms)))
+
+(defun current-process ()
+  "The current process."
+  mp:*current-process*)
+
+(defun interrupt-process (process function &rest args)
+  "Run FUNCTION in PROCESS."
+  (apply #'mp:process-interrupt process function args))
+
+(defun make-process-lock (&key name)
+  (mp:make-lock :name name))
+
+(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms)
+  (declare (ignore norecursive))
+  `(mp:with-lock (,lock
+		  ,@(when whostate (list :whostate whostate))
+		  ,@(when timeout (list :timeout timeout)))
+    , at forms))
+

Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,311 @@
+;; This package is designed for LispWorks.  It implements the
+;; ACL-style socket interface on top of LispWorks.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require "comm"))
+
+#+cl-ssl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(ssl-internal::initialize-ssl-library)
+)
+
+(in-package acl-compat.socket)
+
+(define-condition stream-error (error)
+  ((acl-compat.excl::stream :initarg :stream
+           :reader stream-error-stream)
+   (acl-compat.excl::action :initarg :action
+           :reader stream-error-action)
+   (acl-compat.excl::code :initarg :code
+         :reader stream-error-code)
+   (acl-compat.excl::identifier :initarg :identifier
+               :reader stream-error-identifier))
+  (:report (lambda (condition stream)
+             (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
+                     (stream-error-action condition)
+                     (stream-error-identifier condition)
+                     (stream-error-code condition)
+                     (stream-error-stream condition)))))
+
+(define-condition socket-error (stream-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
+                     (stream-error-action condition)
+                     (stream-error-identifier condition)
+                     (stream-error-code condition)
+                     (stream-error-stream condition)))))
+
+#+unix
+(defun %socket-error-identifier (code)
+  (case code
+    (32 :x-broken-pipe)
+    (98 :address-in-use)
+    (99 :address-not-available)
+    (100 :network-down)
+    (102 :network-reset)
+    (103 :connection-aborted)
+    (104 :connection-reset)
+    (105 :no-buffer-space)
+    (108 :shutdown)
+    (110 :connection-timed-out)
+    (111 :connection-refused)
+    (112 :host-down)
+    (113 :host-unreachable)
+    (otherwise :unknown)))
+
+#+win32
+(defun %socket-error-identifier (code)
+  (case code
+    (10048 :address-in-use)
+    (10049 :address-not-available)
+    (10050 :network-down)
+    (10052 :network-reset)
+    (10053 :connection-aborted)
+    (10054 :connection-reset)
+    (10055 :no-buffer-space)
+    (10058 :shutdown)
+    (10060 :connection-timed-out)
+    (10061 :connection-refused)
+    (10064 :host-down)
+    (10065 :host-unreachable)
+    (otherwise :unknown)))
+
+(defun socket-error (stream error-code action format-string &rest format-args)
+  (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error
+  (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
+    (error 'socket-error :stream stream :code code
+           :identifier (if (keywordp error-code)
+                           error-code
+                         (%socket-error-identifier error-code))
+           :action action)))
+
+
+(defclass socket ()
+  ((passive-socket :type fixnum
+                   :initarg :passive-socket
+                   :reader socket-os-fd)))
+
+(defclass passive-socket (socket)
+  ((element-type :type (member signed-byte unsigned-byte base-char)
+		 :initarg :element-type
+		 :reader element-type)
+   (port :type fixnum
+	 :initarg :port
+	 :reader local-port)))
+
+(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ())
+(defclass input-binary-socket-stream (binary-socket-stream)())
+(defclass output-binary-socket-stream (binary-socket-stream)())
+(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
+
+
+(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
+  (apply #'socket-error stream error-code :IO format-string format-args))
+
+
+(declaim (inline %reader-function-for-sequence))
+(defun %reader-function-for-sequence (sequence)
+  (typecase sequence
+    (string #'read-char)
+    ((array unsigned-byte (*)) #'read-byte)
+    ((array signed-byte (*)) #'read-byte)
+    (otherwise #'read-byte)))
+
+;; Bivalent socket support for READ-SEQUENCE
+(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end)
+  (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs
+(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end)
+  (write-string sequence stream :start start :end end))
+
+;; ACL Gray-Streams Enhancment Generic Functions 
+
+(defmethod stream-input-fn ((stream input-binary-socket-stream))
+  (comm:socket-stream-socket stream))
+
+(defmethod stream-output-fn ((stream output-binary-socket-stream))
+  (comm:socket-stream-socket stream))
+
+(defmethod socket-os-fd ((socket comm:socket-stream))
+  (comm:socket-stream-socket socket))
+
+(defmethod print-object ((passive-socket passive-socket) stream)
+  (print-unreadable-object (passive-socket stream :type t :identity nil)
+    (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
+
+(defmethod stream-input-available ((fd fixnum))
+  (comm::socket-listen fd))
+
+(defmethod stream-input-available ((stream stream::os-file-handle-stream))
+  (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
+
+(defmethod stream-input-available ((stream comm:socket-stream))
+  (or (comm::socket-listen (comm:socket-stream-socket stream))
+      (listen stream)))
+
+(defmethod stream-input-available ((stream socket::passive-socket))
+  (comm::socket-listen (socket::socket-os-fd stream)))
+
+
+(defmethod accept-connection ((passive-socket passive-socket)
+			      &key (wait t))
+  (if (or wait (stream-input-available passive-socket))
+      (make-instance 'bidirectional-binary-socket-stream
+                     :socket (comm::get-fd-from-socket (socket-os-fd passive-socket))
+                     :direction :io
+                     :element-type (element-type passive-socket))))
+
+(defun %new-passive-socket (local-port)
+  (multiple-value-bind (socket error-location error-code)
+      (comm::create-tcp-socket-for-service local-port)
+    (cond (socket socket)
+	  (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
+
+(defun make-socket (&key (remote-host "localhost")
+			 local-port
+			 remote-port 
+			 (connect :active)
+			 (format :text)
+                         (reuse-address t)
+			 &allow-other-keys)
+  (declare (ignore format))
+  (check-type remote-host string)
+  (ecase connect 
+    (:passive
+     (let ((comm::*use_so_reuseaddr* reuse-address))
+       (make-instance 'passive-socket
+                      :port local-port
+                      :passive-socket (%new-passive-socket local-port)
+                      :element-type '(unsigned-byte 8))))
+    (:active
+     (handler-case
+         (let ((stream (comm:open-tcp-stream remote-host remote-port
+                                             :direction :io
+                                             :element-type '(unsigned-byte 8)
+                                             :errorp t)))
+           (change-class stream 'bidirectional-binary-socket-stream))
+       (simple-error (condition) 
+                     (let ((code (first (last (simple-condition-format-arguments condition)))))
+                       (socket-error condition code
+                                     :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition))))))))
+
+
+(defmethod close ((passive-socket passive-socket) &key abort)
+  (declare (ignore abort))
+  (comm::close-socket (socket-os-fd passive-socket)))
+
+;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+;		ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+  ;(declare (type (unsigned-byte 32) ipaddr))
+  (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection
+    (let ((a (logand #xff (ash ipaddr -24)))
+          (b (logand #xff (ash ipaddr -16)))
+          (c (logand #xff (ash ipaddr -8)))
+          (d (logand #xff ipaddr)))
+      (if values
+	(values a b c d)
+        (format nil "~d.~d.~d.~d" a b c d)))
+    (if values (values 0 0 0 0) "0.0.0.0")))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+                      (let ((pos2 (position #\Space str :start pos1)))
+                        (if (not pos2)
+                            (nreverse acc)
+                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                         acc))))))
+(get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (values (unsigned-byte 32)))
+		dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors 
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (declare (ignore ignore-cache))
+  (multiple-value-bind (name)
+      (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name))
+    name))
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (multiple-value-bind (addr)
+	  (comm:get-host-entry host :fields '(:address))
+	addr)
+    (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defmethod remote-host ((socket comm:socket-stream))
+  (comm:socket-stream-peer-address socket))
+
+(defmethod remote-port ((socket comm:socket-stream))
+  (multiple-value-bind (host port)
+      (comm:socket-stream-peer-address socket)
+    (declare (ignore host))
+    port))
+
+(defmethod local-host ((socket comm:socket-stream))
+  (multiple-value-bind (host port)
+      (comm:socket-stream-address socket)
+    (declare (ignore port))
+    host))
+
+(defmethod local-port ((socket comm:socket-stream))
+  (multiple-value-bind (host port)
+      (comm:socket-stream-address socket)
+    (declare (ignore host))
+    port))
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+  (when oc-p
+    (when output-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking))
+  (when output-chunking-eof
+    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+  (when ic-p
+    (when input-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking)))
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options)
+  (declare (ignore options))
+  (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client)
+  socket-stream)
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defun initialize-ssl-library ()
+  ;; Dunno how to force load yet
+  (comm:ensure-ssl))
+
+#+(and :lispworks4.4 (not :cl-ssl))
+(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate  certificate-password)
+  (flet ((ctx-configure-callback (ctx)
+	   (comm:ssl-ctx-use-privatekey-file ctx
+					     certificate-password
+					     comm:SSL_FILETYPE_PEM))
+	 (ssl-configure-callback (ssl)
+	   (comm:ssl-use-certificate-file ssl
+					  certificate
+					  comm:SSL_FILETYPE_PEM)))
+    (comm:attach-ssl socket-stream
+		     :ssl-side :server
+		     :ctx-configure-callback #'ctx-configure-callback
+		     :ssl-configure-callback #'ssl-configure-callback))
+  socket-stream)
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lispworks/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,24 @@
+(in-package :sys)
+(let ((*handle-warn-on-redefinition* :warn))
+;      (*packages-for-warn-on-redefinition* nil))
+
+  (defun command-line-arguments ()
+    system:*line-arguments-list*)
+  
+  (defun command-line-argument (n)
+    (nth n system:*line-arguments-list*))
+  
+  (defun reap-os-subprocess (&key (wait nil))
+    (declare (ignore wait))
+    nil)
+
+  (export 'command-line-arguments)
+  (export 'command-line-argument)
+  (export 'reap-os-subprocess))
+
+;; Franz uses the MSWINDOWS feature conditional in some of their code;
+;; thus, under Windows, ACL-COMPAT should probably push MSWINDOWS
+;; onto the *features* list when it detects the presence of WIN32
+;; under Lispworks.
+#+WIN32 (eval-when (:compile-toplevel :load-toplevel :execute)
+          (pushnew :mswindows *features*))

Added: branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/lw-buffering.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,261 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; LW Style Buffer Protocol for other Lisps     ;;;
+;;; So far only 8bit byte and character IO works ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package :gray-stream)
+
+(defvar *default-input-buffer-size* 8192)
+(defvar *default-output-buffer-size* 8192)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defstruct buffer-state 
+    (input-buffer (make-array *default-input-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*)))
+    (input-index nil)
+    (input-limit *default-input-buffer-size* :type fixnum)
+    (output-buffer (make-array *default-output-buffer-size* :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (*)))
+    (output-index 0)
+    (output-limit *default-output-buffer-size* :type fixnum)))
+
+;; Can be used to implement resourcing of buffers later
+(defun %allocate-buffer-state (&optional (input-limit *default-input-buffer-size*) (output-limit *default-output-buffer-size*))
+  (declare (ignore input-limit output-limit))
+  (make-buffer-state))
+
+(defun %deallocate-buffer-state (state)
+  (declare (ignore state)))
+
+;; Can be used to implement unbuffered encapsulating streams later
+(defclass native-lisp-stream-mixin ()
+  ((lisp-stream :initarg :lisp-stream
+		:reader native-lisp-stream))
+  (:documentation "Stream mixin that encapsulates a native stream."))
+
+(defclass buffered-stream-mixin (native-lisp-stream-mixin)
+  ((buffer-state :initform (%allocate-buffer-state)))
+  (:documentation "Stream mixin that provides buffering for a native lisp stream."))
+
+;; fundamental-bivalent-xxx-streams can be used to implement buffered
+;; and unbuffered bivalent streams.  At the moment, we only implement
+;; buffered ones.
+(defclass fundamental-bivalent-input-stream
+    (fundamental-character-input-stream fundamental-binary-input-stream)
+  ())
+
+(defclass fundamental-bivalent-output-stream
+    (fundamental-character-output-stream fundamental-binary-output-stream)
+  ())
+
+(defclass buffered-bivalent-input-stream
+    (buffered-stream-mixin fundamental-bivalent-input-stream)
+  ())
+
+(defclass buffered-bivalent-output-stream
+    (buffered-stream-mixin fundamental-bivalent-output-stream)
+  ())
+
+(defclass buffered-bivalent-stream
+    (buffered-bivalent-input-stream buffered-bivalent-output-stream)
+  ())
+
+(defmacro with-stream-output-buffer ((buffer index limit) stream &body forms)
+  (let ((state (gensym "BUFFER-STATE-")))
+  `(let ((,state (slot-value ,stream 'buffer-state)))
+     (symbol-macrolet ((,buffer ,(list 'buffer-state-output-buffer state))
+                       (,index ,(list 'buffer-state-output-index state))
+                       (,limit ,(list 'buffer-state-output-limit state)))
+       , at forms))))
+
+;;; Encapsulated native streams
+
+(defmethod close ((stream native-lisp-stream-mixin) &key abort)
+  (close (native-lisp-stream stream) :abort abort))
+
+(defmethod stream-listen ((stream native-lisp-stream-mixin))
+  (listen (native-lisp-stream stream)))
+
+(defmethod open-stream-p ((stream native-lisp-stream-mixin))
+  (common-lisp::open-stream-p (native-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream native-lisp-stream-mixin))
+  (clear-output (native-lisp-stream stream)))
+
+;;; Input streams
+
+(declaim (inline %reader-function-for-sequence))
+(defun %reader-function-for-sequence (sequence)
+  (typecase sequence
+    (string #'read-char)
+    ((array unsigned-byte (*)) #'read-byte)
+    ((array signed-byte (*)) #'read-byte)
+    (otherwise #'read-byte)))
+
+(defun read-elements (socket-stream sequence start end reader-fn)
+  (let* ((len (length sequence))
+         (chars (- (min (or end len) len) start)))
+    (loop for i upfrom start
+          repeat chars
+          for char = (funcall reader-fn socket-stream)
+          if (eq char :eof) do (return-from read-elements i)
+          do (setf (elt sequence i) char))
+    (+ start chars)))
+
+(defmacro with-stream-input-buffer ((buffer index limit) stream &body forms)
+  (let ((state (gensym "BUFFER-STATE-")))
+  `(let ((,state (slot-value ,stream 'buffer-state)))
+     (symbol-macrolet ((,buffer ,(list 'buffer-state-input-buffer state))
+                       (,index ,(list 'buffer-state-input-index state))
+                       (,limit ,(list 'buffer-state-input-limit state)))
+       , at forms))))
+
+(defgeneric stream-fill-buffer (stream))
+(defmethod stream-fill-buffer ((stream buffered-stream-mixin))
+  ;; Implement b/nb semantics: block until at least one byte is read,
+  ;; but not until the whole buffer is filled.  This means it takes at
+  ;; most n calls to this function to fill a buffer of length n, even
+  ;; with a slow connection.
+  (with-stream-input-buffer (buffer index limit) stream
+    (let* ((the-stream (native-lisp-stream stream))
+           (read-bytes
+            (loop with byte
+               for n-read from 0 below limit
+               while (and (if (< 0 n-read) (listen the-stream) t)
+                          (setf byte (read-byte the-stream nil nil)))
+               do (setf (aref buffer n-read) byte)
+               count t)))
+      (if (zerop read-bytes)
+          nil
+          (setf index 0
+                limit read-bytes)))))
+
+(defmethod stream-read-byte ((stream buffered-bivalent-input-stream))
+  (with-stream-input-buffer (buffer index limit) stream
+     (unless (and index (< index limit))
+       (when (null (stream-fill-buffer stream))
+	 (return-from stream-read-byte :eof)))
+     (prog1 (aref buffer index)
+       (incf index))))
+
+(defmethod stream-read-char ((stream buffered-bivalent-input-stream))
+  (let ((byte (stream-read-byte stream)))
+    (if (eq byte :eof)
+        :eof
+      (code-char byte))))
+
+(defmethod stream-read-char-no-hang ((stream buffered-bivalent-input-stream))
+  (if (listen stream)
+      (read-char stream)
+      nil))
+
+(defmethod stream-unread-char ((stream buffered-bivalent-input-stream) character)
+  (with-stream-input-buffer (buffer index limit) stream
+      (let ((new-index (1- index)))
+        (when (minusp new-index)
+          (error "Cannot unread char ~A" character))
+        (setf (aref buffer new-index) (char-code character)
+              index new-index)))
+  nil)
+
+(defmethod stream-peek-char ((stream buffered-bivalent-input-stream))
+  (let ((char (stream-read-char stream)))
+    (unless (eq char :eof)
+      (stream-unread-char stream char))
+    char))
+
+
+(defmethod stream-read-line ((stream buffered-bivalent-input-stream))
+  (let ((res (make-array 80 :element-type 'character :fill-pointer 0)))
+    (loop
+     (let ((ch (stream-read-char stream)))
+       (cond ((eq ch :eof)
+	      (return (values (copy-seq res) t)))
+	     ((char= ch #\Linefeed)
+              (return (values (copy-seq res) nil)))
+             (t
+              (vector-push-extend ch res)))))))
+
+
+(defmethod stream-read-sequence ((stream buffered-bivalent-input-stream) sequence &optional start end)
+  (read-elements stream sequence start end (%reader-function-for-sequence sequence)))
+
+;;(defmethod stream-clear-input ((stream buffered-bivalent-input-stream))
+;;  (clear-input (native-lisp-stream stream)))
+
+(defmethod stream-element-type ((stream fundamental-bivalent-input-stream))
+  '(or character (unsigned-byte 8)))
+
+;;; Output streams
+
+(declaim (inline %writer-function-for-sequence))
+(defun %writer-function-for-sequence (sequence)
+  (typecase sequence
+    (string #'stream-write-char)
+    ((array unsigned-byte (*)) #'stream-write-byte)
+    ((array signed-byte (*)) #'stream-write-byte)
+    (otherwise #'stream-write-byte)))
+
+(defun write-elements (stream sequence start end writer-fn)
+  (let* ((len (length sequence))
+         (start (or start 0))
+         (end (or end len)))
+    (assert (<= 0 start end len))
+    (etypecase sequence
+      (simple-vector (loop for i from start below end
+                           do (funcall writer-fn stream (svref sequence i))))
+      (vector (loop for i from start below end
+                    do (funcall writer-fn stream (aref sequence i))))
+      (list (loop for i from start below end
+                  for c in (nthcdr start sequence)
+                  do (funcall writer-fn stream c))))))
+
+(defgeneric stream-write-buffer (stream buffer start end))
+(defmethod stream-write-buffer ((stream buffered-stream-mixin) buffer start end)
+  (let ((lisp-stream (native-lisp-stream stream)))
+    (write-sequence buffer lisp-stream :start start :end end)))
+
+(defgeneric stream-flush-buffer (stream))
+(defmethod stream-flush-buffer ((stream buffered-stream-mixin))
+  (with-stream-output-buffer (buffer index limit) stream
+    (when (plusp index)
+      (stream-write-buffer stream buffer 0 index)
+      (setf index 0))))
+
+(defmethod stream-write-byte ((stream buffered-bivalent-output-stream) byte)
+  (with-stream-output-buffer (buffer index limit) stream
+    (unless (< index limit)
+      (stream-flush-buffer stream))
+    (setf (aref buffer index) byte)
+    (incf index)))
+
+(defmethod stream-write-char ((stream buffered-bivalent-output-stream) character)
+  (stream-write-byte stream (char-code character)))
+
+(defmethod stream-write-string ((stream buffered-bivalent-output-stream) string &optional (start 0) end)
+  (write-elements stream string start end #'stream-write-char))
+
+(defmethod stream-write-sequence ((stream buffered-stream-mixin) sequence
+                                  &optional (start 0) end)
+  (write-elements stream sequence start end (%writer-function-for-sequence sequence)))
+
+(defmethod stream-element-type ((stream fundamental-bivalent-output-stream))
+  '(or character (unsigned-byte 8)))
+
+(defmethod stream-line-column ((stream fundamental-bivalent-output-stream))
+  nil)
+
+(defmethod stream-finish-output ((stream buffered-bivalent-output-stream))
+  (stream-flush-buffer stream)
+  (finish-output (native-lisp-stream stream)))
+
+(defmethod stream-force-output ((stream buffered-bivalent-output-stream))
+  (stream-flush-buffer stream)
+  (force-output (native-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream buffered-bivalent-output-stream))
+  (with-stream-output-buffer (buffer index limit) stream
+     (setf index 0
+           limit 0))
+  (call-next-method)                    ; Clear native stream also
+  )
+
+

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,168 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+;#-openmcl
+;(defun fixnump (x)
+;  (ccl::fixnump x))
+
+#-openmcl
+(import 'ccl::fixnump)
+
+#+openmcl
+(defun filesys-inode (path)
+    (or (nth-value 4 (ccl::%stat (ccl::native-translated-namestring path)))
+	      (error "path ~s does not exist" path)))
+
+(defun cl-internal-real-time ()
+  (round (/ (get-internal-real-time) 1000)))
+
+(defun stream-input-fn (stream)
+  stream)
+
+(defun filesys-type (file-or-directory-name)
+	(if (ccl:directory-pathname-p file-or-directory-name)
+		:directory
+		(if (probe-file file-or-directory-name)
+			:file
+			nil)))
+
+(defmacro atomically (&body forms)
+  `(ccl:without-interrupts , at forms))
+
+(defmacro without-package-locks (&body forms)
+  `(progn , at forms))
+
+(define-condition stream-error (error)
+  ((stream :initarg :stream
+           :reader stream-error-stream)
+   (action :initarg :action
+           :initform nil
+           :reader stream-error-action)
+   (code :initarg :code
+         :initform nil
+         :reader stream-error-code)
+   (identifier :initarg :identifier
+               :initform nil
+               :reader stream-error-identifier))
+  (:report (lambda (condition stream)
+             (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
+                     (stream-error-action condition)
+                     (stream-error-identifier condition)
+                     (stream-error-code condition)
+                     (stream-error-stream condition)))))
+
+(define-condition socket-error (stream-error)
+  ()
+  (:report (lambda (condition stream)
+             (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
+                     (stream-error-action condition)
+                     (stream-error-identifier condition)
+                     (stream-error-code condition)
+                     (stream-error-stream condition)))))
+
+
+
+;! Need to figure out what to do here
+(defun fasl-read (filename)
+  (declare (ignore filename))
+  (error "fasl-read not implemented for MCL.") )
+
+(defun fasl-write (data stream opt)
+  (declare (ignore data stream opt))
+  (error "fasl-write not implemented for MCL.") )
+
+
+(defmacro schedule-finalization (object function)
+  `(ccl:terminate-when-unreachable ,object ,function))
+
+(defun run-shell-command (program
+                          &key input output error-output separate-streams
+                          if-input-does-not-exist if-output-exists
+                          if-error-output-exists wait environment show-window)
+  (declare (ignore show-window))
+  ;; KLUDGE: split borrowed from asdf, this shouldn't be done -- it
+  ;; would be better to use split-sequence or define one ourselves ...
+  ;; TODO: On Unix, acl also handles a vector of simple-strings as
+  ;; value for program, with different semantics.
+  (let* ((program-and-arguments
+          (delete "" (asdf::split program) :test #'string=))
+         (program (car program-and-arguments))
+         (arguments (cdr program-and-arguments)))
+   (when environment
+     #-unix (error "Don't know how to run program in an environment.")
+     (setf arguments (append
+                      (list "-i")
+                      (loop for (name . value) in environment
+                         collecting (concatenate 'string name "=" value))
+                      (list program)
+                      arguments))
+     (setf program "env"))
+       
+   (let* ((process (run-program program arguments
+                                :input input
+                                :if-input-does-not-exist
+                                if-input-does-not-exist
+                                :output output
+                                :if-output-exists if-output-exists
+                                :error error-output
+                                :if-error-exists if-error-output-exists
+                                :wait wait))
+          (in-stream (external-process-input-stream process))
+          (out-stream (external-process-output-stream process))
+          (err-stream (external-process-error-stream process))
+          (pid (external-process-id process)))
+     (cond
+       ;; one value: exit status
+       (wait (nth-value 1 (external-process-status process)))
+       ;; four values: i/o/e stream, pid
+       (separate-streams
+        (values (if (eql input :stream) in-stream nil)
+                (if (eql output :stream) out-stream nil)
+                (if (eql error-output :stream) err-stream nil)
+                pid))
+       ;; three values: normal stream, error stream, pid
+       (t (let ((normal-stream
+                 (cond ((and (eql input :stream) (eql output :stream))
+                        (make-two-way-stream in-stream out-stream))
+                       ((eql input :stream) in-stream)
+                       ((eql output :stream) out-stream)
+                       (t nil)))
+                (error-stream (if (eql error-output :stream) err-stream nil)))
+            (values normal-stream error-stream pid)))))))
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+                         end mb-vector make-mb-vector?
+                         (external-format :default))
+  "This function returns a lisp-usb8-vector and the number of bytes copied."
+  (declare (ignore external-format))
+  ;; The end parameter is different in ACL's lambda list, but this
+  ;; variant lets us give an argument :end nil explicitly, and the
+  ;; right thing will happen
+  (unless end (setf end (length string)))
+  (let* ((number-of-octets (if null-terminate (1+ (- end start))
+                               (- end start)))
+         (mb-vector (cond
+                      ((and mb-vector (>= (length mb-vector) number-of-octets))
+                       mb-vector)
+                      ((or (not mb-vector) make-mb-vector?)
+                       (make-array (list number-of-octets)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element 0))
+                      (t (error "Was given a vector of length ~A, ~
+                                 but needed at least length ~A."
+                                (length mb-vector) number-of-octets)))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+    (loop for from-index from start below end
+       for to-index upfrom 0
+       do (progn
+            (setf (aref mb-vector to-index)
+                  (char-code (aref string from-index)))))
+    (when null-terminate
+      (setf (aref mb-vector (1- number-of-octets)) 0))
+    (values mb-vector number-of-octets)))

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,183 @@
+;;; This file implements the process functions for AllegroServe in MCL.
+;;; Based on the the work done for cmucl and Lispworks.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforge.net
+
+
+(in-package :acl-compat.mp)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+; existing stuff from ccl we can reuse directly
+(shadowing-import 
+ '(ccl:*current-process*
+   ccl::lock
+   ccl:process-allow-schedule
+   ccl:process-name
+   ccl:process-preset
+   #-openmcl-native-threads ccl:process-run-reasons
+   ccl:process-wait
+   ccl:process-wait-with-timeout
+   ccl:without-interrupts))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(export 
+ '(*current-process*
+   lock
+   process-allow-schedule
+   process-name
+   process-preset
+   process-run-reasons
+   process-wait
+   process-wait-with-timeout
+   without-interrupts))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+                 
+(defmacro without-scheduling (&body forms)
+  `(ccl:without-interrupts , at forms))
+
+#|
+; more ideas stolen from acl-mp-lw.lisp
+(defun invoke-with-timeout (seconds bodyfn timeoutfn)
+  (block timeout
+    (let* ((process *current-process*)
+           (timer (ccl:process-run-function "with-timeout-timer"
+                                            #'(lambda () 
+                                                (sleep seconds)
+                                                (ccl:process-interrupt process
+                                                                       #'(lambda ()
+                                                                           (return-from timeout
+                                                                             (funcall timeoutfn))))))))
+      (unwind-protect (funcall bodyfn)
+        (ccl:process-kill timer)))))
+
+|#
+
+
+
+(defun invoke-with-timeout (seconds bodyfn timeoutfn)
+  (block timeout
+    (let* ((timer (ccl::make-timer-request
+                    seconds
+                    #'(lambda () (return-from timeout (funcall timeoutfn))))))
+      (ccl::enqueue-timer-request timer)
+      (unwind-protect (funcall bodyfn)
+	(ccl::dequeue-timer-request timer)))))
+
+
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Execute BODY; if execution takes more than SECONDS seconds, terminate and evaluate TIMEOUT-FORMS."
+  `(invoke-with-timeout ,seconds #'(lambda () , at body)
+                        #'(lambda () , at timeout-forms)))
+
+
+#+openmcl-native-threads
+(progn
+
+;;; The :INITIAL-BINDINGS arg to process creation functions seems to be
+;;; quoted, even when it appears in a list (as in the case of
+;;; (process-run-function <args>))  By the time that percolates down
+;;; to OpenMCL's process creation functions, it should lose the quote.
+;;;
+;;; Perhaps I imagined that ...
+;;;
+
+(defun ccl::openmcl-fix-initial-bindings (initial-bindings)
+  (if (and (consp initial-bindings)
+           (eq (car initial-bindings) 'quote))
+    (cadr initial-bindings)
+    initial-bindings))
+                             
+)
+	   
+
+#-openmcl-native-threads
+(defmacro process-revoke-run-reason (process reason)
+  `(ccl:process-disable-run-reason ,process ,reason) )
+
+#-openmcl-native-threads
+(defmacro process-add-run-reason (process reason)
+  `(ccl:process-enable-run-reason ,process ,reason) )
+
+
+(defmacro make-process-lock (&key name)
+  (if name
+    `(ccl:make-lock ,name)
+    `(ccl:make-lock)))
+
+(defmacro with-process-lock ((lock &key norecursive timeout whostate) &body forms)
+  (declare (ignore norecursive whostate timeout))
+  `(ccl:with-lock-grabbed (,lock) , at forms))
+
+
+(defmacro process-kill (process)
+  `(progn
+    #-openmcl-native-threads
+     (unless (ccl:process-active-p ,process) ;won't die unless enabled
+       (ccl:process-reset-and-enable ,process) )
+     (ccl:process-kill ,process)))
+)
+
+(defun process-active-p (process)
+  (ccl::process-active-p process))
+
+(defun interrupt-process (process function &rest args)
+  "Run FUNCTION in PROCESS."
+(apply #'ccl:process-interrupt process function args))
+
+(defun current-process ()
+  "The current process."
+  ccl:*current-process*)
+
+
+;property list implementation from acl-mp-cmu.lisp
+(defvar *process-plists* (make-hash-table :test #'eq)
+  "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+  (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+  (setf (gethash process *process-plists*) new-value))
+
+; from acl-mp-lw.lisp
+(defun make-process (&key (name "Anonymous") reset-action run-reasons arrest-reasons (priority 0) quantum
+                          resume-hook suspend-hook initial-bindings run-immediately)
+  (declare (ignore priority quantum reset-action resume-hook suspend-hook run-immediately))
+  #-openmcl-native-threads
+  (declare (ignore initial-bindings)) ;! need separate lexical bindings for each process?
+  #+openmcl-native-threads
+  (declare (ignore run-reasons arrest-reasons))
+  ;(let ((acl-mp:*process-initial-bindings* initial-bindings))
+  #-openmcl-native-threads
+  (ccl:make-process name :run-reasons run-reasons :arrest-reasons arrest-reasons)
+  #+openmcl-native-threads
+  (ccl:make-process name :initial-bindings (ccl::openmcl-fix-initial-bindings initial-bindings)))
+
+(defun process-run-function (name-or-options preset-function &rest preset-arguments)
+  (let ((process (ctypecase name-or-options
+                   (string (acl-mp:make-process :name name-or-options))
+                   (list (apply #'acl-mp:make-process name-or-options)))))
+    (apply #'acl-mp:process-preset process preset-function preset-arguments)
+    #+openmcl-native-threads (ccl:process-enable process)
+    #-openmcl-native-threads (process-add-run-reason process :enable)
+    process))
+
+;;; Busy-waiting ...
+(defun wait-for-input-available (streams
+                                 &key (wait-function #'ccl:stream-listen)
+                                 whostate timeout)
+  (let ((collected-fds nil))
+    (flet ((collect-fds ()
+             (setf collected-fds
+                   (remove-if-not wait-function streams))))
+      
+      (if timeout
+          (process-wait-with-timeout (or whostate "Waiting for input") timeout #'collect-fds)
+          (process-wait (or whostate "Waiting for input") #'collect-fds)))
+    collected-fds))

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-mcl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,268 @@
+;;; MCL layer for ACL sockets.
+;;; Based on acl-socket-cmu.lisp and acl-socket-lw.lisp.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforge.net
+
+
+(defpackage :acl-compat.socket
+  (:nicknames :socket :acl-socket)
+  (:use :common-lisp)
+  (:export #:make-socket 
+           #:accept-connection
+           #:ipaddr-to-dotted 
+           #:dotted-to-ipaddr 
+           #:ipaddr-to-hostname 
+           #:lookup-hostname
+           #:remote-host 
+           #:remote-port 
+           #:local-host 
+           #:local-port 
+           #:socket-control
+           ))
+
+(in-package :socket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(require :opentransport)
+
+;OpenTransport.lisp does not export anything, so do this to make it look a bit cleaner.
+(import '(ccl::open-tcp-stream
+          ccl::opentransport-tcp-stream
+          ccl::opentransport-binary-tcp-stream
+          ccl::stream-local-port
+          ccl::stream-local-host
+          ccl::stream-local-port
+          ccl::stream-remote-host
+          ccl::stream-remote-port
+          ccl::inet-host-name
+          ccl::tcp-host-address
+          ) )
+
+(defmacro connection-state (s)
+  `(ccl::opentransport-stream-connection-state ,s))
+
+(defmacro connection-established (s)
+  `(eq :dataxfer (connection-state ,s)) )
+
+)
+
+
+;;; There is a bug in MCL (4.3.1 tested) where read-sequence and
+;;; write-sequence fail with binary tcp streams. These two methods 
+;;; provide a work-around.
+#-carbon-compat ;should be fixed starting with first carbon version (4.3.5)
+(defmethod ccl:stream-write-sequence ((s opentransport-binary-tcp-stream)
+                                      (sequence ccl::simple-unsigned-byte-vector)
+                                      &key (start 0) end)
+  (ccl::stream-write-vector s sequence start (or end (length sequence)))
+  s)
+
+
+
+#-carbon-compat ;should be fixed starting with first carbon version (4.3.5)
+(defmethod ccl:stream-read-sequence ((s opentransport-binary-tcp-stream)
+                                         (sequence ccl::simple-unsigned-byte-vector) 
+                                         &key (start 0) (end (length sequence)))
+  (ccl::stream-read-bytes-to-vector s sequence (- end start) start)
+  end)
+  
+
+ 
+(defmethod port ((stream opentransport-tcp-stream))
+  (stream-local-port stream) )
+
+(defmethod local-host ((s opentransport-tcp-stream))
+  (stream-local-host s))
+
+(defmethod local-port ((s opentransport-tcp-stream))
+  (stream-local-port s))
+
+(defmethod remote-host ((s opentransport-tcp-stream))
+  (stream-remote-host s))
+
+(defmethod remote-port ((s opentransport-tcp-stream))
+  (stream-remote-port s))
+
+;? copied from lispworks - don't think it applies to mcl
+(defmethod fd ((s opentransport-tcp-stream))
+  (declare (ignore s))
+  42)
+
+
+
+(defvar *passive-socket-listener-count* 10
+  "Default number of listen streams to use.")
+
+; With ACL, an unlimited number of connections can be made to the same passive
+; socket instance. Nothing like that here, so we have to create our own stream
+; listener to create the "real" sockets as connections are made.
+
+
+; Create a class to monitor streams so we have a data structure to pass to process-wait
+(defclass passive-socket (stream) ;inherit stream so we can handle close
+  ((port
+    :documentation "Port we are listening on."
+    :initform 80
+    :initarg :port
+    :reader local-port)
+   (element-type
+    :documentation "Stream element type."
+    :initarg :element-type
+    :initform '(unsigned-byte 8))
+   (count
+    :documentation "Number of listening streams to monitor."
+    :initform *passive-socket-listener-count*)
+   (streams
+    :documentation "Array of listen streams."
+    :initform nil)
+   (index
+    :documentation "Index of the last listen stream checked."
+    :initform *passive-socket-listener-count*)
+   (connect-index
+    :documentation "Index of a connected stream, next for processing."
+    :initform nil)
+   )
+  (:documentation "Class used to manage listening streams and connections.") )
+
+
+
+(defmethod initialize-instance :after ((listener passive-socket) &rest initargs)
+  (declare (ignore initargs))
+  (with-slots (streams count port element-type) listener
+    (setf streams (make-array count :initial-element nil :adjustable t))
+    (dotimes (i count)
+      (setf (elt streams i) (new-listen-stream listener)) ) ) )
+
+
+(defmethod ccl:stream-close ((listener passive-socket))
+  (with-slots (streams count) listener
+    (dotimes (i count)
+      (close (elt streams i)))
+    (setf count 0)))
+
+
+(defmethod new-listen-stream ((listener passive-socket))
+  (with-slots (port element-type) listener
+    (open-tcp-stream nil port ;use nil host to get a passive connection
+                          :element-type element-type) ) )
+
+
+(defmethod local-host ((listener passive-socket))
+  (with-slots (streams count) listener
+    (when (> count 0)
+      (local-host (elt streams 0)))))
+              
+
+
+; See if one of the streams is established. 
+(defmethod find-connection-index ((listener passive-socket))
+  (with-slots (count streams index connect-index) listener
+    (let ((next (if (< (1+ index) count) (1+ index) 0)))
+       (when (connection-established (elt streams next))
+         (setf index next
+               connect-index next)
+         connect-index))))
+
+
+(defmethod process-connected-stream ((listener passive-socket))
+  (with-slots (streams connect-index) listener
+    (if (null connect-index) nil
+        (let ((s (elt streams connect-index))) ;return the connected stream and set a new one
+          (setf (elt streams connect-index) (new-listen-stream listener))
+          (setf connect-index nil)
+          s) ) ) )
+      
+
+;! future - determine how many connects we are getting an dynamically increase the number
+;  of listeners if necessary.
+(defmethod accept-connection ((listener passive-socket) &key (wait t))
+  (if wait
+    (ccl:process-wait "accept connection..." #'find-connection-index listener) ;apply repeatedly with process wait
+    (find-connection-index listener) )
+  (process-connected-stream listener) )
+
+
+(defun make-socket (&key (remote-host "localhost")
+			   local-port
+			   remote-port 
+			   (connect :active)
+			   (format :text)
+			   &allow-other-keys)
+  (let ((element-type (ecase format
+			(:text 'base-char)
+			(:binary 'signed-byte)
+                        (:bivalent 'unsigned-byte))))
+    (ecase connect 
+      (:passive
+       (make-instance 'passive-socket :port local-port :element-type element-type :direction :io))
+      (:active
+       (let ((host (if (integerp remote-host) ;aparently the acl version also accepts an integer
+                     (ipaddr-to-dotted remote-host)
+                     remote-host)))
+         (check-type host string)
+         (open-tcp-stream host remote-port
+                          :element-type element-type))))))
+
+
+
+(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
+		ipaddr-to-dotted))
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (if values
+	(values a b c d)
+      (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+             (let ((pos2 (position #\Space str :start pos1)))
+               (if (not pos2)
+                 (nreverse acc)
+                 (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                acc))))))
+    (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (values (unsigned-byte 32)))
+		dotted-to-ipaddr))
+
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors 
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (declare (ignore ignore-cache))
+  (inet-host-name ipaddr) )
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+    (tcp-host-address host)
+    (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+  (declare (ignore stream))
+  (warn "SOCKET-CONTROL function not implemented.")
+  (when (or output-chunking output-chunking-eof input-chunking)
+    (error "Chunking is not yet supported in MCL. Restart the server with argument :chunking nil (turns chunking off).") ) )
+
+
+(provide 'acl-socket)
+
+
+

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-socket-openmcl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,145 @@
+;;; OpenMCL layer for ACL sockets.
+;;; Most everything is already there, just needs to be in the socket package.
+;;;
+;;; John DeSoi, Ph.D. desoi at users.sourceforget.net
+
+(in-package :acl-compat.socket)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (shadowing-import
+   '(;ccl:make-socket                    ; use our own version
+     ccl:accept-connection
+     ccl:dotted-to-ipaddr 
+     ccl:ipaddr-to-hostname
+     ccl:lookup-hostname
+     ccl:remote-host 
+     ccl:remote-port 
+     ccl:local-host 
+     ccl:local-port))
+)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export
+   '(accept-connection
+     ipaddr-to-dotted 
+     dotted-to-ipaddr 
+     ipaddr-to-hostname
+     lookup-hostname
+     remote-host 
+     remote-port 
+     local-host 
+     local-port
+     socket-control))
+  )
+
+
+(defclass server-socket ()
+  ((socket :initarg :socket :reader socket
+           :initform (error "No value supplied for socket"))
+   (port :initarg :port
+	 :reader port
+         :initform (error "No value supplied for port"))))
+
+
+(defmethod print-object ((socket server-socket) stream)
+  (print-unreadable-object (socket stream :type t :identity nil)
+    (format stream "listening on port ~d" (port socket))))
+
+
+(defmethod accept-connection ((server-socket server-socket)
+			      &key (wait t))
+  "Return a bidirectional stream connected to socket."
+  (let ((stream (accept-connection (socket server-socket) :wait wait)))
+    (when stream (make-chunked-stream stream))))
+
+
+(defun make-socket (&rest args
+                    &key (connect :active) port
+                    &allow-other-keys)
+  "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+"
+  (let ((socket-or-stream (apply #'ccl:make-socket args)))
+    (if (eq connect :active)
+        (make-chunked-stream socket-or-stream)
+        (make-instance 'server-socket :socket socket-or-stream :port port))))
+
+
+(defmethod close ((server-socket server-socket) &key abort)
+  "Kill a passive (listening) socket.  (Active sockets are actually
+streams and handled by their close methods."
+  (declare (ignore abort))
+  (close (socket server-socket)))
+
+(defmethod local-host ((server-socket server-socket))
+  (local-host (socket server-socket)))
+
+(defmethod local-port ((server-socket server-socket))
+  (local-port (socket server-socket)))
+
+(defmethod ccl:stream-write-vector
+    ((stream gray-stream::buffered-bivalent-stream) vector start end)
+  (declare (fixnum start end))
+  (let ((fn (gray-stream::%writer-function-for-sequence vector)))
+    (do* ((i start (1+ i)))
+         ((= i end))
+      (declare (fixnum i))
+      (funcall fn stream (ccl:uvref vector i)))))
+
+(defmethod ccl:stream-read-vector
+    ((stream gray-stream::buffered-bivalent-stream) vector start end)
+  (declare (fixnum start end))
+  (let ((fn (gray-stream::%reader-function-for-sequence vector)))
+    (do* ((i start (1+ i)))
+         ((= i end) end)
+      (declare (fixnum i))
+      (let* ((b (funcall fn stream)))
+        (if (eq b :eof)
+            (return i)
+            (setf (ccl:uvref vector i) b))))))
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+                          gray-stream::buffered-bivalent-stream)
+  ((plist :initarg :plist :accessor stream-plist)))
+
+(defun make-chunked-stream (lisp-stream &key plist)
+  (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+(defmethod local-host ((chunked-stream chunked-stream))
+  (local-host (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod local-port ((chunked-stream chunked-stream))
+  (local-port (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod remote-host ((chunked-stream chunked-stream))
+  (remote-host (gray-stream::native-lisp-stream chunked-stream)))
+
+(defmethod remote-port ((chunked-stream chunked-stream))
+  (remote-port (gray-stream::native-lisp-stream chunked-stream)))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+  (when oc-p
+    (when output-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+          output-chunking))
+  (when output-chunking-eof
+    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+  (when ic-p
+    (when input-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+          input-chunking)))
+
+; OpenMCL has a built-in ipaddr-to-dotted. But it appears that sometimes
+; the log function is being called after the connection is closed and
+; it causes nil to be passed to ipaddr-to-dotted. So we wrap ipaddr-to-dotten
+; to ensure only non-nil values are passed.
+
+(defun ipaddr-to-dotted (ipaddr &key values)
+  (unless (null ipaddr)
+    (ccl:ipaddr-to-dotted ipaddr :values values)))
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,20 @@
+
+(in-package :acl-compat.system)
+
+
+(defun command-line-arguments ()
+  #+openmcl (ccl::command-line-arguments)
+  #-openmcl nil)
+
+(defun command-line-argument (n)
+  #+openmcl (nth n (command-line-arguments))
+  #-openmcl nil)
+
+;;; On acl, reap-os-subprocess is needed for (run-shell-command ...
+;;; :wait nil), but not on OpenMCL.
+(defun reap-os-subprocess (&key (wait nil))
+  (declare (ignore wait))
+  nil)
+
+#+nil
+(export '(command-line-arguments command-line-argument reap-os-subprocess))

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-stream-fix.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,44 @@
+
+
+(in-package :ccl)
+
+;;; There are several bugs in MCL functions to read sequences prior to 4.3.5; this fixes them
+
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  
+(let ((ccl:*warn-if-redefine* nil))
+  
+(defun %io-buffer-read-bytes-to-vector (io-buffer vector bytes start)
+  (loop with fill-pointer = start
+        with bytes-remaining = bytes
+        until (eql 0 bytes-remaining)
+        while (if (eql 0 (io-buffer-incount io-buffer))
+                (%io-buffer-advance io-buffer t t)        ; eof may be signalled through this -- JCMa 5/13/1999.
+                t)
+        for buffer =  (io-buffer-inptr io-buffer)
+        for read-bytes = (min (io-buffer-incount io-buffer) bytes-remaining)
+        do (%copy-ptr-to-ivector buffer 0 vector fill-pointer read-bytes)                
+        (incf fill-pointer read-bytes)
+        (%incf-ptr (io-buffer-inptr io-buffer) read-bytes) ;; bug fix from akh on 7/28/2002
+        (decf bytes-remaining read-bytes)
+        (decf (io-buffer-incount io-buffer) read-bytes)
+        (incf (io-buffer-bytes-read io-buffer) read-bytes)))
+
+  
+;This function is unchanged, but kept for completeness
+(defun io-buffer-read-bytes-to-vector (io-buffer vector bytes &optional (start 0))
+  (require-type io-buffer 'io-buffer)
+  (with-io-buffer-locked (io-buffer)
+    (multiple-value-bind (v v-offset) 
+                         (array-data-and-offset vector)
+      (%io-buffer-read-bytes-to-vector io-buffer v bytes (+ start v-offset)))))
+
+  
+(defmethod stream-read-bytes-to-vector ((stream buffered-output-stream-mixin) vector bytes &optional (start 0))
+  (io-buffer-read-bytes-to-vector (stream-io-buffer stream) vector bytes start)) ;original fuction did not get the buffer from the stream
+  
+  
+)
+)
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/mcl/mcl-timers.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,112 @@
+;;; mcl-timers contributed by Gary Byers
+
+(in-package "CCL")
+
+
+;;; A simple timer mechanism for MCL/OpenMCL, which uses a
+;;; PERIODIC-TASK to check for expired "timer requests".
+;;; In MCL and OpenMCL, PERIODIC-TASKS run at specified
+;;; intervals via the same preemption mechanism that the
+;;; scheduler uses; they run in the execution context of
+;;; whatever thread was preempted, and they're assumed to
+;;; run pretty quickly.
+;;; This code uses doubly-linked-list elements (DLL-NODEs)
+;;; to represent a sorted list of "timer requests"; client
+;;; processes use timer requests to schedule an interrupt
+;;; action at a specified time.  A periodic task walks this
+;;; list once a second (by default), removing those requests
+;;; whose time isn't in the future and interrupting the
+;;; corresponding processes.
+
+
+;;; The number of timer interrupts (ticks) per second.
+(defmacro ticks-per-second ()
+  #+OpenMCL '*ticks-per-second*
+  #-OpenMCL 60)
+
+
+(defun expiration-tick-count (seconds)
+  (+ (round (* seconds (ticks-per-second)))
+     (get-tick-count)))
+
+(defstruct (timer-request (:include dll-node)
+			  (:constructor %make-timer-request))
+  expiration-tick			; when the timer expires
+  process				; what process to interrupt
+  function)				; how to interrupt it
+
+
+(defun make-timer-request (seconds-from-now function)
+  (check-type seconds-from-now (and unsigned-byte fixnum))
+  (check-type function function)
+  (%make-timer-request
+   :expiration-tick (expiration-tick-count seconds-from-now)
+   :process *current-process*
+   :function function))
+
+
+;;; the CCL::DEFLOADVAR construct ensures that the variable
+;;; will be reinitialized when a saved image is restarted
+(defloadvar *timer-request-queue*
+    #-openmcl-native-threads (make-dll-header)
+    #+openmcl-native-threads (make-locked-dll-header))
+
+;;; Insert the timer request before the first element with a later
+;;; expiration time (or at the end of the queue if there's no such
+;;; element.)
+(defun enqueue-timer-request (r)
+  (#-openmcl-native-threads without-interrupts
+   #+openmcl-native-threads with-locked-dll-header
+   #+openmcl-native-threads (*timer-request-queue*)
+   (if (dll-node-succ r)                ;  Already enqueued.
+     r                                  ;  Or signal an error.
+     (let* ((r-date (timer-request-expiration-tick r)))
+       (do* ((node *timer-request-queue* next)
+	     (next (dll-node-succ node) (dll-node-succ next)))
+	    ((or (eq next *timer-request-queue*)
+	         (> (timer-request-expiration-tick next) r-date))
+	     (insert-dll-node-after r node)))))))
+
+;;; Remove a timer request.  (It's a no-op if the request has already
+;;; been removed.)
+(defun dequeue-timer-request (r)
+  (#-openmcl-native-threads without-interrupts
+   #+openmcl-native-threads with-locked-dll-header
+   #+openmcl-native-threads (*timer-request-queue*)
+   (when (dll-node-succ r)		;enqueued
+     (remove-dll-node r))
+   r))
+
+;;; Since this runs in an arbitrary process, it tries to be a little
+;;; careful with requests made by the current process (since running
+;;; the interrupt function will probably transfer control out of the
+;;; periodic task function.)  The oldest (hopefully only) request for
+;;; the current process is handled after all other pending requests.
+(defun process-timer-requests ()
+  (let* ((now (get-tick-count))
+         (current-process *current-process*)
+         (current-process-action ()))
+  (#-openmcl-native-threads progn
+   #+openmcl-native-threads with-locked-dll-header
+   #+openmcl-native-threads (*timer-request-queue*)
+
+    (do-dll-nodes (r *timer-request-queue*)
+      (when (> (timer-request-expiration-tick r) now)
+	(return))                       ;  Anything remaining is
+                                        ;  in the future.
+      (dequeue-timer-request r)
+      (let* ((proc (timer-request-process r))
+             (func (timer-request-function r)))
+        (if (eq proc current-process)
+          (if (null current-process-action)
+            (setq current-process-action func))
+          (process-interrupt (timer-request-process r)
+			     (timer-request-function r)))))
+    (when current-process-action
+      (funcall current-process-action)))))
+
+(%install-periodic-task
+ 'process-timer-requests                ; Name of periodic task
+ 'process-timer-requests                ; function to call
+ (ticks-per-second)			; Run once per second
+ )

Added: branches/trunk-reorg/thirdparty/acl-compat/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/packages.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,272 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; Package definitions for acl-compat.
+;;;;
+;;;; Package names follow their Allegro CL counterparts -- for an ACL
+;;;; package foo, acl-compat defines a package acl-compat.foo
+;;;;
+;;;; Some packages have nicknames, which were used as package names by
+;;;; previous versions of paserve and acl-compat.  The nicknames are
+;;;; deprecated, but are kept for the benefit of people using
+;;;; acl-compat in other projects.  New projects should use the
+;;;; package names starting with "acl-compat.".
+;;;;
+
+(in-package :common-lisp-user)
+
+;;; general
+(defpackage :acl-compat.excl
+  (:use #:common-lisp
+        #+cmu #:ext
+        #+clisp #:ext
+        #+sbcl #:sb-ext #+sbcl #:sb-gray
+        #+(or allegro cormanlisp) :excl
+        #+(or mcl openmcl) :ccl
+        )
+  #+lispworks (:import-from :common-lisp #:fixnump)
+  #+sbcl (:import-from :sb-int #:fixnump)
+  #+sbcl (:import-from :sb-ext #:without-package-locks)
+  #+cmu (:import-from :ext #:without-package-locks)
+  #+allegro (:shadowing-import-from :excl #:filesys-size
+	    #:filesys-write-date #:intern* #:filesys-type #:atomically #:fast)
+  (:export
+   #:if*
+   #:*initial-terminal-io*
+   #:*cl-default-special-bindings*
+   #:filesys-size
+   #:filesys-write-date
+   #:stream-input-fn
+   #:match-regexp
+   #:compile-regexp
+   #:*current-case-mode*
+   #:intern*
+   #:filesys-type
+   #:errorset
+   #:atomically
+   #:fast
+   #:without-package-locks
+   #:fixnump
+   #+(or lispworks mcl openmcl) #:socket-error
+   #+(or allegro lispworks mcl openmcl) #:run-shell-command
+   #+(or allegro mcl openmcl) #:fasl-read
+   #+(or allegro mcl openmcl) #:fasl-write
+   #+(or allegro cmu scl mcl lispworks openmcl) #:string-to-octets
+   #+(or allegro cmu scl mcl lispworks openmcl) #:write-vector
+   ))
+
+
+;; general
+(defpackage :acl-compat.mp
+  (:use :common-lisp #+cormanlisp :acl-compat-mp #+allegro :mp)
+  (:nicknames :acl-mp #-cormanlisp :acl-compat-mp)
+  #+allegro (:shadowing-import-from :mp #:process-interrupt #:lock)
+  #+allegro (:shadowing-import-from :excl #:without-interrupts)
+  (:export 
+   #:*current-process*         ;*
+   #:process-kill              ;*
+   #:process-preset            ;*
+   #:process-name              ;*
+
+   #:process-wait-function
+   #:process-run-reasons 
+   #:process-arrest-reasons
+   #:process-whostate
+   #:without-interrupts
+   #:process-wait
+   #:process-enable
+   #:process-disable
+   #:process-reset
+   #:process-interrupt
+
+   #:process-run-function      ;*
+   #:process-property-list     ;*
+   #:without-scheduling        ;*
+   #:process-allow-schedule    ;*
+   #:make-process              ;*
+   #:process-add-run-reason    ;*
+   #:process-revoke-run-reason ;*
+   #:process-add-arrest-reason    ;*
+   #:process-revoke-arrest-reason ;*
+   #:process-allow-schedule    ;*
+   #:with-timeout              ;*
+   #:make-process-lock         ;*
+   #:with-process-lock         ;*
+   #:process-lock
+   #:process-unlock
+
+   #:current-process
+   #:process-name-to-process
+   #:process-wait-with-timeout
+   #:wait-for-input-available
+   #:process-active-p
+   ))
+
+(defpackage :de.dataheaven.chunked-stream-mixin
+  (:use :common-lisp)
+  (:export #:chunked-stream-mixin
+           #:output-chunking-p #:input-chunking-p))
+
+;; general
+(defpackage acl-compat.socket
+  (:use #:common-lisp
+        #+(or cmu lispworks scl) #:acl-mp
+        #+(or lispworks cmu)#:acl-compat.excl
+        #+clisp #:socket
+        #+sbcl #:sb-bsd-sockets
+        #+(or lispworks cmu) #:de.dataheaven.chunked-stream-mixin
+        #+cormanlisp #:socket
+        )
+  #+cl-ssl (:import-from :ssl #:MAKE-SSL-CLIENT-STREAM #:MAKE-SSL-SERVER-STREAM)
+  #+lispworks (:shadow socket-stream stream-error)
+  (:export
+   #+(or lispworks cmu) #:socket
+   #:make-socket
+   #:accept-connection
+   #:ipaddr-to-dotted
+   #:dotted-to-ipaddr
+   #:ipaddr-to-hostname
+   #:lookup-hostname
+   #:remote-host
+   #:remote-port
+   #:local-host
+   #:local-port
+   #:socket-control
+   #+cl-ssl #:make-ssl-client-stream
+   #+cl-ssl #:make-ssl-server-stream
+   #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-client-stream
+   #+(and :lispworks4.4 (not :cl-ssl)) #:make-ssl-server-stream
+   #+lispworks #:socket-os-fd
+   )
+  #-cormanlisp (:nicknames #-(or clisp allegro) socket #-allegro acl-socket))
+
+
+(defpackage acl-compat.system
+  (:nicknames :acl-compat.sys)
+  (:use :common-lisp) 
+  (:export
+   #:command-line-arguments
+   #:command-line-argument
+   #:reap-os-subprocess
+   ))
+
+
+; these are not all in the ccl package which causes an error
+#+(and mcl (not openmcl))
+(shadowing-import '(
+                    fundamental-binary-input-stream
+                    fundamental-binary-output-stream
+                    fundamental-character-input-stream
+                    fundamental-character-output-stream
+                    stream-element-type
+                    stream-listen
+                    stream-read-byte
+                    stream-read-char
+                    stream-peek-char
+                    stream-write-byte
+                    stream-write-char
+                    stream-read-char-no-hang
+                    stream-force-output
+                    stream-finish-output
+                    stream-clear-input
+                    stream-clear-output
+                    stream-line-column
+                    stream-read-sequence
+                    stream-unread-char
+                    stream-read-line
+                    stream-write-sequence
+                    stream-write-string)
+                  :ccl)
+
+#-cormanlisp
+(defpackage :gray-stream
+  (:use #:common-lisp)
+  (:import-from #+lispworks :stream #+cmu :lisp #+clisp :gray #+cormanlisp :gray-streams
+                #+(or mcl openmcl) :ccl #+allegro :excl #+sbcl :sb-gray
+                #:fundamental-binary-input-stream
+                #:fundamental-binary-output-stream
+                #:fundamental-character-input-stream
+                #:fundamental-character-output-stream
+                #:stream-element-type
+                #:stream-listen
+                #:stream-read-byte
+                #:stream-read-char
+                #:stream-peek-char
+                #:stream-write-byte
+                #:stream-write-char
+                #:stream-read-char-no-hang
+                #:stream-force-output
+                #:stream-finish-output
+                #:stream-clear-input
+                #:stream-clear-output
+                #:stream-line-column
+                #-(or clisp openmcl) #:stream-read-sequence
+                #:stream-unread-char
+                #:stream-read-line
+                #-(or clisp openmcl) #:stream-write-sequence
+                #:stream-write-string
+                #+lispworks #:stream-write-buffer
+                #+lispworks #:stream-read-buffer
+                #+lispworks #:stream-fill-buffer
+                #+lispworks #:stream-flush-buffer
+                #+lispworks #:with-stream-input-buffer
+                #+lispworks #:with-stream-output-buffer)
+  (:export 
+   #:fundamental-binary-input-stream
+   #:fundamental-binary-output-stream
+   #:fundamental-character-input-stream
+   #:fundamental-character-output-stream
+   #:stream-element-type
+   #:stream-listen
+   #:stream-read-byte
+   #:stream-read-char
+   #:stream-write-byte
+   #:stream-write-char
+   #:stream-read-char-no-hang
+   #:stream-force-output
+   #:stream-finish-output
+   #:stream-clear-input
+   #:stream-clear-output
+   #:stream-line-column
+   #-clisp #:stream-read-sequence
+   #:stream-unread-char
+   #:stream-read-line
+   #-clisp #:stream-write-sequence
+   #:stream-write-string
+   #:stream-write-buffer
+   #:stream-read-buffer
+   #:stream-fill-buffer
+   #:stream-flush-buffer
+   #:with-stream-input-buffer
+   #:with-stream-output-buffer))
+
+#+cormanlisp
+(defpackage :gray-stream
+  (:use #:common-lisp :gray-streams)
+  (:export 
+   #:fundamental-binary-input-stream
+   #:fundamental-binary-output-stream
+   #:fundamental-character-input-stream
+   #:fundamental-character-output-stream
+   #:stream-element-type
+   #:stream-listen
+   #:stream-read-byte
+   #:stream-read-char
+   #:stream-write-byte
+   #:stream-write-char
+   #:stream-read-char-no-hang
+   #:stream-force-output
+   #:stream-finish-output
+   #:stream-clear-input
+   #:stream-clear-output
+   #:stream-line-column
+   #:stream-read-sequence
+   #:stream-unread-char
+   #:stream-read-line
+   #:stream-write-sequence
+   #:stream-write-string
+   #:stream-write-buffer
+   #:stream-read-buffer
+   #:stream-fill-buffer
+   #:stream-flush-buffer
+   #:with-stream-input-buffer
+   #:with-stream-output-buffer))

Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,32 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+  stream)
+
+(defun filesys-type (file-or-directory-name)
+  (let ((mode (sb-posix:stat-mode (sb-posix:stat file-or-directory-name))))
+    (cond
+      ((sb-posix:s-isreg mode) :file)
+      ((sb-posix:s-isdir mode) :directory)
+      (t nil))))
+
+(defmacro atomically (&body forms)
+  `(acl-mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+  (declare (ignore signal pid))
+  (error "unix-signal not implemented in acl-excl-sbcl.lisp"))
+
+(defun filesys-inode (path)
+  (sb-posix:stat-ino (sb-posix:lstat path)))
+
+(defun cl-internal-real-time ()
+  (round (/ (get-internal-real-time) internal-time-units-per-second)))
+

Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,294 @@
+;; Threading for sbcl, or stub functions for single-threaded sbcl.
+;;
+;; Written by Rudi Schlatte, intended to be distributed along with the
+;; acl-compat library, under the same license as the rest of it.
+
+;; Inspirations taken from Dan Barlow<dan at metacircles.com>'s work for
+;; McCLIM; cut, pasted and mutilated with permission.
+
+(in-package :acl-compat.mp)
+
+(defstruct (process
+            (:constructor %make-process)
+            (:predicate processp))
+  name
+  state
+  whostate
+  function                              ; function wot will be run
+  arguments                             ; arguments to the function
+  id                                    ; pid of unix thread or nil
+  %lock                                 ; lock for process structure mutators
+  run-reasons                           ; primitive mailbox for IPC
+  %queue                                ; queue for condition-wait
+  initial-bindings                      ; special variable bindings
+  property-list)
+
+(defparameter *current-process* 
+  #-sb-thread 
+  (%make-process)
+  #+sb-thread
+  ;; We don't fill in the process id, so the process compiling this
+  ;; (the REPL, in most cases) can't be killed by accident. (loop for
+  ;; p in (all-processes) do (kill-process p)), anyone?
+  (%make-process :name "initial process" :function nil))
+
+(defparameter *all-processes-lock*
+  (sb-thread:make-mutex :name "all processes lock"))
+
+(defparameter *all-processes* 
+  (list *current-process*))
+
+#-sb-thread
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+                           arrest-reasons (priority 0) quantum resume-hook
+                           suspend-hook initial-bindings run-immediately)
+   (declare (ignore reset-action arrest-reasons priority quantum resume-hook
+		    suspend-hook run-immediately))
+   (%make-process :name "the only process"
+		  :run-reasons run-reasons
+		  :initial-bindings initial-bindings))
+
+#+sb-thread
+(defun make-process  (&key (name "Anonymous") reset-action run-reasons
+                      arrest-reasons (priority 0) quantum resume-hook
+                      suspend-hook initial-bindings run-immediately)
+  (declare (ignore reset-action arrest-reasons priority quantum resume-hook
+                   suspend-hook run-immediately))
+  (let ((p (%make-process
+            :name name
+            :run-reasons run-reasons
+            :initial-bindings initial-bindings
+            :%lock (sb-thread:make-mutex
+                    :name (format nil "Internal lock for ~A" name))
+            :%queue (sb-thread:make-waitqueue
+                     :name (format nil "Blocking queue for ~A" name)))))
+    (sb-thread:with-mutex (*all-processes-lock*)
+      (push p *all-processes*))
+    p))
+
+(defmacro defun/sb-thread (name args &body body)
+  #-sb-thread (declare (ignore body))
+  `(defun ,name ,args
+     #-sb-thread
+     (declare (ignore ,@(remove-if
+			 (lambda (x)
+			   (member x '(&optional &rest &key &allow-other-keys
+                                       &aux)))
+			 (mapcar (lambda (x) (if (consp x) (car x) x))
+				 args))))
+     #-sb-thread
+     (error
+      "~A: Calling a multiprocessing function on a single-threaded sbcl build"
+      ',name)
+     #+sb-thread
+     , at body))
+
+(defun/sb-thread process-interrupt (process function)
+  (sb-thread:interrupt-thread (process-id process) function))
+
+;; TODO: why no such function was in +sb-thread part?
+(defun/sb-thread process-wait-function (process)
+  (declare (ignore process)))
+
+(defun/sb-thread process-wait (reason predicate &rest arguments)
+  (declare (type function predicate))
+  (let ((old-state (process-whostate *current-process*)))
+    (unwind-protect
+        (progn
+          (setf old-state (process-whostate *current-process*)
+                (process-whostate *current-process*) reason)
+          (loop 
+           (let ((it (apply predicate arguments)))
+             (when it (return it)))
+           (process-allow-schedule)))
+      (setf (process-whostate *current-process*) old-state))))
+
+(defun/sb-thread process-allow-schedule (&optional process)
+  (declare (ignore process))
+  (sleep .01))
+
+(defun/sb-thread process-revoke-run-reason (process object)
+  (sb-thread:with-recursive-lock ((process-%lock process))
+    (prog1
+        (setf (process-run-reasons process)
+              (delete object (process-run-reasons process)))
+      (when (and (process-id process) (not (process-run-reasons process)))
+        (disable-process process)))))
+
+(defun/sb-thread process-add-run-reason (process object)
+  (sb-thread:with-recursive-lock ((process-%lock process))
+    (prog1
+        (push object (process-run-reasons process))
+      (if (process-id process)
+          (enable-process process)
+          (restart-process process)))))
+
+(defun/sb-thread process-run-function (name-or-options preset-function
+                                                       &rest preset-arguments)
+  (let* ((make-process-args (etypecase name-or-options
+                              (list name-or-options)
+                              (string (list :name name-or-options))))
+         (process (apply #'make-process make-process-args)))
+    (apply #'process-preset process preset-function preset-arguments)
+    (setf (process-run-reasons process) :enable)
+    (restart-process process)
+    process))
+
+(defun/sb-thread process-preset (process function &rest arguments)
+  (setf (process-function process) function
+        (process-arguments process) arguments)
+  (when (process-id process) (restart-process process)))
+
+(defun/sb-thread process-kill (process)
+  (when (process-id process)
+    (sb-thread:destroy-thread (process-id process))
+    (setf (process-id process) nil))
+  (sb-thread:with-mutex (*all-processes-lock*)
+    (setf *all-processes* (delete process *all-processes*))))
+
+#+sb-thread
+(defun make-process-lock (&key name)
+  (sb-thread:make-mutex :name name))
+#-sb-thread
+(defun make-process-lock (&key name)
+  (declare (ignore name))
+  nil)
+
+(defun/sb-thread process-lock (lock &optional lock-value whostate timeout)
+  (declare (ignore whostate timeout))
+  (sb-thread:get-mutex lock lock-value))
+
+(defun/sb-thread process-unlock (lock &optional lock-value)
+  (declare (ignore lock-value))
+  (sb-thread:release-mutex lock))
+
+#-sb-thread
+(defmacro with-process-lock ((lock &key norecursive timeout whostate)
+                             &body forms)
+  (declare (ignore lock norecursive timeout whostate))
+  `(progn , at forms))
+
+#+sb-thread
+(defmacro with-process-lock ((place &key timeout whostate norecursive)
+			     &body body)
+  (declare (ignore norecursive timeout))
+  (let ((old-whostate (gensym "OLD-WHOSTATE")))
+    `(sb-thread:with-recursive-lock (,place)
+      (let (,old-whostate)
+	(unwind-protect
+	     (progn
+	       (when ,whostate
+		 (setf ,old-whostate (process-whostate *current-process*))
+		 (setf (process-whostate *current-process*) ,whostate))
+	       , at body)
+	  (setf (process-whostate *current-process*) ,old-whostate))))))
+
+
+#-sb-thread
+(defmacro without-scheduling (&body forms)
+  `(progn , at forms))                     ; *
+
+;;; FIXME but, of course, we can't.  Fix whoever wants to use it,
+;;; instead
+#+sb-thread
+(defmacro without-scheduling (&body body)
+  `(progn , at body))
+
+;;; Same implementation for multi- and uni-thread
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  (let ((c (gensym "TIMEOUT-")))
+    `(handler-case
+      (sb-ext::with-timeout ,seconds (progn , at body))
+      (sb-ext::timeout (,c) (declare (ignore ,c)) , at timeout-forms))))
+
+(defun/sb-thread restart-process (process)
+  (labels ((boing ()
+                  (let ((*current-process* process)
+                        (bindings (process-initial-bindings process))
+                        (function (process-function process))
+                        (arguments (process-arguments process)))
+		    (declare (type function function))
+                    (if bindings
+                        (progv
+                            (mapcar #'car bindings)
+                            (mapcar #'(lambda (binding)
+                                        (eval (cdr binding)))
+                                    bindings)
+                          (apply function arguments))
+                      (apply function arguments)))))
+    (when (process-id process)
+      (sb-thread:terminate-thread (process-id process)))
+    ;; XXX handle run-reasons in some way?  Should a process continue
+    ;; running if all run reasons are taken away before
+    ;; restart-process is called?  (process-revoke-run-reason handles
+    ;; this, so let's say (setf (process-run-reasons process) nil) is
+    ;; not guaranteed to do the Right Thing.)
+    (when (setf (process-id process)
+                (sb-thread:make-thread #'boing :name (process-name process)))
+      process)))
+
+(defun current-process ()
+  *current-process*)
+
+(defun all-processes ()
+  (copy-list *all-processes*))
+
+(defun/sb-thread process-wait-with-timeout (reason timeout predicate)
+  (declare (type function predicate))
+  (let ((old-state (process-whostate *current-process*))
+        (end-time (+ (get-universal-time) timeout)))
+    (unwind-protect
+        (progn
+          (setf old-state (process-whostate *current-process*)
+                (process-whostate *current-process*) reason)
+          (loop 
+           (let ((it (funcall predicate)))
+             (when (or (> (get-universal-time) end-time) it)
+               (return it)))
+           (sleep .01)))
+      (setf (process-whostate *current-process*) old-state))))
+
+(defun/sb-thread disable-process (process)
+  ;; TODO: set process-whostate
+  ;; Can't figure out how to safely block a thread from a different one
+  ;; and handle all the locking nastiness.  So punt for now.
+  (if (eq sb-thread:*current-thread* (process-id process))
+      ;; Keep waiting until we have a reason to run.  GC and other
+      ;; things can break a wait prematurely.  Don't know if this is
+      ;; expected or not.
+      (do ()
+          ((process-run-reasons process) nil)
+        (sb-thread:with-recursive-lock ((process-%lock process))
+          (sb-thread:condition-wait (process-%queue process)
+                                    (process-%lock process))))
+      (error "Can't safely disable-process from another thread")))
+
+(defun/sb-thread enable-process (process)
+  ;; TODO: set process-whostate
+  (sb-thread:with-recursive-lock ((process-%lock process))
+    (sb-thread:condition-notify (process-%queue process))))
+
+;;; TODO: integrate with McCLIM / system-wide queue for such things
+#+sb-thread
+(defvar *atomic-spinlock* (sb-thread::make-spinlock))
+
+#-sb-thread
+(defmacro atomic-incf (place)
+  `(incf ,place))
+
+#+sb-thread
+(defmacro atomic-incf (place)
+  `(sb-thread::with-spinlock (*atomic-spinlock*)
+    (incf ,place)))
+
+#-sb-thread
+(defmacro atomic-decf (place)
+  `(decf ,place))
+
+#+sb-thread
+(defmacro atomic-decf (place)
+  `(sb-thread::with-spinlock (*atomic-spinlock*)
+    (decf ,place)))
+
+(defun process-active-p (process)
+  (sb-thread:thread-alive-p (process-id process)))

Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,283 @@
+;; This package is designed for sbcl.  It implements the
+;; ACL-style socket interface on top of sbcl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+
+(in-package #:acl-compat.socket)
+
+(defclass server-socket ()
+  ((socket :initarg :socket :reader socket
+           :initform (error "No value supplied for socket"))
+   (element-type :type (member signed-byte unsigned-byte base-char)
+		 :initarg :element-type
+		 :reader element-type
+                 :initform (error "No value supplied for element-type"))
+   (port :type fixnum
+	 :initarg :port
+	 :reader port
+         :initform (error "No value supplied for port"))
+   (stream-type :type (member :text :binary :bivalent)
+                :initarg :stream-type
+                :reader stream-type
+                :initform (error "No value supplied for stream-type"))))
+
+(defclass datagram-socket (server-socket)
+  ())
+
+
+(defmethod print-object ((socket server-socket) stream)
+  (print-unreadable-object (socket stream :type t :identity nil)
+    (format stream "listening on port ~d" (port socket))))
+
+(defmethod print-object ((socket datagram-socket) stream)
+  (print-unreadable-object (socket stream :type t :identity nil)
+    (format stream "datagram socket listening on port ~d" (port socket))))
+
+(defgeneric accept-connection (socket &key wait))
+(defmethod accept-connection ((server-socket server-socket)
+			      &key (wait t))
+  "Return a bidirectional stream connected to socket."
+  (if (sb-sys:wait-until-fd-usable (socket-file-descriptor (socket server-socket))
+                                   :input (if (numberp wait) wait nil))
+      (let* ((socket (socket-accept (socket server-socket)))
+             (stream (socket-make-stream socket
+                                         :input t :output t
+                                        ; :buffering :none
+                                         :element-type
+                                         (element-type server-socket)
+                                         :auto-close t)))
+        (if (eq (stream-type server-socket) :bivalent)
+            ;; HACK: remember socket, so we can do peer lookup
+            (make-bivalent-stream stream :plist `(:socket ,socket))
+            stream))
+      nil))
+
+(defmethod receive-from ((socket datagram-socket) size &key buffer extract)
+  (multiple-value-bind (rbuf len address port)
+      (socket-receive (socket socket) buffer size)
+    (declare (ignore port))
+    (let ((buf
+	   (if (not extract) 
+	       rbuf
+	     (subseq rbuf 0 len)))) ;; FIXME: am I right?
+      (when buffer
+	  (replace buffer buf :end2 len))
+      (values
+       (if buffer buffer buf)
+       len
+       address))))
+
+(defmethod send-to ((socket datagram-socket) buffer size &key remote-host remote-port)
+  (let* ((rhost (typecase remote-host
+		  (string (lookup-hostname remote-host))
+		  (otherwise remote-host)))
+	 (s (socket socket))
+	 (stream (progn
+		   (socket-connect s rhost remote-port)
+		   (socket-make-stream s :input t :output t :buffering :none))))
+    (write-sequence buffer stream)
+    size))
+    
+     
+
+(defun make-socket (&key 
+		    (type :stream)
+		    (remote-host "localhost")
+                    local-port
+                    remote-port
+                    (connect :active)
+                    (format :text)
+                    (reuse-address t)
+                    &allow-other-keys)
+  "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe.  Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+  (check-type remote-host string)
+  (let ((element-type (ecase format
+			(:text 'base-char)
+			(:binary 'signed-byte)
+                        (:bivalent 'unsigned-byte)))
+        (socket 
+	 (if (eq type :datagram)
+	     (progn
+	       (setf connect :passive-udp)
+	       (make-instance 'inet-socket :type :datagram :protocol :udp))
+	   (make-instance 'inet-socket :type :stream :protocol :tcp))))
+    (ecase connect
+      (:passive-udp
+       (setf (sockopt-reuse-address socket) reuse-address)
+       (if local-port
+	   (socket-bind socket #(0 0 0 0) local-port))
+       (make-instance 'datagram-socket
+                      :port (nth-value 1 (socket-name socket))
+                      :socket socket
+                      :element-type element-type
+                      :stream-type format))
+      (:passive
+       (setf (sockopt-reuse-address socket) reuse-address)
+       (if local-port
+	   (socket-bind socket #(0 0 0 0) local-port))
+       (socket-listen socket 10)        ;Arbitrarily chosen backlog value
+       (make-instance 'server-socket
+                      :port (nth-value 1 (socket-name socket))
+                      :socket socket
+                      :element-type element-type
+                      :stream-type format))
+      (:active
+       (socket-connect socket (lookup-hostname remote-host) remote-port)
+       (let ((stream (socket-make-stream socket :input t :output t
+                                         :element-type element-type
+                                        ; :buffering :none
+                                           )))
+           (if (eq :bivalent format)
+               ;; HACK: remember socket, so we can do peer lookup
+               (make-bivalent-stream stream :plist `(:socket ,socket))
+               stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+  "Kill a passive (listening) socket.  (Active sockets are actually
+streams and handled by their close methods."
+  (declare (ignore abort))
+  (socket-close (socket server)))
+
+#+ignore
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+                          (or (values fixnum fixnum fixnum fixnum)
+			      (values simple-string)))
+		ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+  "Convert from 32-bit integer to dotted string."
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (if values
+	(values a b c d)
+      (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun ipaddr-to-vector (ipaddr)
+  "Convert from 32-bit integer to a vector of octets."
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (make-array 4 :initial-contents (list a b c d))))
+
+(declaim (ftype (function (vector)
+                          (values (unsigned-byte 32)))
+                vector-to-ipaddr))
+(defun vector-to-ipaddr (sensible-ipaddr)
+  "Convert from 4-integer vector to 32-bit integer."
+  (loop with result = 0
+        for component across sensible-ipaddr
+        do (setf result (+ (ash result 8) component))
+        finally (return result)))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+                      (let ((pos2 (position #\Space str :start pos1)))
+                        (if (not pos2)
+                            (nreverse acc)
+                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                         acc))))))
+    (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (or null (unsigned-byte 32)))
+		dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  "Convert from dotted string to 32-bit integer."
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors
+	(let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	  (+ (ash (first ll) 24) (ash (second ll) 16)
+	     (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+  (host-ent-name (get-host-by-address (ipaddr-to-vector ipaddr))))
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (host-ent-address (get-host-by-name host))
+      (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defun remote-host (socket-stream)
+  (let (socket)
+    (if (and (typep socket-stream 'chunked-stream)
+             (setf socket (getf (stream-plist socket-stream) :socket)))
+        (vector-to-ipaddr (socket-peername socket))
+        (progn (warn "Could not get remote host for ~S" socket-stream)
+               0))))
+
+(defun remote-port (socket-stream)
+  (let (socket)
+    (if (and (typep socket-stream 'chunked-stream)
+             (setq socket (getf (stream-plist socket-stream) :socket)))
+        (nth-value 1 (socket-peername socket))
+        (progn (warn "Could not get remote port for ~S" socket-stream)
+               0))))
+
+(defun local-host (thing)
+  (typecase thing
+    (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
+                      (if socket (vector-to-ipaddr (socket-name socket))
+                        (progn (warn "Socket not in plist of ~S -- could not get local host" thing)
+                               0))))
+    (server-socket (vector-to-ipaddr #(127 0 0 1)))
+    (t (progn (warn "Could not get local host for ~S" thing)
+              0))))
+
+(defun local-port (thing)
+  (typecase thing
+    (chunked-stream (let ((socket (getf (stream-plist thing) :socket)))
+                      (if socket (nth-value 1 (socket-name socket))
+                        (progn (warn "Socket not in plist of ~S -- could not get local port" thing)
+                               0))))
+    (server-socket (port thing))
+    (t (progn (warn "Could not get local port for ~S" thing)
+              0))))
+
+;; Now, throw chunking in the mix
+
+(defclass chunked-stream (de.dataheaven.chunked-stream-mixin::chunked-stream-mixin
+                          gray-stream::buffered-bivalent-stream)
+  ((plist :initarg :plist :accessor stream-plist)))
+
+
+(defun make-bivalent-stream (lisp-stream &key plist)
+  (make-instance 'chunked-stream :lisp-stream lisp-stream :plist plist))
+
+
+(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
+  (when oc-p
+    (when output-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::output-chunking-p stream)
+          output-chunking))
+  (when output-chunking-eof
+    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
+  (when ic-p
+    (when input-chunking
+      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
+    (setf (de.dataheaven.chunked-stream-mixin::input-chunking-p stream)
+          input-chunking)))
+
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/sbcl/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,11 @@
+(in-package :acl-compat.system)
+
+(defun command-line-arguments ()
+  sb-ext:*posix-argv*)
+
+(defun command-line-argument (n)
+  (nth n sb-ext:*posix-argv*))
+
+(defun reap-os-subprocess (&key (wait nil))
+  (declare (ignore wait))
+  nil)

Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-excl.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,264 @@
+;;;;
+;;;; ACL-COMPAT - EXCL
+;;;;
+
+;;;; Implementation-specific parts of acl-compat.excl (see
+;;;; acl-excl-common.lisp)
+
+(defpackage :acl-compat.excl
+	(:use #:common-lisp #:ext)
+	(:export
+         #:if*
+         #:*initial-terminal-io*
+         #:*cl-default-special-bindings*
+         #:filesys-size
+         #:filesys-write-date
+         #:stream-input-fn
+         #:match-regexp
+         #:compile-regexp
+         #:*current-case-mode*
+         #:intern*
+         #:filesys-type
+         #:errorset
+         #:atomically
+         #:fast
+         #:without-package-locks
+         #:string-to-octets
+         #:write-vector
+
+         ;; TODO: find better place for bivalent stream classes
+         #:bivalent-input-stream
+         #:bivalent-output-stream
+         #:bivalent-stream
+         #:make-bivalent-input-stream
+         #:make-bivalent-output-stream
+         #:make-bivalent-stream
+         ))
+
+(in-package :acl-compat.excl)
+
+(defun stream-input-fn (stream)
+  stream)
+
+(defun filesys-type (file-or-directory-name)
+       (if (eq :directory (unix:unix-file-kind
+                           (namestring file-or-directory-name)))
+           :directory
+         (if (probe-file file-or-directory-name)
+             :file
+           nil)))
+
+(defmacro atomically (&body forms)
+  `(mp:without-scheduling , at forms))
+
+(defun unix-signal (signal pid)
+  ;; fixxme: did I get the arglist right?  only invocation I have seen
+  ;; is (excl::unix-signal 15 0) in net.aserve:start
+  (unix:unix-kill pid signal))
+
+(defmacro without-package-locks (&body forms)
+  `(progn , at forms))
+
+
+;;; Bivalent Gray streams
+
+
+(defclass lisp-stream-mixin ()
+  ;; For bivalent streams, lisp-stream must be a stream of type
+  ;; unsigned-byte
+  ((lisp-stream :initarg :lisp-stream
+		:accessor lisp-stream)))
+
+(defclass bivalent-input-stream (lisp-stream-mixin
+                                 fundamental-character-input-stream
+                                 fundamental-binary-input-stream))
+
+(defclass bivalent-output-stream (lisp-stream-mixin
+                                  fundamental-character-output-stream
+                                  fundamental-binary-output-stream))
+
+(defclass bivalent-stream (bivalent-input-stream bivalent-output-stream))
+
+
+(defun make-bivalent-input-stream (lisp-stream)
+  (declare (type system:lisp-stream lisp-stream))
+  (make-instance 'bivalent-input-stream :lisp-stream lisp-stream))
+
+(defun make-bivalent-output-stream (lisp-stream)
+  (declare (type system:lisp-stream lisp-stream))
+  (make-instance 'bivalent-output-stream :lisp-stream lisp-stream))
+
+(defun make-bivalent-stream (lisp-stream)
+  (declare (type system:lisp-stream lisp-stream))
+  (make-instance 'bivalent-stream :lisp-stream lisp-stream))
+
+
+(defmethod open-stream-p ((stream lisp-stream-mixin))
+  (common-lisp::open-stream-p (lisp-stream stream)))
+
+(defmethod close ((stream lisp-stream-mixin) &key abort)
+  (close (lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream lisp-stream-mixin))
+  (input-stream-p (lisp-stream stream)))
+
+(defmethod output-stream-p ((stream lisp-stream-mixin))
+  (output-stream-p (lisp-stream stream)))
+
+(defmethod stream-element-type ((stream bivalent-input-stream))
+  '(or character (unsigned-byte 8)))
+
+(defmethod stream-read-char ((stream bivalent-input-stream))
+  (code-char (read-byte (lisp-stream stream) nil :eof)))
+
+(defmethod stream-read-byte ((stream bivalent-input-stream))
+  (read-byte (lisp-stream stream) nil :eof))
+
+;; stream-unread-char
+
+(defmethod stream-read-char-no-hang ((stream bivalent-input-stream))
+  (if (listen (lisp-stream stream))
+      (code-char (read-byte (lisp-stream stream)))
+      nil))
+
+;; stream-peek-char
+
+(defmethod stream-listen ((stream bivalent-input-stream))
+  (listen (lisp-stream stream)))
+
+(defmethod stream-clear-input ((stream bivalent-input-stream))
+  (clear-input (lisp-stream stream)))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+                                 (seq vector) &optional start end)
+  (unless start (setf start 0))
+  (unless end (setf end (length seq)))
+  (assert (<= end (length seq)))
+  (if (subtypep (array-element-type seq) 'character)
+      (loop for count upfrom start
+            for i from start below end
+            do (setf (aref seq i) (code-char (read-byte stream)))
+            finally (return count))
+      (read-sequence seq (lisp-stream stream)
+                     :start start :end end)))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+                                 (seq cons) &optional (start 0) end)
+  (unless start (setf start 0))
+  (unless end (setf end (length seq)))
+  (let ((seq (nthcdr start seq)))
+    (loop for count upfrom start
+          for head on seq
+          for i below (- end start)
+          while head
+          do (setf (car head) (read-byte stream))
+          finally (return count))))
+
+(defmethod stream-read-sequence ((stream bivalent-input-stream)
+                                 (seq null) &optional (start 0) end)
+  (declare (ignore end))
+  start)
+
+(defmethod stream-element-type ((stream bivalent-output-stream))
+  '(or character (unsigned-byte 8)))
+
+(defmethod stream-write-char ((stream bivalent-output-stream) character)
+  (write-byte (char-code character) (lisp-stream stream)))
+
+(defmethod stream-write-byte ((stream bivalent-output-stream) byte)
+  (write-byte byte (lisp-stream stream)))
+
+(defmethod stream-line-column ((stream bivalent-output-stream))
+  nil)
+
+(defmethod stream-finish-output ((stream bivalent-output-stream))
+  (finish-output (lisp-stream stream)))
+
+(defmethod stream-force-output ((stream bivalent-output-stream))
+  (force-output (lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream bivalent-output-stream))
+  (clear-output (lisp-stream stream)))
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+                                  (seq vector) &optional (start 0) end)
+  (let ((length (length seq)))
+    (unless end (setf end length))
+    (assert (<= end length)))
+  (unless start (setf start 0))
+  (when (< end start)
+    (cerror "Continue with switched start and end ~s <-> ~s"
+            "Stream-write-sequence: start (~S) and end (~S) exchanged."
+            start end seq)
+    (rotatef start end))
+  (cond
+    ((subtypep (array-element-type seq) '(unsigned-byte 8))
+     (write-sequence seq (lisp-stream stream) :start start :end end))
+    ((subtypep (array-element-type seq) 'character)
+     (loop for i from start below end
+            do (stream-write-char stream (aref seq i))))
+    ((subtypep (array-element-type seq) 'integer)
+     (loop for i from start below end
+           do (stream-write-byte stream (aref seq i)))))
+  seq)
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+                                  (seq cons) &optional (start 0) end)
+  (let ((length (length seq)))
+    (unless end (setf end length))
+    (assert (<= end length)))
+  (unless start (setf start 0))
+  (when (< end start)
+    (cerror "Continue with switched start and end ~s <-> ~s"
+            "Stream-write-sequence: start (~S) and end (~S) exchanged."
+            start end seq)
+    (rotatef start end))
+  (let ((seq (nthcdr start seq)))
+    (loop for element in seq
+          for i below (- end start)
+          while seq
+          do (etypecase element
+               (character (stream-write-char stream element))
+               (integer (stream-write-byte stream element)))))
+  seq)
+
+(defmethod stream-write-sequence ((stream bivalent-output-stream)
+                                  (seq null) &optional (start 0) end)
+  (declare (ignore start end))
+  seq)
+
+;;; End bivalent Gray streams
+
+(defun string-to-octets (string &key (null-terminate t) (start 0)
+                         end mb-vector make-mb-vector?
+                         (external-format :default))
+  "This function returns a lisp-usb8-vector and the number of bytes copied."
+  (declare (ignore external-format))
+  ;; The end parameter is different in ACL's lambda list, but this
+  ;; variant lets us give an argument :end nil explicitly, and the
+  ;; right thing will happen
+  (unless end (setf end (length string)))
+  (let* ((number-of-octets (if null-terminate (1+ (- end start))
+                               (- end start)))
+         (mb-vector (cond
+                      ((and mb-vector (>= (length mb-vector) number-of-octets))
+                       mb-vector)
+                      ((or (not mb-vector) make-mb-vector?)
+                       (make-array (list number-of-octets)
+                                   :element-type '(unsigned-byte 8)
+                                   :initial-element 0))
+                      (t (error "Was given a vector of length ~A, ~
+                                 but needed at least length ~A."
+                                (length mb-vector) number-of-octets)))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) mb-vector))
+    (loop for from-index from start below end
+       for to-index upfrom 0
+       do (progn
+            (setf (aref mb-vector to-index)
+                  (char-code (aref string from-index)))))
+    (when null-terminate
+      (setf (aref mb-vector (1- number-of-octets)) 0))
+    (values mb-vector number-of-octets)))
+
+
+(provide 'acl-excl)

Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-mp.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,155 @@
+;; This package is designed for cmucl.  It implements ACL-style
+;; multiprocessing on top of cmucl (basically, process run reasons and
+;; some function renames).
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks.
+
+(in-package :acl-compat-mp)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Import equivalent parts from the CMU MP package ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(shadowing-import '(mp:*current-process*
+                    ;; mp::process-preset
+                    mp::process-reset
+                    mp:process-interrupt
+                    mp::process-name
+                    mp::process-wait-function
+                    mp:process-run-reasons
+                    mp:process-add-run-reason
+                    mp:process-revoke-run-reason
+                    mp:process-arrest-reasons
+                    mp:process-add-arrest-reason
+                    mp:process-revoke-arrest-reason
+                    mp:process-whostate
+                ;    mp:without-interrupts
+                    mp:process-wait
+                    mp:with-timeout
+		    mp:without-scheduling
+                    ))
+
+(export '(*current-process*
+          ;; process-preset
+          process-reset
+          process-interrupt
+          process-name
+          process-wait-function
+          process-whostate
+          process-wait
+          with-timeout
+          without-scheduling
+          process-run-reasons
+          process-add-run-reason
+          process-revoke-run-reason
+          process-arrest-reasons
+          process-add-arrest-reason
+          process-revoke-arrest-reason
+          ))
+
+
+(defun process-allow-schedule ()
+  (mp:process-yield))
+
+(defvar *process-plists* (make-hash-table :test #'eq)
+  "maps processes to their plists.
+See the functions process-plist, (setf process-plist).")
+
+(defun process-property-list (process)
+  (gethash process *process-plists*))
+
+(defun (setf process-property-list) (new-value process)
+  (setf (gethash process *process-plists*) new-value))
+
+#||
+
+;;; rudi 2002-06-09: This is not needed as of cmucl 18d, thanks to Tim
+;;; Moore who added run reasons to cmucl's multithreading.  Left in
+;;; for the time being just in case someone wants to get acl-compat
+;;; running on older cmucl's.  Can be deleted safely.
+
+(defvar *process-run-reasons* (make-hash-table :test #'eq)
+  "maps processes to their run-reasons.
+See the functions process-run-reasons, (setf process-run-reasons),
+process-add-run-reason, process-revoke-run-reason.")
+
+(defun process-run-reasons (process)
+  (gethash process *process-run-reasons*))
+
+(defun (setf process-run-reasons) (new-value process)
+  (mp:without-scheduling
+   (prog1
+       (setf (gethash process *process-run-reasons*) new-value)
+     (if new-value
+         (mp:enable-process process)
+       (mp:disable-process process)))))
+
+(defun process-revoke-run-reason (process object)
+  (without-scheduling
+   (setf (process-run-reasons process)
+	 (remove object (process-run-reasons process))))
+  (when (and (eq process mp:*current-process*))
+    (mp:process-yield)))
+
+(defun process-add-run-reason (process object)
+  (setf (process-run-reasons process)
+        (pushnew object (process-run-reasons process))))
+||#
+
+(defun process-run-function (name-or-options preset-function
+                             &rest preset-arguments)
+  (let ((process (ctypecase name-or-options
+                   (string (make-process :name name-or-options))
+                   (list (apply #'make-process name-or-options)))))
+    (apply #'acl-mp::process-preset process preset-function preset-arguments)
+    process))
+
+(defun process-preset (process preset-function &rest arguments)
+  (mp:process-preset process
+                     #'(lambda ()
+                         (apply-with-bindings preset-function
+                                              arguments
+                                              (process-initial-bindings process)))))
+
+(defvar *process-initial-bindings* (make-hash-table :test #'eq))
+
+(defun process-initial-bindings (process)
+  (gethash process *process-initial-bindings*))
+
+(defun (setf process-initial-bindings) (bindings process)
+  (setf (gethash process *process-initial-bindings*) bindings))
+
+
+;;;                          ;;;
+;;; Contributed by Tim Moore ;;;
+;;;	                     ;;;
+(defun apply-with-bindings (function args bindings)
+  (if bindings
+      (progv
+	  (mapcar #'car bindings)
+	  (mapcar #'(lambda (binding)
+		      (eval (cdr binding))))
+	(apply function args))
+      (apply function args)))
+
+(defun make-process (&key (name "Anonymous") reset-action run-reasons
+                     arrest-reasons (priority 0) quantum resume-hook
+                     suspend-hook initial-bindings run-immediately)
+  (declare (ignore priority quantum reset-action resume-hook suspend-hook
+                   run-immediately))
+  (mp:make-process nil :name name
+                   :run-reasons run-reasons
+                   :arrest-reasons arrest-reasons
+                   :initial-bindings initial-bindings))
+
+(defun process-kill (process)
+  (mp:destroy-process process))
+
+
+(defun make-process-lock (&key name)
+  (mp:make-lock name))
+
+(defmacro with-process-lock ((lock &key norecursive) &body forms)
+  (declare (ignore norecursive))
+  `(mp:with-lock-held (,lock) , at forms))

Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,196 @@
+;; This package is designed for scl.  It implements the
+;; ACL-style socket interface on top of scl.
+;;
+;; Written by Rudi Schlatte, based on the work done by Jochen Schmidt
+;; for Lispworks and net.lisp in the port library of CLOCC.
+;;
+;; This was modified for SCL by Kevin Rosenberg
+
+(defpackage acl-socket
+  (:use "MP" "COMMON-LISP")
+  #+cl-ssl (:import-from :ssl "MAKE-SSL-CLIENT-STREAM" "MAKE-SSL-SERVER-STREAM")
+  (:export #:socket #:make-socket #:accept-connection
+   #:ipaddr-to-dotted #:dotted-to-ipaddr #:ipaddr-to-hostname #:lookup-hostname
+   #:remote-host #:remote-port #:local-host #:local-port #:socket-control
+   #+cl-ssl #:make-ssl-client-stream #+cl-ssl #:make-ssl-server-stream)
+  (:nicknames socket))
+
+(in-package socket)
+
+(defclass socket ()
+  ((fd :type fixnum
+       :initarg :fd
+       :reader fd)))
+
+(defmethod print-object ((socket socket) stream)
+  (print-unreadable-object (socket stream :type t :identity t)
+    (format stream "@~d" (fd socket))))
+
+(defclass server-socket (socket)
+  ((element-type :type (member signed-byte unsigned-byte base-char)
+		 :initarg :element-type
+		 :reader element-type
+                 :initform (error "No value supplied for element-type"))
+   (port :type fixnum
+	 :initarg :port
+	 :reader port
+         :initform (error "No value supplied for port"))
+   (stream-type :type (member :text :binary :bivalent)
+                :initarg :stream-type
+                :reader stream-type
+                :initform (error "No value supplied for stream-type"))))
+
+#+cl-ssl
+(defmethod make-ssl-server-stream ((lisp-stream system:lisp-stream)
+                                   &rest options)
+  (apply #'make-ssl-server-stream (system:fd-stream-fd lisp-stream) options))
+
+(defmethod print-object ((socket server-socket) stream)
+  (print-unreadable-object (socket stream :type t :identity nil)
+    (format stream "@~d on port ~d" (fd socket) (port socket))))
+
+(defmethod accept-connection ((server-socket server-socket)
+			      &key (wait t))
+  "Return a bidirectional stream connected to socket, or nil if no
+client wanted to initiate a connection and wait is nil."
+  ;; fixxme: perhaps check whether we run multiprocessing and use
+  ;; sys:wait-until-fd-usable instead of
+  ;; mp:process-wait-until-fd-usable here?
+
+  ;; api pipe fitting: wait t ==> timeout nil
+  (when (mp:process-wait-until-fd-usable (fd server-socket) :input
+                                         (if wait nil 0))
+    (let ((stream (sys:make-fd-stream
+                   (ext:accept-tcp-connection (fd server-socket))
+                   :input t :output t
+                   :element-type (element-type server-socket)
+                   :auto-close t)))
+      (if (eq (stream-type server-socket) :bivalent)
+          (excl:make-bivalent-stream stream)
+          stream))))
+
+(defun make-socket (&key (remote-host "localhost")
+			 local-port
+			 remote-port
+			 (connect :active)
+			 (format :text)
+			 &allow-other-keys)
+  "Return a stream connected to remote-host if connect is :active, or
+something listening on local-port that can be fed to accept-connection
+if connect is :passive.
+
+This is an incomplete implementation of ACL's make-socket function!
+It was written to provide the functionality necessary to port
+AllegroServe.  Refer to
+http://franz.com/support/documentation/6.1/doc/pages/operators/socket/make-socket.htm
+to read about the missing parts."
+  (check-type remote-host string)
+  (let ((element-type (ecase format
+			(:text 'base-char)
+			(:binary 'signed-byte)
+                        (:bivalent 'unsigned-byte))))
+    (ecase connect
+      (:passive
+         (make-instance 'server-socket
+		        :port local-port
+                        :fd (ext:create-inet-listener local-port)
+                        :element-type element-type
+                        :stream-type format))
+      (:active
+       (let ((stream (sys:make-fd-stream
+                      (ext:connect-to-inet-socket remote-host remote-port)
+                      :input t :output t :element-type element-type)))
+         (if (eq :bivalent format)
+             (excl:make-bivalent-stream stream)
+             stream))))))
+
+(defmethod close ((server server-socket) &key abort)
+  "Kill a passive (listening) socket.  (Active sockets are actually
+streams and handled by their close methods."
+  (declare (ignore abort))
+  (unix:unix-close (fd server)))
+
+(declaim (ftype (function ((unsigned-byte 32) &key (:values t))
+                          (values simple-string))
+		ipaddr-to-dotted))
+(defun ipaddr-to-dotted (ipaddr &key values)
+  (declare (type (unsigned-byte 32) ipaddr))
+  (let ((a (logand #xff (ash ipaddr -24)))
+	(b (logand #xff (ash ipaddr -16)))
+	(c (logand #xff (ash ipaddr -8)))
+	(d (logand #xff ipaddr)))
+    (if values
+	(values a b c d)
+      (format nil "~d.~d.~d.~d" a b c d))))
+
+(defun string-tokens (string)
+  (labels ((get-token (str pos1 acc)
+                      (let ((pos2 (position #\Space str :start pos1)))
+                        (if (not pos2)
+                            (nreverse acc)
+                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
+                                                         acc))))))
+    (get-token (concatenate 'string string " ") 0 nil)))
+
+(declaim (ftype (function (string &key (:errorp t))
+                          (values (unsigned-byte 32)))
+		dotted-to-ipaddr))
+(defun dotted-to-ipaddr (dotted &key (errorp t))
+  (declare (string dotted))
+  (if errorp
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll)))
+    (ignore-errors
+      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
+
+(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
+  (ext:host-entry-name (ext:lookup-host-entry ipaddr)))
+
+(defun lookup-hostname (host &key ignore-cache)
+  (when ignore-cache
+    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
+  (if (stringp host)
+      (car (ext:host-entry-addr-list (ext:lookup-host-entry host)))
+      (dotted-to-ipaddr (ipaddr-to-dotted host))))
+
+(defgeneric get-fd (stream))
+
+(defmethod get-fd ((stream excl::lisp-stream-mixin))
+  (system:fd-stream-fd (excl::lisp-stream stream)))
+
+(defmethod get-fd ((stream system:lisp-stream))
+  (system:fd-stream-fd stream))
+
+(defun remote-host (socket-stream)
+  (ext:get-peer-host-and-port (get-fd socket-stream)))
+
+(defun remote-port (socket-stream)
+    (multiple-value-bind (host port)
+        (ext:get-peer-host-and-port (get-fd socket-stream))
+      (declare (ignore host))
+      port))
+
+(defun local-host (socket-stream)
+  (ext:get-socket-host-and-port (get-fd socket-stream)))
+
+(defun local-port (socket-stream)
+  (if (typep socket-stream 'socket::server-socket)
+      (port socket-stream)
+      (multiple-value-bind (host port)
+          (ext:get-socket-host-and-port (get-fd socket-stream))
+        (declare (ignore host))
+        port)))
+
+(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
+  (declare (ignore stream))
+  (warn "SOCKET-CONTROL function not implemented.")
+  (when (or output-chunking output-chunking-eof input-chunking)
+    (error "Chunking is not yet supported in scl. Restart the server with chunking off.")))
+
+
+(provide 'acl-socket)

Added: branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/scl/acl-sys.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,18 @@
+(in-package :sys)
+
+(ignore-errors
+(export 'command-line-arguments)
+(export 'command-line-argument)
+(export 'reap-os-subprocess)
+
+(defun command-line-arguments ()
+  ext:*command-line-strings*)
+
+(defun command-line-argument (n)
+  (nth n ext:*command-line-strings*))
+
+(defun reap-os-subprocess (&key (wait nil))
+  (declare (ignore wait))
+  nil)
+
+)

Added: branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/acl-compat/test-acl-socket.lisp	Thu Feb  7 03:21:48 2008
@@ -0,0 +1,61 @@
+;;; Unit tests for the ACL-SOCKET compatibility package.
+
+(in-package cl-user)
+
+(require :acl-socket)
+
+(use-package '(acl-socket))
+
+(defun test1 ()
+  (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+    (when stream
+      (read-line stream)
+      (format stream "helo foo")
+      (write-char #\Return stream)
+      (write-char #\Linefeed stream)
+      (finish-output stream)
+      (read-line stream)
+      (close stream))))
+
+(defun test2 ()
+  (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+    (when stream
+      (socket-control stream :output-chunking t)
+      (read-line stream)
+      (format stream "helo foo")
+      (write-char #\Return stream)
+      (write-char #\Linefeed stream)
+      (finish-output stream)
+      (read-line stream)
+      (close stream))))
+
+(defun test3 ()
+  (let ((stream (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)))
+    (when stream
+      (socket-control stream :input-chunking t)
+      (prog1
+          (read-line stream)
+        (close stream)))))
+
+(defun test4 ()
+  (let ((stream (or (make-socket :connect :active :remote-host "127.0.0.1" :remote-port 2500)
+                    (error "Failed to connect."))))
+    (socket-control stream :input-chunking t)
+    (format t "File number 1: ")
+    #1=(handler-case
+	   (loop
+	    for char = (read-char stream nil stream)
+	    until (eq char stream)
+	    do (write-char char))
+	 (excl::socket-chunking-end-of-file (e) (socket-control stream :input-chunking t)))
+    (format t "~%File number 2: ")
+    #1#
+    (terpri)
+    (values)))
+
+
+        
+  
+
+
+


From hhubner at common-lisp.net  Thu Feb  7 08:30:36 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu,  7 Feb 2008 03:30:36 -0500 (EST)
Subject: [bknr-cvs] r2451 - in branches/trunk-reorg/bknr: datastore/src/data
	datastore/src/utils web/src web/src/rss web/src/web
Message-ID: <20080207083036.654327C051@common-lisp.net>

Author: hhubner
Date: Thu Feb  7 03:30:34 2008
New Revision: 2451

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/object.lisp
   branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp
   branches/trunk-reorg/bknr/web/src/bknr-web.asd
   branches/trunk-reorg/bknr/web/src/packages.lisp
   branches/trunk-reorg/bknr/web/src/rss/rss.lisp
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/host.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
Log:
save current state

Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/object.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp	Thu Feb  7 03:30:34 2008
@@ -574,8 +574,7 @@
 			    (if restoring
 				(remove-transient-slot-initargs (find-class class-name) initargs)
 				initargs)))
-	   (unless restoring
-	     (initialize-persistent-instance obj))
+	   (initialize-persistent-instance obj)
 	   (initialize-transient-instance obj)
 	   (setf error nil)
 	   obj)

Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp	Thu Feb  7 03:30:34 2008
@@ -511,7 +511,7 @@
   (with-open-file (s pathname :element-type '(unsigned-byte 8))
     (let ((result
            (make-array (file-length s) :element-type '(unsigned-byte 8))))
-      (read-sequence result s )
+      (read-sequence result s)
       result)))
 
 (defun class-subclasses (class)

Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd
==============================================================================
--- branches/trunk-reorg/bknr/web/src/bknr-web.asd	(original)
+++ branches/trunk-reorg/bknr/web/src/bknr-web.asd	Thu Feb  7 03:30:34 2008
@@ -31,6 +31,7 @@
 		 :hunchentoot
 		 :xhtmlgen
 		 :puri
+		 :usocket
 		 :bknr-datastore
 		 :bknr-data-impex
 		 :parenscript)

Modified: branches/trunk-reorg/bknr/web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/packages.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/packages.lisp	Thu Feb  7 03:30:34 2008
@@ -263,6 +263,7 @@
 
 	   ;; templates
 	   #:expand-template
+	   #:expand-variables
 	   #:get-template-var
 	   #:with-template-vars
 	   #:emit-template-node
@@ -313,6 +314,7 @@
 	   #:object-handler
 	   #:edit-object-handler
 	   #:template-handler
+	   #:template-handler-destination
 	   #:page-handler
 	   #:page-handler-prefix
 	   #:page-handler-site

Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/rss/rss.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp	Thu Feb  7 03:30:34 2008
@@ -129,7 +129,7 @@
   (remove-item (rss-item-channel rss-item) rss-item))
 
 (defun item-slot-element (item slot-name)
-  (let ((accessor (kmrcl:concat-symbol-pkg (find-package :bknr.rss) 'rss-item- slot-name)))
+  (let ((accessor (find-symbol (format nil "RSS-ITEM-~A" slot-name) (find-package :bknr.rss))))
     (aif (funcall accessor item)
 	 (with-element (string-downcase (symbol-name slot-name))
 	   (text it)))))

Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Thu Feb  7 03:30:34 2008
@@ -557,4 +557,4 @@
 
 (defun unpublish ()
   (setf *dispatch-table* (remove 'bknr-handler *dispatch-table*)
-	*handlers* nil))
\ No newline at end of file
+	*handlers* nil))

Modified: branches/trunk-reorg/bknr/web/src/web/host.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/host.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/host.lisp	Thu Feb  7 03:30:34 2008
@@ -46,11 +46,11 @@
     (host-ip-address host)))
 
 (defmethod host-ipaddr ((host host))
-  (kmrcl::dotted-to-ipaddr (host-ip-address host)))
+  (usocket:host-byte-order (host-ip-address host)))
 
 (defun find-host (&key ip-address create ipaddr)
   (when ipaddr
-    (setf ip-address (kmrcl::ipaddr-to-dotted ipaddr)))
+    (setf ip-address (usocket:hbo-to-dotted-quad ipaddr)))
   (or (host-with-ipaddress ip-address)
       (and create
 	   (make-object 'host :ip-address ip-address))))

Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Thu Feb  7 03:30:34 2008
@@ -92,7 +92,7 @@
                            ,(intern (symbol-name var) :keyword)))))
     , at body))
 
-(defun expand-variables (string)
+(defun expand-variables (string lookup-variable)
   (if (find #\$ string)
       (regex-replace-all
        #?r"\$\(([\*_-\w]+)\)" string
@@ -101,7 +101,7 @@
 	   (let* ((var (make-keyword-from-string
 			(subseq target-string (aref reg-starts 0)
 				(aref reg-ends 0))))
-		  (val (get-template-var var)))
+		  (val (funcall lookup-variable var)))
 	     (cond
 	       ((stringp val) val)
 	       ((null val) "")
@@ -136,7 +136,7 @@
 
 (defun emit-template-node (expander node)
   (if (stringp node)
-      (sax:characters *html-sink* (expand-variables node))
+      (sax:characters *html-sink* (expand-variables node #'get-template-var))
       (let* ((name (node-name node))
              (ns (node-ns node))
              (children (node-children node))
@@ -148,10 +148,10 @@
 	     (apply (find-tag-function expander name ns)
 		    (append (loop for (key name) in attrs
 				  collect (make-keyword-from-string key)
-				  collect (expand-variables name))))))
+				  collect (expand-variables name #'get-template-var))))))
           (t
            (sax:start-element *html-sink* nil nil name
-                              (xmls-attributes-to-sax #'expand-variables attrs))
+                              (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs))
            (dolist (child children)
              (emit-template-node expander child))
            (sax:end-element *html-sink* nil nil name))))))


From hhubner at common-lisp.net  Thu Feb  7 08:33:05 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu,  7 Feb 2008 03:33:05 -0500 (EST)
Subject: [bknr-cvs] r2452 - in branches/trunk-reorg/thirdparty/slime: . CVS
	contrib contrib/CVS doc/CVS
Message-ID: <20080207083305.02DD4554B9@common-lisp.net>

Author: hhubner
Date: Thu Feb  7 03:32:58 2008
New Revision: 2452

Removed:
   branches/trunk-reorg/thirdparty/slime/CVS/Entries.Log
Modified:
   branches/trunk-reorg/thirdparty/slime/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/ChangeLog
   branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
   branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp
   branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
   branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp
   branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/slime-autoloads.el
   branches/trunk-reorg/thirdparty/slime/slime.el
   branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
   branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
   branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
   branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
   branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
   branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
   branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
   branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
delete unwanted file

Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/CVS/Entries	Thu Feb  7 03:32:58 2008
@@ -1,35 +1,35 @@
 D/contrib////
 D/doc////
-/.cvsignore/1.5/Sun Apr  8 19:23:57 2007//
-/ChangeLog/1.1274/Sun Jan 27 22:03:20 2008//
-/HACKING/1.8/Sun Jan 27 22:03:20 2008//
-/NEWS/1.9/Sun Jan 27 22:03:20 2008//
-/PROBLEMS/1.8/Sun Jan 27 22:03:20 2008//
-/README/1.14/Sun Jan 27 22:03:20 2008//
-/hyperspec.el/1.11/Sun Jan 27 22:03:20 2008//
-/metering.lisp/1.4/Sun Jan 27 22:03:20 2008//
-/mkdist.sh/1.7/Sun Jan 27 22:03:20 2008//
-/nregex.lisp/1.4/Sun Jan 27 22:03:20 2008//
-/sbcl-pprint-patch.lisp/1.1/Sun Jan 27 22:03:20 2008//
-/slime-autoloads.el/1.3/Sun Jan 27 22:03:20 2008//
-/slime.el/1.896/Sun Jan 27 22:03:20 2008//
-/swank-abcl.lisp/1.44/Sun Jan 27 22:03:20 2008//
-/swank-allegro.lisp/1.98/Sun Jan 27 22:03:20 2008//
-/swank-backend.lisp/1.126/Sun Jan 27 22:03:21 2008//
-/swank-clisp.lisp/1.64/Sun Jan 27 22:03:21 2008//
-/swank-cmucl.lisp/1.175/Sun Jan 27 22:03:21 2008//
-/swank-corman.lisp/1.11/Sun Jan 27 22:03:21 2008//
-/swank-ecl.lisp/1.11/Sun Jan 27 22:03:21 2008//
-/swank-gray.lisp/1.10/Sun Jan 27 22:03:21 2008//
-/swank-lispworks.lisp/1.93/Sun Jan 27 22:03:21 2008//
-/swank-loader.lisp/1.75/Sun Jan 27 22:03:21 2008//
-/swank-openmcl.lisp/1.120/Sun Jan 27 22:03:21 2008//
-/swank-sbcl.lisp/1.187/Sun Jan 27 22:03:21 2008//
-/swank-scl.lisp/1.14/Sun Jan 27 22:03:21 2008//
-/swank-source-file-cache.lisp/1.8/Sun Jan 27 22:03:21 2008//
-/swank-source-path-parser.lisp/1.18/Sun Jan 27 22:03:21 2008//
-/swank.asd/1.5/Sun Jan 27 22:03:21 2008//
-/swank.lisp/1.523/Sun Jan 27 22:03:21 2008//
-/test-all.sh/1.2/Sun Jan 27 22:03:21 2008//
-/test.sh/1.9/Sun Jan 27 22:03:21 2008//
-/xref.lisp/1.2/Sun Jan 27 22:03:21 2008//
+/.cvsignore/1.5/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.1282/Thu Feb  7 08:07:30 2008//
+/HACKING/1.8/Thu Oct 11 14:10:25 2007//
+/NEWS/1.9/Sun Dec  2 04:22:09 2007//
+/PROBLEMS/1.8/Thu Oct 11 14:10:25 2007//
+/README/1.14/Thu Oct 11 14:10:25 2007//
+/hyperspec.el/1.11/Thu Oct 11 14:10:25 2007//
+/metering.lisp/1.4/Thu Oct 11 14:10:25 2007//
+/mkdist.sh/1.7/Thu Oct 11 14:10:25 2007//
+/nregex.lisp/1.4/Thu Oct 11 14:10:25 2007//
+/sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007//
+/slime-autoloads.el/1.4/Thu Feb  7 08:07:30 2008//
+/slime.el/1.901/Thu Feb  7 08:07:31 2008//
+/swank-abcl.lisp/1.45/Thu Feb  7 08:07:31 2008//
+/swank-allegro.lisp/1.99/Thu Feb  7 08:07:31 2008//
+/swank-backend.lisp/1.127/Thu Feb  7 08:07:31 2008//
+/swank-clisp.lisp/1.65/Thu Feb  7 08:07:31 2008//
+/swank-cmucl.lisp/1.176/Thu Feb  7 08:07:31 2008//
+/swank-corman.lisp/1.13/Thu Feb  7 08:07:31 2008//
+/swank-ecl.lisp/1.12/Thu Feb  7 08:07:31 2008//
+/swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007//
+/swank-lispworks.lisp/1.94/Thu Feb  7 08:07:31 2008//
+/swank-loader.lisp/1.77/Thu Feb  7 08:07:31 2008//
+/swank-openmcl.lisp/1.122/Thu Feb  7 08:07:31 2008//
+/swank-sbcl.lisp/1.189/Thu Feb  7 08:07:31 2008//
+/swank-scl.lisp/1.15/Thu Feb  7 08:07:31 2008//
+/swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007//
+/swank-source-path-parser.lisp/1.18/Thu Feb  7 07:59:36 2008//
+/swank.asd/1.5/Thu Oct 11 14:10:25 2007//
+/swank.lisp/1.527/Thu Feb  7 08:07:31 2008//
+/test-all.sh/1.2/Thu Oct 11 14:10:25 2007//
+/test.sh/1.9/Thu Oct 11 14:10:25 2007//
+/xref.lisp/1.2/Thu Oct 11 14:10:25 2007//

Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/ChangeLog	(original)
+++ branches/trunk-reorg/thirdparty/slime/ChangeLog	Thu Feb  7 03:32:58 2008
@@ -1,7 +1,73 @@
+2008-02-05  Marco Baringer  <mb at bese.it>
+
+	* slime.el (slime-search-buffer-package): Ask the lisp to read the
+	in-package form so that we properly deal with #+foo and |WHATEVER|
+	package names.
+	(slime-repl-set-package): Only prompt with a default package if
+	the repl's package is different from the current package.
+
+2008-02-04  Marco Baringer  <mb at bese.it>
+
+	* swank-openmcl.lisp (ccl::advise ccl::break): advise the
+	lower-level ccl::cbreak-loop instead of cl:break.
+	(frame-locals): If the value is a value-cell (a closed over value)
+	show the closed over value and not the value cell.
+	(disassemble-frame): add in x86-64 code.
+
+	* slime-autoloads.el (slime-setup-contribs): Add contribs
+	directory to load-path.
+
+	* slime.el (slime-setup): Add contribs directory to load-path.
+
+	* swank-abcl.lisp, swank-allegro.lisp, swank-backend.lisp,
+	swank-clisp.lisp, swank-cmucl.lisp, swank-corman.lisp,
+	swank-ecl.lisp, swank-lispworks.lisp, swank-openmcl.lisp,
+	swank-sbcl.lisp, swank-scl.lisp, swank.lisp,
+	contrib/swank-fancy-inspector.lisp: Remove second argument from
+	swank:inspect-for-emacs. This functionality, choosing an inspector
+	at runtime, was never actually used and is, now, needless
+	complexity.
+
+2008-02-04  Helmut Eller  <heller at common-lisp.net>
+
+	Simpler code to bind 0-9 in the debugger.
+
+	* slime.el (sldb-mode-map): When binding the keys 0-9, use eval
+	instead of two macros.
+
+2008-02-04  Helmut Eller  <heller at common-lisp.net>
+
+	Move some functions to swank-arglist.lisp.
+
+	* swank.lisp (length=, ensure-list, recursively-empty-p)
+	(maybecall, exactly-one-p, read-softly-from-string)
+	(unintern-in-home-package, valid-function-name-p): Moved to
+	contrib/swank-arglist.lisp.
+
+2008-02-03  Marco Baringer  <mb at bese.it>
+
+	* swank.lisp (*sldb-condition-printer*): New variable.
+	(safe-condition-message): Use the current binding
+	of *sldb-condition-printer* to print the condition to a string.
+
+	* slime.el (sldb-invoke-restart-by-name): New function. Invokes a
+	restart by name, uses completion to read restart's name.
+	(slime-define-keys sldb-mode-map): Bind
+	sldb-invoke-restart-by-name to I in sldb buffers.
+
+	* swank-loader.lisp: When loading swank delete all swank packages
+	first. This protects the lisp from broken reloads of swank. Leave
+	the swank-loader package so that users can set *fasl-directory*
+	and *source-directory* as per the documentation.
+	(lisp-version-string): On openmcl use the full
+	cl:lisp-implementation-version, ccl::*openmcl-major-version* and
+	ccl::*openmcl-minor-version* aren't sufficently precise to notice
+	changes in openmcl's cvs.
+
 2008-01-27  Helmut Eller  <heller at common-lisp.net>
 
 	Make it easier to start a non-default Lisp from ELisp code.
-	
+
 	* slime.el (slime): If the argument is a symbol start the
 	corresponding entry in slime-lisp-implementations.
 	Typical use is something like:
@@ -15,7 +81,7 @@
 	(suppress-sharp-dot): unused, delete it.
 
 	* slime.el (test compile-defun): test with #+#.'(:and).
-	
+
 2008-01-21  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (sldb-mode): Don't throw to toplevel in the

Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	Thu Feb  7 03:32:58 2008
@@ -1,33 +1,37 @@
-/ChangeLog/1.82/Sun Jan 27 22:03:21 2008//
-/README/1.3/Sun Jan 27 22:03:21 2008//
-/bridge.el/1.1/Sun Jan 27 22:03:22 2008//
-/inferior-slime.el/1.2/Sun Jan 27 22:03:22 2008//
-/slime-asdf.el/1.3/Sun Jan 27 22:03:22 2008//
-/slime-autodoc.el/1.7/Sun Jan 27 22:03:22 2008//
-/slime-banner.el/1.4/Sun Jan 27 22:03:22 2008//
-/slime-c-p-c.el/1.8/Sun Jan 27 22:03:22 2008//
-/slime-editing-commands.el/1.6/Sun Jan 27 22:03:22 2008//
-/slime-fancy-inspector.el/1.2/Sun Jan 27 22:03:22 2008//
-/slime-fancy.el/1.4/Sun Jan 27 22:03:22 2008//
-/slime-fuzzy.el/1.6/Sun Jan 27 22:03:22 2008//
-/slime-highlight-edits.el/1.3/Sun Jan 27 22:03:22 2008//
-/slime-parse.el/1.10/Sun Jan 27 22:03:22 2008//
-/slime-presentation-streams.el/1.2/Sun Jan 27 22:03:22 2008//
-/slime-presentations.el/1.12/Sun Jan 27 22:03:22 2008//
-/slime-references.el/1.4/Sun Jan 27 22:03:22 2008//
-/slime-scheme.el/1.1/Wed Jan  9 18:30:26 2008//
-/slime-scratch.el/1.4/Sun Jan 27 22:03:22 2008//
-/slime-tramp.el/1.2/Sun Jan 27 22:03:22 2008//
-/slime-typeout-frame.el/1.6/Sun Jan 27 22:03:22 2008//
-/slime-xref-browser.el/1.1/Sun Jan 27 22:03:22 2008//
-/swank-arglists.lisp/1.18/Sun Jan 27 22:03:22 2008//
-/swank-asdf.lisp/1.1/Sun Jan 27 22:03:22 2008//
-/swank-c-p-c.lisp/1.2/Sun Jan 27 22:03:22 2008//
-/swank-fancy-inspector.lisp/1.5/Sun Jan 27 22:03:22 2008//
-/swank-fuzzy.lisp/1.7/Sun Jan 27 22:03:22 2008//
-/swank-goo.goo/1.1/Sat Jan 19 14:08:27 2008//
-/swank-kawa.scm/1.1/Sat Jan 19 14:08:27 2008//
-/swank-listener-hooks.lisp/1.1/Sun Jan 27 22:03:22 2008//
-/swank-presentation-streams.lisp/1.4/Sun Jan 27 22:03:22 2008//
-/swank-presentations.lisp/1.4/Sun Jan 27 22:03:22 2008//
+/ChangeLog/1.87/Thu Feb  7 08:07:31 2008//
+/README/1.3/Thu Oct 11 14:10:25 2007//
+/bridge.el/1.1/Thu Oct 11 14:10:25 2007//
+/inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007//
+/slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007//
+/slime-autodoc.el/1.7/Thu Feb  7 07:59:35 2008//
+/slime-banner.el/1.4/Thu Oct 11 14:10:25 2007//
+/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007//
+/slime-editing-commands.el/1.6/Thu Feb  7 07:59:35 2008//
+/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007//
+/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007//
+/slime-fuzzy.el/1.6/Thu Feb  7 07:59:35 2008//
+/slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007//
+/slime-indentation.el/1.1/Sun Feb  3 18:45:14 2008//
+/slime-motd.el/1.1/Sun Feb  3 18:39:23 2008//
+/slime-parse.el/1.10/Thu Feb  7 07:59:35 2008//
+/slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007//
+/slime-presentations.el/1.12/Thu Feb  7 07:59:35 2008//
+/slime-references.el/1.4/Thu Oct 11 14:10:25 2007//
+/slime-scheme.el/1.1/Thu Feb  7 08:07:31 2008//
+/slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007//
+/slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007//
+/slime-typeout-frame.el/1.6/Thu Feb  7 07:59:35 2008//
+/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007//
+/swank-arglists.lisp/1.20/Thu Feb  7 08:07:31 2008//
+/swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007//
+/swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007//
+/swank-fancy-inspector.lisp/1.7/Thu Feb  7 08:07:32 2008//
+/swank-fuzzy.lisp/1.7/Thu Feb  7 07:59:35 2008//
+/swank-goo.goo/1.1/Thu Feb  7 08:07:32 2008//
+/swank-indentation.lisp/1.1/Sun Feb  3 18:45:14 2008//
+/swank-kawa.scm/1.1/Thu Feb  7 08:07:32 2008//
+/swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007//
+/swank-motd.lisp/1.1/Sun Feb  3 18:39:23 2008//
+/swank-presentation-streams.lisp/1.5/Thu Feb  7 08:07:32 2008//
+/swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007//
 D

Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	Thu Feb  7 03:32:58 2008
@@ -1,7 +1,37 @@
+2008-02-04  Marco Baringer  <mb at bese.it>
+
+	* swank-presentation-streams.lisp (presenting-object-1): Add
+	declare special *record-repl-results* to silence compiler
+	warnings.
+
+	* swank-arglists.lisp (arglist-dispatch): Specialize operator-type
+	so openmcl doesn't warn about unused arguments.
+	(arglist-dispatch): add declare ignore form.
+
+2008-02-04  Helmut Eller  <heller at common-lisp.net>
+
+	Move some functions to swank-arglist.lisp.
+
+	* swank-arglist.lisp (length=, ensure-list, recursively-empty-p)
+	(maybecall, exactly-one-p, read-softly-from-string)
+	(unintern-in-home-package, valid-function-name-p): Moved from
+	swank.lisp. to contrib/swank-arglist.lisp.
+
+2008-02-03  Marco Baringer  <mb at bese.it>
+
+	* swank-motd.lisp, slime-motd.el: Message Of The Day printing for
+	slime.
+
+	* slime-indentation.el: Integrate cl-indent.el into slime's
+	contrib infrastructure. Fix bug in &rest.
+
+	* swank-indentation.lisp: Allow an application runnig under slime
+	to update emacs' indentation notes.
+
 2008-01-27  Helmut Eller  <heller at common-lisp.net>
 
 	Make autodoc use the correct width of the typeout-window.
-	
+
 	* slime-autodoc.el (slime-autodoc-dimensions-function): New
 	variable.
 	(slime-autodoc-message-dimensions): Use it.
@@ -13,7 +43,7 @@
 2008-01-27  Helmut Eller  <heller at common-lisp.net>
 
 	Use slime-require instead of a connected-hook.
-	
+
 	* slime-autodoc.el (slime-autodoc-on-connect): Deleted.
 
 2008-01-20  Matthias Koeppe  <mkoeppe at mail.math.uni-magdeburg.de>

Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-arglists.lisp	Thu Feb  7 03:32:58 2008
@@ -12,6 +12,40 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (swank-require :swank-c-p-c))
 
+(defun length= (seq n)
+  "Test for whether SEQ contains N number of elements. I.e. it's equivalent
+ to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
+ efficiently implemented."
+  (etypecase seq 
+    (list (do ((i n (1- i))
+               (list seq (cdr list)))
+              ((or (<= i 0) (null list))
+               (and (zerop i) (null list)))))
+    (sequence (= (length seq) n))))
+
+(defun ensure-list (thing)
+  (if (listp thing) thing (list thing)))
+
+(defun recursively-empty-p (list)
+  "Returns whether LIST consists only of arbitrarily nested empty lists."
+  (cond ((not (listp list)) nil)
+	((null list) t)
+	(t (every #'recursively-empty-p list))))
+
+(defun maybecall (bool fn &rest args)
+  "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
+  (if bool (apply fn args) (values-list args)))
+
+(defun exactly-one-p (&rest values)
+  "If exactly one value in VALUES is non-NIL, this value is returned.
+Otherwise NIL is returned."
+  (let ((found nil))
+    (dolist (v values)
+      (when v (if found
+                  (return-from exactly-one-p nil)
+                  (setq found v))))
+    found))
+
 (defun valid-operator-symbol-p (symbol)
   "Is SYMBOL the name of a function, a macro, or a special-operator?"
   (or (fboundp symbol)
@@ -24,6 +58,14 @@
   (let ((symbol (parse-symbol string)))
     (valid-operator-symbol-p symbol)))
 
+(defun valid-function-name-p (form)
+  (or (symbolp form)
+      (and (consp form)
+           (second form)
+           (not (third form))
+           (eq (first form) 'setf)
+           (symbolp (second form)))))
+
 (defslimefun arglist-for-echo-area (raw-specs &key arg-indices
                                                    print-right-margin print-lines)
   "Return the arglist for the first valid ``form spec'' in
@@ -243,6 +285,29 @@
     (assert (= pos (length string)))
     (values sexp interned?)))
 
+(defun read-softly-from-string (string)
+  "Returns three values:
+
+     1. the object resulting from READing STRING.
+
+     2. The index of the first character in STRING that was not read.
+
+     3. T if the object is a symbol that had to be newly interned
+        in some package. (This does not work for symbols in
+        compound forms like lists or vectors.)"
+  (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
+    (if found?
+        (values symbol (length string) nil)
+        (multiple-value-bind (sexp pos) (read-from-string string)
+          (values sexp pos
+                  (when (symbolp sexp)
+                    (prog1 t
+                      ;; assert that PARSE-SYMBOL didn't parse incorrectly.
+                      (assert (and (equal symbol-name (symbol-name sexp))
+                                   (eq package (symbol-package sexp)))))))))))
+
+(defun unintern-in-home-package (symbol)
+  (unintern symbol (symbol-package symbol)))
 
 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
   provided-args         ; list of the provided actual arguments
@@ -1022,7 +1087,7 @@
 
 (defgeneric arglist-dispatch (operator-type operator arguments &key remove-args))
   
-(defmethod arglist-dispatch (operator-type operator arguments &key (remove-args t))
+(defmethod arglist-dispatch ((operator-type t) operator arguments &key (remove-args t))
   (when (and (symbolp operator)
              (valid-operator-symbol-p operator))
     (multiple-value-bind (decoded-arglist determining-args any-enrichment)
@@ -1075,7 +1140,7 @@
 (defmethod arglist-dispatch ((operator-type (eql :function)) (operator (eql 'declare))
                              arguments &key (remove-args t))
   ;; Catching 'DECLARE before SWANK-BACKEND:ARGLIST can barf.
-  (declare (ignore remove-args))
+  (declare (ignore remove-args arguments))
   (make-arglist :rest '#:decl-specifiers))
 
 (defmethod arglist-dispatch ((operator-type (eql :declaration))

Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp	Thu Feb  7 03:32:58 2008
@@ -6,12 +6,7 @@
 
 (in-package :swank)
 
-;; Subclass `backend-inspector' so that backend specific methods are
-;; also considered.
-(defclass fancy-inspector (backend-inspector) ())
-
-(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((symbol symbol))
   (let ((package (symbol-package symbol)))
     (multiple-value-bind (_symbol status) 
 	(and package (find-symbol (string symbol) package))
@@ -94,8 +89,7 @@
 	  (t 
 	   (list label ": " '(:newline) "  " docstring '(:newline))))))
 
-(defmethod inspect-for-emacs ((f function) inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((f function))
   (values "A function."
 	  (append 
 	   (label-value-line "Name" (function-name f))
@@ -128,12 +122,11 @@
 	  (swank-mop:method-qualifiers method)
 	  (method-specializers-for-inspect method)))
 
-(defmethod inspect-for-emacs ((object standard-object) 
-			      (inspector fancy-inspector))
+(defmethod inspect-for-emacs ((object standard-object))
   (let ((class (class-of object)))
     (values "An object."
             `("Class: " (:value ,class) (:newline)
-              ,@(all-slots-for-inspector object inspector)))))
+              ,@(all-slots-for-inspector object)))))
 
 (defvar *gf-method-getter* 'methods-by-applicability
   "This function is called to get the methods of a generic function.
@@ -193,8 +186,8 @@
                    `(" " (:action "[make unbound]"
                           ,(lambda () (swank-mop:slot-makunbound-using-class class object slot)))))))))
 
-(defgeneric all-slots-for-inspector (object inspector)
-  (:method ((object standard-object) inspector)
+(defgeneric all-slots-for-inspector (object)
+  (:method ((object standard-object))
     (declare (ignore inspector))
     (append '("--------------------" (:newline)
               "All Slots:" (:newline))
@@ -231,8 +224,7 @@
                   append slot-presentation
                   collect '(:newline))))))
 
-(defmethod inspect-for-emacs ((gf standard-generic-function) 
-                              (inspector fancy-inspector)) 
+(defmethod inspect-for-emacs ((gf standard-generic-function)) 
   (flet ((lv (label value) (label-value-line label value)))
     (values 
      "A generic function."
@@ -255,10 +247,9 @@
                             (remove-method gf m))))
 	      (:newline)))
       `((:newline))
-      (all-slots-for-inspector gf inspector)))))
+      (all-slots-for-inspector gf)))))
 
-(defmethod inspect-for-emacs ((method standard-method) 
-                              (inspector fancy-inspector))
+(defmethod inspect-for-emacs ((method standard-method))
   (values "A method." 
           `("Method defined on the generic function " 
 	    (:value ,(swank-mop:method-generic-function method)
@@ -276,10 +267,9 @@
             (:newline)
             "Method function: " (:value ,(swank-mop:method-function method))
             (:newline)
-            ,@(all-slots-for-inspector method inspector))))
+            ,@(all-slots-for-inspector method))))
 
-(defmethod inspect-for-emacs ((class standard-class) 
-                              (inspector fancy-inspector))
+(defmethod inspect-for-emacs ((class standard-class))
   (values "A class."
           `("Name: " (:value ,(class-name class))
             (:newline)
@@ -336,10 +326,9 @@
                                `(:value ,(swank-mop:class-prototype class))
                                '"#<N/A (class not finalized)>")
             (:newline)
-            ,@(all-slots-for-inspector class inspector))))
+            ,@(all-slots-for-inspector class))))
 
-(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) 
-                              (inspector fancy-inspector))
+(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition))
   (values "A slot."
           `("Name: " (:value ,(swank-mop:slot-definition-name slot))
             (:newline)
@@ -353,7 +342,7 @@
                              "#<unspecified>") (:newline)
             "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))            
             (:newline)
-            ,@(all-slots-for-inspector slot inspector))))
+            ,@(all-slots-for-inspector slot))))
 
 
 ;; Wrapper structure over the list of symbols of a package that should
@@ -445,9 +434,7 @@
                         (:newline)
                         )))))
 
-(defmethod inspect-for-emacs ((%container %package-symbols-container) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((%container %package-symbols-container))
   (with-struct (%container. title description symbols grouping-kind) %container
     (values title
             `(, at description
@@ -464,10 +451,7 @@
               (:newline) (:newline)
               ,@(make-symbols-listing grouping-kind symbols)))))
 
-
-(defmethod inspect-for-emacs ((package package) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((package package))
   (let ((package-name         (package-name package))
         (package-nicknames    (package-nicknames package))
         (package-use-list     (package-use-list package))
@@ -561,9 +545,7 @@
                            :description nil)))))))
 
 
-(defmethod inspect-for-emacs ((pathname pathname) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((pathname pathname))
   (values (if (wild-pathname-p pathname)
               "A wild pathname."
               "A pathname.")
@@ -579,9 +561,7 @@
                               (not (probe-file pathname)))
                     (label-value-line "Truename" (truename pathname))))))
 
-(defmethod inspect-for-emacs ((pathname logical-pathname) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((pathname logical-pathname))
   (values "A logical pathname."
           (append 
            (label-value-line*
@@ -601,9 +581,7 @@
             ("Truename" (if (not (wild-pathname-p pathname))
                             (probe-file pathname)))))))
 
-(defmethod inspect-for-emacs ((n number) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((n number))
   (values "A number." `("Value: " ,(princ-to-string n))))
 
 (defun format-iso8601-time (time-value &optional include-timezone-p)
@@ -626,9 +604,7 @@
               year month day hour minute second
               include-timezone-p (format-iso8601-timezone zone)))))
 
-(defmethod inspect-for-emacs ((i integer) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((i integer))
   (values "A number."
           (append
            `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
@@ -640,26 +616,20 @@
            (ignore-errors
              (label-value-line "Universal-time" (format-iso8601-time i t))))))
 
-(defmethod inspect-for-emacs ((c complex) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((c complex))
   (values "A complex number."
           (label-value-line* 
            ("Real part" (realpart c))
            ("Imaginary part" (imagpart c)))))
 
-(defmethod inspect-for-emacs ((r ratio) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((r ratio))
   (values "A non-integer ratio."
           (label-value-line*
            ("Numerator" (numerator r))
            ("Denominator" (denominator r))
            ("As float" (float r)))))
 
-(defmethod inspect-for-emacs ((f float) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((f float))
   (values "A floating point number."
           (cond
             ((> f most-positive-long-float)
@@ -679,9 +649,7 @@
                 (label-value-line "Digits" (float-digits f))
                 (label-value-line "Precision" (float-precision f))))))))
 
-(defmethod inspect-for-emacs ((stream file-stream) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((stream file-stream))
   (multiple-value-bind (title content)
       (call-next-method)
     (declare (ignore title))
@@ -699,9 +667,7 @@
                (:newline))
              content))))
 
-(defmethod inspect-for-emacs ((condition stream-error) 
-                              (inspector fancy-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((condition stream-error))
   (multiple-value-bind (title content)
       (call-next-method)
     (let ((stream (stream-error-stream condition)))
@@ -724,14 +690,10 @@
 (defvar *fancy-inpector-undo-list* nil)
 
 (defslimefun fancy-inspector-init ()
-  (let ((i *default-inspector*))
-    (push (lambda () (setq *default-inspector* i))
-	  *fancy-inpector-undo-list*))
-  (setq *default-inspector* (make-instance 'fancy-inspector))
   t)
 
 (defslimefun fancy-inspector-unload ()
   (loop while *fancy-inpector-undo-list* do
 	(funcall (pop *fancy-inpector-undo-list*))))
 
-(provide :swank-fancy-inspector)
\ No newline at end of file
+(provide :swank-fancy-inspector)

Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-presentation-streams.lisp	Thu Feb  7 03:32:58 2008
@@ -210,6 +210,9 @@
 (defun presenting-object-1 (object stream continue)
   "Uses the bridge mechanism with two messages >id and <id. The first one
 says that I am starting to print an object with this id. The second says I am finished"
+  ;; this declare special is to let the compiler know that *record-repl-results* will eventually be
+  ;; a global special, even if it isn't when this file is compiled/loaded.
+  (declare (special *record-repl-results*))
   (let ((slime-stream-p 
 	 (and *record-repl-results* (slime-stream-p stream))))
     (if slime-stream-p

Modified: branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/doc/CVS/Entries	Thu Feb  7 03:32:58 2008
@@ -1,9 +1,9 @@
-/.cvsignore/1.1/Mon Jul 24 14:13:23 2006//
-/Makefile/1.12/Sun Jan 27 22:03:22 2008//
-/slime-refcard.pdf/1.1/Sun Jan 27 22:03:22 2008//
-/slime-refcard.tex/1.1/Sun Jan 27 22:03:22 2008//
-/slime-small.eps/1.1/Sun Jan 27 22:03:22 2008//
-/slime-small.pdf/1.1/Sun Jan 27 22:03:22 2008//
-/slime.texi/1.64/Sun Jan 27 22:03:22 2008//
-/texinfo-tabulate.awk/1.2/Sun Jan 27 22:03:22 2008//
+/.cvsignore/1.1/Thu Oct 11 14:10:24 2007//
+/Makefile/1.12/Thu Oct 11 14:10:24 2007//
+/slime-refcard.pdf/1.1/Thu Oct 11 14:10:24 2007//
+/slime-refcard.tex/1.1/Thu Oct 11 14:10:24 2007//
+/slime-small.eps/1.1/Thu Oct 11 14:10:24 2007//
+/slime-small.pdf/1.1/Thu Oct 11 14:10:24 2007//
+/slime.texi/1.64/Thu Feb  7 07:59:33 2008//
+/texinfo-tabulate.awk/1.2/Thu Oct 11 14:10:24 2007//
 D

Modified: branches/trunk-reorg/thirdparty/slime/slime-autoloads.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime-autoloads.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/slime-autoloads.el	Thu Feb  7 03:32:58 2008
@@ -39,11 +39,16 @@
 (defvar slime-setup-contribs nil)
 
 (defun slime-setup-contribs () 
-  (dolist (c slime-setup-contribs)
-    (require c)
-    (let ((init (intern (format "%s-init" c))))
-      (when (fboundp init)
-        (funcall init)))))
+  (when slime-setup-contribs
+    (pushnew (file-name-as-directory
+              (expand-file-name (concat slime-path "contribs")))
+             load-path
+             :test 'string=)    
+    (dolist (c slime-setup-contribs)
+      (require c)
+      (let ((init (intern (format "%s-init" c))))
+        (when (fboundp init)
+          (funcall init))))))
 
 (provide 'slime-autoloads)
 

Modified: branches/trunk-reorg/thirdparty/slime/slime.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/slime.el	Thu Feb  7 03:32:58 2008
@@ -71,11 +71,16 @@
 CONTRIBS is a list of contrib packages to load."
   (when (member 'lisp-mode slime-lisp-modes)
     (add-hook 'lisp-mode-hook 'slime-lisp-mode-hook))
-  (dolist (c contribs)
-    (require c)
-    (let ((init (intern (format "%s-init" c))))
-      (when (fboundp init)
-        (funcall init)))))
+  (when contribs
+    (pushnew (file-name-as-directory
+              (expand-file-name (concat slime-path "contribs")))
+             load-path
+             :test 'string=)
+    (dolist (c contribs)
+      (require c)
+      (let ((init (intern (format "%s-init" c))))
+        (when (fboundp init)
+          (funcall init))))))
 
 (defun slime-lisp-mode-hook ()
   (slime-mode 1)
@@ -2262,7 +2267,11 @@
     (save-excursion
       (when (or (re-search-backward regexp nil t)
                 (re-search-forward regexp nil t))
-        (match-string-no-properties 2)))))
+        ;; package name can be a string designator, convert it to a string.
+        ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0))))
+        ;;            "COMMON-LISP-USER")
+        (match-string-no-properties 2)
+        ))))
 
 ;;; Synchronous requests are implemented in terms of asynchronous
 ;;; ones. We make an asynchronous request with a continuation function
@@ -3312,8 +3321,12 @@
 
 (defun slime-repl-set-package (package)
   "Set the package of the REPL buffer to PACKAGE."
-  (interactive (list (slime-read-package-name
-                      "Package: " (slime-pretty-find-buffer-package))))
+  (interactive (list (slime-read-package-name "Package: "
+                                              (if (string= (slime-current-package)
+                                                           (with-current-buffer (slime-repl-buffer)
+                                                             (slime-current-package)))
+                                                nil
+                                                (slime-pretty-find-buffer-package)))))
   (with-current-buffer (slime-output-buffer)
     (let ((unfinished-input (slime-repl-current-input)))
       (destructuring-bind (name prompt-string)
@@ -6551,6 +6564,7 @@
   (">"    'sldb-end-of-backtrace)
   ("t"    'sldb-toggle-details)
   ("r"    'sldb-restart-frame)
+  ("I"    'sldb-invoke-restart-by-name)
   ("R"    'sldb-return-from-frame)
   ("c"    'sldb-continue)
   ("s"    'sldb-step)
@@ -6573,23 +6587,14 @@
         (define-key sldb-mode-map key command)))))
 
 ;; Keys 0-9 are shortcuts to invoke particular restarts.
-(defmacro define-sldb-invoke-restart-key (number key)
+(dotimes (number 10)
   (let ((fname (intern (format "sldb-invoke-restart-%S" number)))
         (docstring (format "Invoke restart numbered %S." number)))
-    `(progn
-       (defun ,fname ()
-         ,docstring
-	 (interactive)
-	 (sldb-invoke-restart ,number))
-       (define-key sldb-mode-map ,key ',fname))))
-
-(defmacro define-sldb-invoke-restart-keys (from to)
-  `(progn
-     ,@(loop for n from from to to
-	     collect `(define-sldb-invoke-restart-key ,n
-			,(number-to-string n)))))
-
-(define-sldb-invoke-restart-keys 0 9)
+    (eval `(defun ,fname ()
+             ,docstring
+             (interactive)
+             (sldb-invoke-restart ,number)))
+    (define-key sldb-mode-map (number-to-string number) fname)))
 
 

 ;;;;; SLDB buffer creation & update
@@ -7223,6 +7228,14 @@
       ((:ok value) (message "Restart returned: %s" value))
       ((:abort)))))
 
+(defun sldb-invoke-restart-by-name (restart-name)
+  (interactive (list (completing-read "Restart: "
+                                      sldb-restarts nil t
+                                      ""
+                                      'sldb-invoke-restart-by-name)))
+  (sldb-invoke-restart (position restart-name sldb-restarts 
+                                 :test 'string= :key 'first)))
+
 (defun sldb-break-with-default-debugger ()
   "Enter default debugger."
   (interactive)

Modified: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp	Thu Feb  7 03:32:58 2008
@@ -421,14 +421,7 @@
 
 ;;;; Inspecting
 
-(defclass abcl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'abcl-inspector))
-
-(defmethod inspect-for-emacs ((slot mop::slot-definition) 
-                              (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((slot mop::slot-definition))
   (values "A slot." 
           `("Name: " (:value ,(mop::%slot-definition-name slot))
             (:newline)
@@ -443,8 +436,7 @@
             "  Function: " (:value ,(mop::%slot-definition-initfunction slot))
             (:newline))))
 
-(defmethod inspect-for-emacs ((f function) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((f function))
   (values "A function."
           `(,@(when (function-name f)
                     `("Name: " 
@@ -461,7 +453,7 @@
 
 #|
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((o t))
   (let* ((class (class-of o))
          (slots (mop::class-slots class)))
     (values (format nil "~A~%   is a ~A" o class)

Modified: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp	Thu Feb  7 03:32:58 2008
@@ -564,13 +564,7 @@
 
 ;;;; Inspecting
 
-(defclass acl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'acl-inspector))
-
-(defmethod inspect-for-emacs ((f function) inspector)
-  inspector
+(defmethod inspect-for-emacs ((f function))
   (values "A function."
           (append
            (label-value-line "Name" (function-name f))
@@ -579,17 +573,13 @@
              (when doc
                `("Documentation:" (:newline) ,doc))))))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o t))
   (values "A value." (allegro-inspect o)))
 
-(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o function))
   (values "A function." (allegro-inspect o)))
 
-(defmethod inspect-for-emacs ((o standard-object) 
-                              (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o standard-object))
   (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
 
 (defun allegro-inspect (o)

Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	Thu Feb  7 03:32:58 2008
@@ -840,26 +840,10 @@
 

 ;;;; Inspector
 
-(defclass inspector ()
-  ()
-  (:documentation "Super class of inspector objects.
-
-Implementations should sub class in order to dispatch off of the
-inspect-for-emacs method."))
-
-(defclass backend-inspector (inspector) ())
-
-(definterface make-default-inspector ()
-  "Return an inspector object suitable for passing to inspect-for-emacs.")
-
-(defgeneric inspect-for-emacs (object inspector)
+(defgeneric inspect-for-emacs (object)
   (:documentation
    "Explain to Emacs how to inspect OBJECT.
 
-The argument INSPECTOR is an object representing how to get at
-the internals of OBJECT, it is usually an implementation specific
-class used simply for dispatching to the proper method.
-
 Returns two values: a string which will be used as the title of
 the inspector buffer and a list specifying how to render the
 object for inspection.
@@ -880,12 +864,11 @@
 
  NIL - do nothing."))
 
-(defmethod inspect-for-emacs ((object t) (inspector t))
+(defmethod inspect-for-emacs ((object t))
   "Generic method for inspecting any kind of object.
 
 Since we don't know how to deal with OBJECT we simply dump the
 output of CL:DESCRIBE."
-  (declare (ignore inspector))
   (values 
    "A value."
    `("Type: " (:value ,(type-of object)) (:newline)

Modified: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp	Thu Feb  7 03:32:58 2008
@@ -627,12 +627,7 @@
 
 ;;;; Inspecting
 
-(defclass clisp-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector () (make-instance 'clisp-inspector))
-
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o t))
   (let* ((*print-array* nil) (*print-pretty* t)
          (*print-circle* t) (*print-escape* t)
          (*print-lines* custom:*inspect-print-lines*)

Modified: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp	Thu Feb  7 03:32:58 2008
@@ -1869,7 +1869,7 @@
                                   :key #'symbol-value)))
           (format t ", type: ~A" type-symbol))))))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((o t))
   (cond ((di::indirect-value-cell-p o)
          (values (format nil "~A is a value cell." o)
                  `("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1887,8 +1887,7 @@
                 (loop for value in parts  for i from 0 
                       append (label-value-line i value))))))
 
-(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o function))
   (let ((header (kernel:get-type o)))
     (cond ((= header vm:function-header-type)
            (values (format nil "~A is a function." o)
@@ -1915,9 +1914,7 @@
           (t
            (call-next-method)))))
 
-(defmethod inspect-for-emacs ((o kernel:funcallable-instance)
-                              (i backend-inspector))
-  (declare (ignore i))
+(defmethod inspect-for-emacs ((o kernel:funcallable-instance))
   (values 
    (format nil "~A is a funcallable-instance." o)
    (append (label-value-line* 
@@ -1926,8 +1923,7 @@
             (:layout  (kernel:%funcallable-instance-layout o)))
            (nth-value 1 (cmucl-inspect o)))))
 
-(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector))
-  (declare (ignore _))
+(defmethod inspect-for-emacs ((o kernel:code-component))
   (values (format nil "~A is a code data-block." o)
           (append 
            (label-value-line* 
@@ -1954,8 +1950,7 @@
                          (ash (kernel:%code-code-size o) vm:word-shift)
                          :stream s))))))))
 
-(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o kernel:fdefn))
   (values (format nil "~A is a fdenf object." o)
           (label-value-line*
            ("name" (kernel:fdefn-name o))
@@ -1964,8 +1959,7 @@
                         (sys:int-sap (kernel:get-lisp-obj-address o))
                         (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
 
-(defmethod inspect-for-emacs ((o array) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o array))
   (if (typep o 'simple-array)
       (call-next-method)
       (values (format nil "~A is an array." o)
@@ -1980,8 +1974,7 @@
                (:displaced-p (kernel:%array-displaced-p o))
                (:dimensions (array-dimensions o))))))
 
-(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o simple-vector))
   (values (format nil "~A is a simple-vector." o)
           (append 
            (label-value-line*

Modified: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp	Thu Feb  7 03:32:58 2008
@@ -387,21 +387,13 @@
 ;; Hack to make swank.lisp load, at least
 (defclass file-stream ())
 
-(defclass corman-inspector (backend-inspector)
-  ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'corman-inspector))
-
 (defun comma-separated (list &optional (callback (lambda (v)
                                                    `(:value ,v))))
   (butlast (loop for e in list
               collect (funcall callback e)
               collect ", ")))
 
-(defmethod inspect-for-emacs ((class standard-class)
-                              (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((class standard-class))
   (values "A class."
           `("Name: " (:value ,(class-name class))
             (:newline)
@@ -438,9 +430,8 @@
                   '("#<N/A (class not finalized)>"))
             (:newline))))
 
-(defmethod inspect-for-emacs ((slot cons) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((slot cons))
   ;; Inspects slot definitions
-  (declare (ignore inspector))
   (if (eq (car slot) :name)
       (values "A slot." 
               `("Name: " (:value ,(swank-mop:slot-definition-name slot))
@@ -457,9 +448,7 @@
                                              (:newline)))
       (call-next-method)))
   
-(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal)
-                              inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal))
   (values (if (wild-pathname-p pathname)
               "A wild pathname."
               "A pathname.")
@@ -475,7 +464,7 @@
                               (not (probe-file pathname)))
                     (label-value-line "Truename" (truename pathname))))))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((o t))
   (cond ((cl::structurep o) (inspect-structure o))
 	(t (call-next-method))))
 

Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp	Thu Feb  7 03:32:58 2008
@@ -248,13 +248,7 @@
 
 ;;;; Inspector
 
-(defclass ecl-inspector (inspector)
-  ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'ecl-inspector))
-
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((o t))
   ; ecl clos support leaves some to be desired
   (cond
     ((streamp o)

Modified: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp	Thu Feb  7 03:32:58 2008
@@ -629,20 +629,15 @@
 (defimplementation make-default-inspector ()
   (make-instance 'lispworks-inspector))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o t))
   (lispworks-inspect o))
 
-(defmethod inspect-for-emacs ((o function) 
-                              (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o function))
   (lispworks-inspect o))
 
 ;; FIXME: slot-boundp-using-class in LW works with names so we can't
 ;; use our method in swank.lisp.
-(defmethod inspect-for-emacs ((o standard-object) 
-                              (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o standard-object))
   (lispworks-inspect o))
 
 (defun lispworks-inspect (o)

Modified: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp	Thu Feb  7 03:32:58 2008
@@ -18,6 +18,12 @@
 ;;   (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
 ;;   (load ".../swank-loader.lisp")
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-package :swank)
+    (delete-package :swank)
+    (delete-package :swank-io-package)
+    (delete-package :swank-backend)))
+
 (cl:defpackage :swank-loader
   (:use :cl)
   (:export :load-swank
@@ -60,14 +66,9 @@
     :sparc64 :sparc :hppa64 :hppa))
 
 (defun lisp-version-string ()
-  #+cmu       (substitute-if #\_ (lambda (x) (find x " /"))
+  #+(or openmcl cmu)       (substitute-if #\_ (lambda (x) (find x " /"))
                              (lisp-implementation-version))
-  #+scl       (lisp-implementation-version)
-  #+sbcl      (lisp-implementation-version)
-  #+ecl       (lisp-implementation-version)
-  #+openmcl   (format nil "~d.~d"
-                      ccl::*openmcl-major-version*
-                      ccl::*openmcl-minor-version*)
+  #+(or cormanlisp scl sbcl ecl)       (lisp-implementation-version)
   #+lispworks (lisp-implementation-version)
   #+allegro   (format nil
                       "~A~A~A"
@@ -76,8 +77,7 @@
                       (if (member :64bit *features*) "-64bit" ""))
   #+clisp     (let ((s (lisp-implementation-version)))
                 (subseq s 0 (position #\space s)))
-  #+armedbear (lisp-implementation-version)
-  #+cormanlisp (lisp-implementation-version))
+  #+armedbear (lisp-implementation-version))
 
 (defun unique-directory-name ()
   "Return a name that can be used as a directory name that is

Modified: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp	Thu Feb  7 03:32:58 2008
@@ -211,14 +211,18 @@
 
 (defvar *break-in-sldb* t)
 
+
 (let ((ccl::*warn-if-redefine-kernel* nil))
-  (ccl::advise 
-   cl::break 
+  (ccl::advise
+   ccl::cbreak-loop
    (if (and *break-in-sldb* 
-            (find ccl::*current-process* (symbol-value (intern "*CONNECTIONS*" 'swank))
-                  :key (intern "CONNECTION.REPL-THREAD" 'swank)))
+            (find ccl::*current-process*
+                  (symbol-value (intern (string :*connections*) :swank))
+                  :key (intern (string :connection.repl-thread) :swank)))
        (apply 'break-in-sldb ccl::arglist)
-       (:do-it)) :when :around :name sldb-break))
+       (:do-it))
+   :when :around
+   :name sldb-break))
 
 (defun break-in-sldb (&optional string &rest args)
   (let ((c (make-condition 'simple-condition
@@ -335,8 +339,7 @@
                      for (value nil name) = (multiple-value-list (ccl::nth-value-in-frame p count context lfun pc vsp parent-vsp))
                      when name do (incf varcount)
                      until (= varcount var)
-                     finally (return value))
-               )))))))
+                     finally (return value)))))))))
 
 (defun xref-locations (relation name &optional (inverse nil))
   (flet ((function-source-location (entry)
@@ -345,8 +348,8 @@
                 (ccl::%db-key-from-xref-entry entry)
                 (if (eql (ccl::xref-entry-type entry)
                          'macro)
-                    'function
-                    (ccl::xref-entry-type entry)))
+                  'function
+                  (ccl::xref-entry-type entry)))
              (cond ((not info)
                     (list :error
                           (format nil "No source info available for ~A"
@@ -466,7 +469,8 @@
   (setq ccl::*fasl-save-definitions* nil)
   (setq ccl::*fasl-save-doc-strings* t)
   (setq ccl::*fasl-save-local-symbols* t)
-  (setq ccl::*ppc2-compiler-register-save-label* t) 
+  #+ppc (setq ccl::*ppc2-compiler-register-save-label* t)
+  #+x86-64 (setq ccl::*x862-compiler-register-save-label* t)
   (setq ccl::*save-arglist-info* t)
   (setq ccl::*save-definitions* nil)
   (setq ccl::*save-doc-strings* t)
@@ -513,9 +517,8 @@
 
 (defun frame-arguments (p context lfun pc)
   "Returns a string representing the arguments of a frame."
-  (multiple-value-bind (args types names count nclosed)
+  (multiple-value-bind (args types names)
       (ccl::frame-supplied-args p lfun pc nil context)
-    (declare (ignore count nclosed))
     (let ((result nil))
       (loop named loop
          for var = (cond
@@ -575,7 +578,9 @@
                    (push (list 
                           :name name
                           :id 0
-                          :value var)
+                          :value (if (typep var 'ccl::value-cell)
+                                     (ccl::uvref var 0)
+                                     var))
                          result))))
              (return-from frame-locals (nreverse result)))))))))
 
@@ -610,19 +615,24 @@
          (when (= frame-number the-frame-number)
            (setq function-to-disassemble lfun)
            (return-from find-frame)))))
-    (ccl::print-ppc-instructions 
-     *standard-output* 
-     (ccl::function-to-dll-header function-to-disassemble) nil)))
+    #+ppc (ccl::print-ppc-instructions 
+           *standard-output* 
+           (ccl::function-to-dll-header function-to-disassemble)
+           nil)
+    #+x86-64 (ccl::x8664-xdisassemble function-to-disassemble)))
 
 ;;;
 
-(defun canonicalize-location (file symbol)
+(defun canonicalize-location (file symbol &optional snippet)
   (etypecase file
     ((or string pathname)
      (multiple-value-bind (truename c) (ignore-errors (namestring (truename file)))
        (cond (c (list :error (princ-to-string c)))
              (t (make-location (list :file (remove-filename-quoting truename))
-                               (list :function-name (princ-to-string symbol)))))))))
+                               (list :function-name (princ-to-string symbol))
+                               (if snippet
+                                   (list :snippet snippet)
+                                   '()))))))))
 
 (defun remove-filename-quoting (string)
   (if (search "\\" string)
@@ -644,20 +654,20 @@
                       (list (list type symbol) 
                             (canonicalize-location file symbol))))))
 
-
 (defun function-source-location (function)
-  (multiple-value-bind (info name) (ccl::edit-definition-p function)
+  (multiple-value-bind (info name)
+      (ccl::edit-definition-p function)
     (cond ((not info) (list :error (format nil "No source info available for ~A" function)))
           ((typep (caar info) 'ccl::method)
            `(:location 
              (:file ,(remove-filename-quoting (namestring (translate-logical-pathname (cdr (car info))) )))
              (:method  ,(princ-to-string (ccl::method-name (caar info)))
-               ,(mapcar 'princ-to-string
-                        (mapcar #'specializer-name
-                                (ccl::method-specializers (caar info))))
-               ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
+                       ,(mapcar 'princ-to-string
+                                (mapcar #'specializer-name
+                                        (ccl::method-specializers (caar info))))
+                       ,@(mapcar 'princ-to-string (ccl::method-qualifiers (caar info))))
              nil))
-          (t (canonicalize-location (cdr (first info)) name)))))
+          (t (canonicalize-location (second (first info)) name (third (first info)))))))
 
 (defimplementation frame-source-location-for-emacs (index)
   "Return to Emacs the location of the source code for the
@@ -693,6 +703,7 @@
                         ,form)))
              )))))))
 
+#+ppc
 (defimplementation return-from-frame (index form)
   (let ((values (multiple-value-list (eval-in-frame form index))))
     (map-backtrace
@@ -700,7 +711,8 @@
        (declare (ignore context lfun pc))
        (when (= frame-number index)
          (ccl::apply-in-frame p #'values values))))))
- 
+
+#+ppc
 (defimplementation restart-frame (index)
   (map-backtrace
    (lambda (frame-number p context lfun pc)
@@ -784,19 +796,13 @@
 
 ;;;; Inspection
 
-(defclass openmcl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'openmcl-inspector))
-
 (defimplementation describe-primitive-type (thing)
   (let ((typecode (ccl::typecode thing)))
     (if (gethash typecode *value2tag*)
 	(string (gethash typecode *value2tag*))
 	(string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o t))
   (let* ((i (inspector::make-inspector o))
 	 (count (inspector::compute-line-count i))
 	 (lines 
@@ -814,7 +820,7 @@
                 (pprint o s)))
             lines)))
 
-(defmethod inspect-for-emacs :around ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs :around ((o t))
   (if (or (uvector-inspector-p o)
           (not (ccl:uvectorp o)))
       (call-next-method)
@@ -834,8 +840,7 @@
   (:method ((object t)) nil)
   (:method ((object uvector-inspector)) t))
 
-(defmethod inspect-for-emacs ((uv uvector-inspector) 
-                              (inspector backend-inspector))
+(defmethod inspect-for-emacs ((uv uvector-inspector))
   (with-slots (object)
       uv
     (values (format nil "The UVECTOR for ~S." object)
@@ -855,8 +860,7 @@
 		(cellp (ccl::closed-over-value-p value)))
 	   (list label (if cellp (ccl::closed-over-value value) value))))))
 
-(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure) (inspector t))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure))
   (values
    (format nil "A closure: ~a" c)
    `(,@(if (arglist c)

Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp	Thu Feb  7 03:32:58 2008
@@ -1001,13 +1001,7 @@
 

 ;;;; Inspector
 
-(defclass sbcl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'sbcl-inspector))
-
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o t))
   (cond ((sb-di::indirect-value-cell-p o)
          (values "A value cell." (label-value-line*
                                   (:value (sb-kernel:value-cell-ref o)))))
@@ -1019,8 +1013,7 @@
                (values text (loop for value in parts  for i from 0
                                   append (label-value-line i value))))))))
 
-(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o function))
   (let ((header (sb-kernel:widetag-of o)))
     (cond ((= header sb-vm:simple-fun-header-widetag)
 	   (values "A simple-fun."
@@ -1041,8 +1034,7 @@
                                   i (sb-kernel:%closure-index-ref o i))))))
 	  (t (call-next-method o)))))
 
-(defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ backend-inspector))
-  (declare (ignore _))
+(defmethod inspect-for-emacs ((o sb-kernel:code-component))
   (values (format nil "~A is a code data-block." o)
           (append
            (label-value-line*
@@ -1070,22 +1062,18 @@
                          (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
                          :stream s))))))))
 
-(defmethod inspect-for-emacs ((o sb-ext:weak-pointer) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
   (values "A weak pointer."
           (label-value-line*
            (:value (sb-ext:weak-pointer-value o)))))
 
-(defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o sb-kernel:fdefn))
   (values "A fdefn object."
           (label-value-line*
            (:name (sb-kernel:fdefn-name o))
            (:function (sb-kernel:fdefn-fun o)))))
 
-(defmethod inspect-for-emacs :around ((o generic-function)
-                                      (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs :around ((o generic-function))
   (multiple-value-bind (title contents) (call-next-method)
     (values title
             (append

Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp	Thu Feb  7 03:32:58 2008
@@ -1740,7 +1740,7 @@
                                   :key #'symbol-value)))
           (format t ", type: ~A" type-symbol))))))
 
-(defmethod inspect-for-emacs ((o t) (inspector backend-inspector))
+(defmethod inspect-for-emacs ((o t))
   (cond ((di::indirect-value-cell-p o)
          (values (format nil "~A is a value cell." o)
                  `("Value: " (:value ,(c:value-cell-ref o)))))
@@ -1759,8 +1759,7 @@
                 (loop for value in parts  for i from 0 
                       append (label-value-line i value))))))
 
-(defmethod inspect-for-emacs ((o function) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o function))
   (let ((header (kernel:get-type o)))
     (cond ((= header vm:function-header-type)
            (values (format nil "~A is a function." o)
@@ -1789,8 +1788,7 @@
            (call-next-method)))))
 
 
-(defmethod inspect-for-emacs ((o kernel:code-component) (_ backend-inspector))
-  (declare (ignore _))
+(defmethod inspect-for-emacs ((o kernel:code-component))
   (values (format nil "~A is a code data-block." o)
           (append 
            (label-value-line* 
@@ -1817,8 +1815,7 @@
                          (ash (kernel:%code-code-size o) vm:word-shift)
                          :stream s))))))))
 
-(defmethod inspect-for-emacs ((o kernel:fdefn) (inspector backend-inspector))
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((o kernel:fdefn))
   (values (format nil "~A is a fdenf object." o)
           (label-value-line*
            ("name" (kernel:fdefn-name o))
@@ -1827,8 +1824,7 @@
                         (sys:int-sap (kernel:get-lisp-obj-address o))
                         (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
 
-(defmethod inspect-for-emacs ((o array) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o array))
   (cond ((kernel:array-header-p o)
          (values (format nil "~A is an array." o)
                  (label-value-line*
@@ -1847,8 +1843,7 @@
                   (:header (describe-primitive-type o))
                   (:length (length o)))))))
 
-(defmethod inspect-for-emacs ((o simple-vector) (inspector backend-inspector))
-  inspector
+(defmethod inspect-for-emacs ((o simple-vector))
   (values (format nil "~A is a vector." o)
           (append 
            (label-value-line*

Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp	Thu Feb  7 03:32:58 2008
@@ -415,43 +415,6 @@
   (<= (char-code c) 127))
 
 

-;;;;; Misc
-
-(defun length= (seq n)
-  "Test for whether SEQ contains N number of elements. I.e. it's equivalent
- to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
- efficiently implemented."
-  (etypecase seq 
-    (list (do ((i n (1- i))
-               (list seq (cdr list)))
-              ((or (<= i 0) (null list))
-               (and (zerop i) (null list)))))
-    (sequence (= (length seq) n))))
-
-(defun ensure-list (thing)
-  (if (listp thing) thing (list thing)))
-
-(defun recursively-empty-p (list)
-  "Returns whether LIST consists only of arbitrarily nested empty lists."
-  (cond ((not (listp list)) nil)
-	((null list) t)
-	(t (every #'recursively-empty-p list))))
-
-(defun maybecall (bool fn &rest args)
-  "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
-  (if bool (apply fn args) (values-list args)))
-
-(defun exactly-one-p (&rest values)
-  "If exactly one value in VALUES is non-NIL, this value is returned.
-Otherwise NIL is returned."
-  (let ((found nil))
-    (dolist (v values)
-      (when v (if found
-                  (return-from exactly-one-p nil)
-                  (setq found v))))
-    found))
-
-

 ;;;;; Symbols
 
 (defun symbol-status (symbol &optional (package (symbol-package symbol)))
@@ -1569,30 +1532,6 @@
     (let ((*read-suppress* nil))
       (read-from-string string))))
 
-(defun read-softly-from-string (string)
-  "Returns three values:
-
-     1. the object resulting from READing STRING.
-
-     2. The index of the first character in STRING that was not read.
-
-     3. T if the object is a symbol that had to be newly interned
-        in some package. (This does not work for symbols in
-        compound forms like lists or vectors.)"
-  (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
-    (if found?
-        (values symbol (length string) nil)
-        (multiple-value-bind (sexp pos) (read-from-string string)
-          (values sexp pos
-                  (when (symbolp sexp)
-                    (prog1 t
-                      ;; assert that PARSE-SYMBOL didn't parse incorrectly.
-                      (assert (and (equal symbol-name (symbol-name sexp))
-                                   (eq package (symbol-package sexp)))))))))))
-
-(defun unintern-in-home-package (symbol)
-  (unintern symbol (symbol-package symbol)))
-
 ;; FIXME: deal with #\| etc.  hard to do portably.
 (defun tokenize-symbol (string)
   "STRING is interpreted as the string representation of a symbol
@@ -1755,7 +1694,7 @@
   (with-buffer-syntax ()
     (let ((*print-readably* nil))
       (cond ((null values) "; No value")
-            ((and (length= values 1)  (integerp (car values)))
+            ((and (integerp (car values)) (null (cdr values)))
              (let ((i (car values)))
                (format nil "~A~D (#x~X, #o~O, #b~B)" 
                        *echo-area-prefix* i i i i)))
@@ -2056,12 +1995,15 @@
                                       ,(princ-to-string real-condition))))
   (throw 'sldb-loop-catcher nil))
 
+(defvar *sldb-condition-printer* #'format-sldb-condition
+  "Function called to print a condition to an SLDB buffer.")
+
 (defun safe-condition-message (condition)
   "Safely print condition to a string, handling any errors during
 printing."
   (let ((*print-pretty* t) (*print-right-margin* 65))
     (handler-case
-        (format-sldb-condition condition)
+        (funcall *sldb-condition-printer* condition)
       (error (cond)
         ;; Beware of recursive errors in printing, so only use the condition
         ;; if it is printable itself:
@@ -2750,8 +2692,7 @@
     (set-pprint-dispatch '(cons (member function)) nil)
     (princ-to-string list)))
 
-(defmethod inspect-for-emacs ((object cons) inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((object cons))
   (if (consp (cdr object))
       (inspect-for-emacs-list object)
       (inspect-for-emacs-simple-cons object)))
@@ -2811,8 +2752,7 @@
  a hash table or array to show by default. If table has more than
  this then offer actions to view more. Set to nil for no limit." )
 
-(defmethod inspect-for-emacs ((ht hash-table) inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((ht hash-table))
   (values (prin1-to-string ht)
           (append
            (label-value-line*
@@ -2864,8 +2804,7 @@
 		      (progn (format t "How many elements should be shown? ") (read))))
 		 (swank::inspect-object thing)))))
 
-(defmethod inspect-for-emacs ((array array) inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((array array))
   (values "An array."
           (append
            (label-value-line*
@@ -2883,8 +2822,7 @@
            (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
                  append (label-value-line i (row-major-aref array i))))))
 
-(defmethod inspect-for-emacs ((char character) inspector)
-  (declare (ignore inspector))
+(defmethod inspect-for-emacs ((char character))
   (values "A character."
           (append 
            (label-value-line*
@@ -2903,7 +2841,6 @@
 (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
 (declaim (type vector *inspector-history*))
 (defvar *inspect-length* 30)
-(defvar *default-inspector* (make-default-inspector))
 
 (defun reset-inspector ()
   (setq *inspectee* nil
@@ -2912,14 +2849,6 @@
         *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
         *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
 
-(defun valid-function-name-p (form)
-  (or (symbolp form)
-      (and (consp form)
-           (second form)
-           (not (third form))
-           (eq (first form) 'setf)
-           (symbolp (second form)))))
-
 (defslimefun init-inspector (string)
   (with-buffer-syntax ()
     (reset-inspector)
@@ -2960,14 +2889,14 @@
   (list :action label (assign-index (list lambda refreshp)
                                     *inspectee-actions*)))
 
-(defun inspect-object (object &optional (inspector *default-inspector*))
+(defun inspect-object (object)
   (push (setq *inspectee* object) *inspector-stack*)
   (unless (find object *inspector-history*)
     (vector-push-extend object *inspector-history*))
   (let ((*print-pretty* nil)            ; print everything in the same line
         (*print-circle* t)
         (*print-readably* nil))
-    (multiple-value-bind (_ content) (inspect-for-emacs object inspector)
+    (multiple-value-bind (_ content) (inspect-for-emacs object)
       (declare (ignore _))
       (list :title (with-output-to-string (s)
                      (print-unreadable-object (object s :type t :identity t)))


From ksprotte at common-lisp.net  Fri Feb  8 14:45:58 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri,  8 Feb 2008 09:45:58 -0500 (EST)
Subject: [bknr-cvs] r2453 - branches/bos/projects/bos/m2
Message-ID: <20080208144558.A23F6610BD@common-lisp.net>

Author: ksprotte
Date: Fri Feb  8 09:45:54 2008
New Revision: 2453

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
Log:
added new function: FORMAT-LON-LAT


Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp	(original)
+++ branches/bos/projects/bos/m2/geometry.lisp	Fri Feb  8 09:45:54 2008
@@ -214,3 +214,56 @@
       (traverse boundary-point initial-direction)
       (nreverse polygon))))
 
+
+;;; formatting
+;; proposed by Michael Weber on alexandria-devel
+(defun format-mixed-radix-number (stream number radix-list format-list
+                                  &key lsb-first leading-zeros
+				  (trailing-zeros t))
+  "Prints NUMBER to STREAM in mixed-radix RADIX.
+representation-LIST is a list of radixes, least-significant first.
+FORMAT-LIST is a list of format directives, one for each digit.
+When LSB-FIRST is nil (default), print most-significant digit first,
+otherwise least-significant digit first.
+When LEADING-ZEROS and TRAILING-ZEROS are nil, leading and
+trailing zero digits are not printed, respectively. \(default: remove
+leading zeros, keep trailing zeros)"
+  (let ((format-pairs
+         (loop with digit and fraction
+	    initially (setf (values number fraction)
+			    (truncate number))
+	    for f-list on format-list
+	    and r-list = radix-list then (rest r-list)
+	    collect (list (first f-list)
+			  (cond ((endp r-list)
+				 (shiftf number 0))
+				((rest f-list)
+				 (setf (values number digit)
+				       (truncate number (first r-list)))
+				 digit)
+				(t number)))
+	    into list
+	    finally (progn
+		      (incf (cadar list) fraction)
+		      (return (nreverse list))))))
+    (unless trailing-zeros
+      (setf format-pairs (member-if #'plusp format-pairs :key
+				    #'second)))
+    (when lsb-first
+      (setf format-pairs (nreverse format-pairs)))
+    (unless leading-zeros
+      (setf format-pairs (member-if #'plusp format-pairs :key
+				    #'second)))
+    (format stream "~{~{~@?~}~}" format-pairs)))
+
+
+(defun format-decimal-degree (degree)
+  (format-mixed-radix-number nil (* 60 degree) '(60 360) '("~,2F?" "~D?")))
+
+(defun format-lon-lat (lon lat)
+  (format nil "~A ~:[S~;N~], ~A~:[W~;E~]"
+	  (format-decimal-degree (abs lat))
+	  (plusp lat)
+	  (format-decimal-degree (abs lon))
+	  (plusp lon)))
+


From ksprotte at common-lisp.net  Fri Feb  8 15:36:04 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri,  8 Feb 2008 10:36:04 -0500 (EST)
Subject: [bknr-cvs] r2454 - branches/bos/projects/bos/m2
Message-ID: <20080208153604.D76111C003@common-lisp.net>

Author: ksprotte
Date: Fri Feb  8 10:36:04 2008
New Revision: 2454

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
   branches/bos/projects/bos/m2/make-certificate.lisp
   branches/bos/projects/bos/m2/packages.lisp
Log:
Geo-Koordinaten im PDF anzeigen #5 done
(Template still needs to be changed in Acrobat for larger font)


Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp	(original)
+++ branches/bos/projects/bos/m2/geometry.lisp	Fri Feb  8 10:36:04 2008
@@ -258,10 +258,10 @@
 
 
 (defun format-decimal-degree (degree)
-  (format-mixed-radix-number nil (* 60 degree) '(60 360) '("~,2F?" "~D?")))
+  (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F????" " ~D??" "~D??")))
 
-(defun format-lon-lat (lon lat)
-  (format nil "~A ~:[S~;N~], ~A~:[W~;E~]"
+(defun format-lon-lat (stream lon lat)
+  (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]"
 	  (format-decimal-degree (abs lat))
 	  (plusp lat)
 	  (format-decimal-degree (abs lon))

Modified: branches/bos/projects/bos/m2/make-certificate.lisp
==============================================================================
--- branches/bos/projects/bos/m2/make-certificate.lisp	(original)
+++ branches/bos/projects/bos/m2/make-certificate.lisp	Fri Feb  8 10:36:04 2008
@@ -42,8 +42,19 @@
 		   :sponsor-id (sponsor-id sponsor)
 		   :master-code (sponsor-master-code sponsor)
 		   :sqm-count (length (contract-m2s contract))
-		   :sqm-ids (with-output-to-string (s)
-			      (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*)
-				    do (loop for nums on group
-					     do (princ (car nums) s)
-					     do (princ (if (cdr nums) #\Tab #\Newline) s)))))))
+		   ;; :sqm-ids (with-output-to-string (s)
+		   ;; 			      (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*)
+		   ;; 				 do (loop for nums on group
+		   ;; 				       do (princ (car nums) s)
+		   ;; 				       do (princ (if (cdr nums) #\Tab #\Newline) s))))
+		   ;; should later be called :sqm-coordinates
+		   :sqm-ids
+		   (flet ((format-point (stream x y)
+			    (apply #'geometry:format-lon-lat stream
+				   (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x)
+							       (- +nw-utm-y+ y) +utm-zone+ t))))
+		     (destructuring-bind (left top width height)
+			 (contract-bounding-box contract)
+		       (with-output-to-string (out)
+			 (format-point out left top) (terpri out)			 
+			 (format-point out (+ left width) (+ top height)) (terpri out)))))))

Modified: branches/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp	(original)
+++ branches/bos/projects/bos/m2/packages.lisp	Fri Feb  8 10:36:04 2008
@@ -9,7 +9,8 @@
 	   #:point-in-polygon-p
 	   #:point-in-circle-p
 	   #:find-boundary-point
-	   #:region-to-polygon))
+	   #:region-to-polygon
+	   #:format-lon-lat))
 
 (defpackage :geo-utm
   (:use :cl)


From hhubner at common-lisp.net  Sun Feb 10 09:02:46 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 10 Feb 2008 04:02:46 -0500 (EST)
Subject: [bknr-cvs] r2455 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080210090246.8D2BF2F069@common-lisp.net>

Author: hhubner
Date: Sun Feb 10 04:02:46 2008
New Revision: 2455

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
Log:
fix syntax error that has not been detected by cmucl

Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Sun Feb 10 04:02:46 2008
@@ -406,8 +406,8 @@
 
 (defgeneric object-date-list-handler-grouped-objects (handler object))
 
-(defmethod object-date-list-handler-date ((handler object-date-list-handler object-list-handler)
-					  object)
+(defmethod object-date-list-handler-date ((handler object-date-list-handler)
+                                          object)
   (with-query-params (date)
     (get-daytime (if date
 		     (or (parse-integer date :junk-allowed t)


From hhubner at common-lisp.net  Sun Feb 10 22:35:24 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 10 Feb 2008 17:35:24 -0500 (EST)
Subject: [bknr-cvs] r2456 - branches/trunk-reorg/bknr/datastore/src/skip-list
Message-ID: <20080210223524.848A62D07C@common-lisp.net>

Author: hhubner
Date: Sun Feb 10 17:35:23 2008
New Revision: 2456

Modified:
   branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
Log:
Fix bug in skip-list random number generator that caused skip list
insertion performance to drop drastically on SBCL with 64bits.  It
appears as if the original algorithm returned NIL to approximately
half the invocations, despite the comment claiming that NIL would be
returned in 3/4 of the times.  I replaced the explicit random number
generator by a call to (RANDOM) with a separate random state for
skip-lists.


Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	Sun Feb 10 17:35:23 2008
@@ -6,23 +6,14 @@
 
 ;;; Pseudo-random number generator from FreeBSD
 
-(defparameter *random-n*
-  (the fixnum (get-internal-real-time))
-  "Internal status of the pseudo-random number generator.")
-
-(defun random-seed (seed)
-  "Seed the pseudo-random number generator."
-  (setf *random-n* seed))
+(defparameter *sl-random-state*
+  (make-random-state)
+  "Internal status of the random number generator.")
 
 (defun sl-random ()
-  "Pseudo-random number generator from FreeBSD, returns NIL 3/4 of the time."
-  (declare (optimize (speed 3))
-	   (type integer *random-n*))
-  (logtest (logand most-positive-fixnum
-		   (setf *random-n*
-			 (mod (+ (the number (* *random-n* 1103515245)) 12345)
-			      2147483648)))
-	   (ash 1 (- (integer-length most-positive-fixnum) 1))))
+  "Pseudo-random number generator, returns NIL 3/4 of the time."
+  (declare (optimize (speed 3)))
+  (< 2 (random 4 *sl-random-state*)))
 
 (defconstant +max-level+ (the fixnum 32)
   "Maximum level of skip-list, should be enough for 2^32 elements.")


From hhubner at common-lisp.net  Sun Feb 10 22:47:13 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 10 Feb 2008 17:47:13 -0500 (EST)
Subject: [bknr-cvs] r2457 -
	branches/trunk-reorg/thirdparty/hunchentoot-0.15.0
Message-ID: <20080210224713.AE42549087@common-lisp.net>

Author: hhubner
Date: Sun Feb 10 17:47:10 2008
New Revision: 2457

Modified:
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
Log:
acl-compat does not actually seem to be needed with current CCL and
Hunchentoot.


Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	(original)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	Sun Feb 10 17:47:10 2008
@@ -51,7 +51,7 @@
                :rfc2388
                #+:sbcl :sb-bsd-sockets
                #+:sbcl :sb-posix
-               #+:openmcl :acl-compat
+               ; #+:openmcl :acl-compat
                :url-rewrite)
   :components ((:file "packages")
                (:file "conditions")


From hhubner at common-lisp.net  Sun Feb 10 22:47:54 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 10 Feb 2008 17:47:54 -0500 (EST)
Subject: [bknr-cvs] r2458 - in branches/trunk-reorg/bknr:
	datastore/src/utils modules/bug web/src/images web/src/web
Message-ID: <20080210224754.9EB1049087@common-lisp.net>

Author: hhubner
Date: Sun Feb 10 17:47:54 2008
New Revision: 2458

Modified:
   branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp
   branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
   branches/trunk-reorg/bknr/modules/bug/package.lisp
   branches/trunk-reorg/bknr/web/src/images/image.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
Log:
openmcl fixes.


Modified: branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/actor.lisp	Sun Feb 10 17:47:54 2008
@@ -18,15 +18,15 @@
 (defmethod actor-start ((actor bknr-actor))
   (actor-stop actor)
   (setf (slot-value actor 'process)
-    (mp:make-process (lambda ()
-		       (funcall #'run-function actor))
-		     :name (bknr-actor-name actor))))
+    (make-process (lambda ()
+                    (funcall #'run-function actor))
+                  :name (bknr-actor-name actor))))
 
 (defmethod actor-running-p ((actor bknr-actor))
   (and (slot-boundp actor 'process)
-       (mp:process-active-p (bknr-actor-process actor))))
+       (process-active-p (bknr-actor-process actor))))
 
 (defmethod actor-stop ((actor bknr-actor))
   (when (slot-boundp actor 'process)
-    (mp:destroy-process (bknr-actor-process actor))
+    (destroy-process (bknr-actor-process actor))
     (slot-makunbound actor 'process)))

Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	Sun Feb 10 17:47:54 2008
@@ -2,140 +2,144 @@
 
 (defpackage :bknr.utils
   (:use :cl
-	:cl-ppcre
-	:cl-interpol
-	:md5
+        :cl-ppcre
+        :cl-interpol
+        :md5
         #+cmu :extensions
-	#+sbcl :sb-ext)
+        #+sbcl :sb-ext
+        #+cmu :mp
+        #+openmcl :ccl)
+  #+openmcl
+  (:shadow :ccl #:copy-file)
   (:shadowing-import-from :cl-interpol quote-meta-chars)
   (:export #:define-bknr-class
 
            ;; byte size formatting
            #:scale-bytes
    
-	   ;; date format
-	   #:format-date-time
-	   #:format-time-interval
-	   #:format-duration
-	   #:year-interval
-	   #:month-interval
-	   #:day-interval
-	   #:timetag
-	   #:daytag
-	   #:get-daytime
-	   #:get-hourtime
-	   #:get-monthtime
-	   #:previous-day
-	   #:next-day
-	   #:month-num-days
+           ;; date format
+           #:format-date-time
+           #:format-time-interval
+           #:format-duration
+           #:year-interval
+           #:month-interval
+           #:day-interval
+           #:timetag
+           #:daytag
+           #:get-daytime
+           #:get-hourtime
+           #:get-monthtime
+           #:previous-day
+           #:next-day
+           #:month-num-days
 
-	   #:hostname
+           #:hostname
            #:parse-time
 
-	   ;; filesystem functions
-	   #:copy-stream
-	   #:copy-file
-	   #:move-file
-	   #:directory-empty-p
-	   #:subdir-p
-	   #:temporary-file
-	   #:with-temp-file
-	   #:file-contents
-	   #:parent-directory
+           ;; filesystem functions
+           #:copy-stream
+           #:copy-file
+           #:move-file
+           #:directory-empty-p
+           #:subdir-p
+           #:temporary-file
+           #:with-temp-file
+           #:file-contents
+           #:parent-directory
    
-	   ;; list functions
-	   #:delete-first
-	   #:make-keyword-from-string
-
-	   #:assoc-values
-	   #:assoc-to-keywords
-	   #:insert-at-index
-	   #:find-neighbourhood
-	   #:group-by
-	   #:group-on
-	   #:find-all
-	   #:genlist
-	   #:nrotate
-	   #:shift-until
-	   #:count-multiple
-
-	   ;; hash table
-	   #:hash-to-list
-	   #:hash-values
-	   #:hash-keys
-	   #:incf-hash
-
-	   ;; randomize
-	   #:random-elts
-	   #:randomize-list
-
-	   ;; md5
-	   #:hash-to-hex
-	   #:md5-string
-
-	   ;; capabilty
-	   #:make-capability-string
-
-	   ;; content-types
-	   #:pathname-type-symbol
-	   #:image-content-type
-	   #:pathname-content-type
-	   #:image-type-symbol
-
-	   ;; utf-8
-	   #:convert-utf8-to-latin1
-
-	   ;; strings
-	   #:find-matching-strings
-	   #:make-extendable-string
-
-	   ;; stream
-	   #:read-delimited
-	   #:read-file
-
-	   ;; smbpasswd
-	   #:set-smb-password
-	   #:smb-password-error
-
-	   ;; actor
-	   #:bknr-actor
-	   #:bknr-actor-name
-	   #:run-function
-	   #:actor-start
-	   #:actor-stop
-	   #:actor-running-p
-
-	   ;; cron
-	   #:cron-actor
-
-	   ;; reader
-	   #:whitespace-char-p
-	   #:whitespace-p
-	   #:bknr-read-delimited-list
-	   #:bknr-read
-	   #:string-beginning-with-p
-	   #:string-delimited-by-p
-
-	   ;; crypt-md5
-	   #:crypt-md5
-	   #:verify-md5-password
-
-	   ;; FDF creation
-	   #:make-fdf-file
-
-	   #:remove-keys
-	   #:eval-initargs
-
-	   ;; Package cleaning for the build process
-	   #:within-temporary-package
-
-	   ;; mp compatibility
-	   #:mp-make-lock
-	   #:mp-with-lock-held
-	   #:mp-with-recursive-lock-held
+           ;; list functions
+           #:delete-first
+           #:make-keyword-from-string
+
+           #:assoc-values
+           #:assoc-to-keywords
+           #:insert-at-index
+           #:find-neighbourhood
+           #:group-by
+           #:group-on
+           #:find-all
+           #:genlist
+           #:nrotate
+           #:shift-until
+           #:count-multiple
+
+           ;; hash table
+           #:hash-to-list
+           #:hash-values
+           #:hash-keys
+           #:incf-hash
+
+           ;; randomize
+           #:random-elts
+           #:randomize-list
+
+           ;; md5
+           #:hash-to-hex
+           #:md5-string
+
+           ;; capabilty
+           #:make-capability-string
+
+           ;; content-types
+           #:pathname-type-symbol
+           #:image-content-type
+           #:pathname-content-type
+           #:image-type-symbol
+
+           ;; utf-8
+           #:convert-utf8-to-latin1
+
+           ;; strings
+           #:find-matching-strings
+           #:make-extendable-string
+
+           ;; stream
+           #:read-delimited
+           #:read-file
+
+           ;; smbpasswd
+           #:set-smb-password
+           #:smb-password-error
+
+           ;; actor
+           #:bknr-actor
+           #:bknr-actor-name
+           #:run-function
+           #:actor-start
+           #:actor-stop
+           #:actor-running-p
+
+           ;; cron
+           #:cron-actor
+
+           ;; reader
+           #:whitespace-char-p
+           #:whitespace-p
+           #:bknr-read-delimited-list
+           #:bknr-read
+           #:string-beginning-with-p
+           #:string-delimited-by-p
+
+           ;; crypt-md5
+           #:crypt-md5
+           #:verify-md5-password
+
+           ;; FDF creation
+           #:make-fdf-file
+
+           #:remove-keys
+           #:eval-initargs
+
+           ;; Package cleaning for the build process
+           #:within-temporary-package
+
+           ;; mp compatibility
+           #:mp-make-lock
+           #:mp-with-lock-held
+           #:mp-with-recursive-lock-held
 
-	   ;; class utils
-	   #:class-subclasses
+           ;; class utils
+           #:class-subclasses
 
-	   ;; norvig
-	   #:find-all))
+           ;; norvig
+           #:find-all))

Modified: branches/trunk-reorg/bknr/modules/bug/package.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/bug/package.lisp	(original)
+++ branches/trunk-reorg/bknr/modules/bug/package.lisp	Sun Feb 10 17:47:54 2008
@@ -12,7 +12,7 @@
 	:bknr.indices
 	:bknr.datastore
 	:bknr.mail)
-  (:shadowing-import-from :cl-interpol quote-meta-chars)
+  (:shadowing-import-from :cl-interpol #:quote-meta-chars)
   (:export #:bug-tracker
 	   #:bug-tracker-bug-reports
 	   #:bug-tracker-add-bug-report
@@ -32,6 +32,5 @@
 	   #:priority-to-num
 	   #:bug-report-add-annotation
 	   #:bug-report-owner
-	   #:edit-bug-report-handler)
-  (:shadowing-import-from :cl-interpol #:quote-meta-chars))
+	   #:edit-bug-report-handler))
 

Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/image.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/image.lisp	Sun Feb 10 17:47:54 2008
@@ -194,4 +194,6 @@
 	  #+cmu
 	  (unix:unix-rmdir (namestring file))
 	  #+sbcl
-	  (sb-posix:rmdir (namestring file)))))
+	  (sb-posix:rmdir (namestring file))
+      #+openmcl
+      (ccl::%rmdir (namestring file)))))

Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Sun Feb 10 17:47:54 2008
@@ -13,7 +13,7 @@
 				       "/usr/local/share/xml/catalog"))
 
 (eval-when (:load-toplevel :execute)
-  (let ((env-catalog (sb-ext:posix-getenv "XMLCATALOG")))
+  (let ((env-catalog (#+sbcl sb-ext:posix-getenv #+openmcl ccl:getenv "XMLCATALOG")))
     (when env-catalog
       (pushnew env-catalog *template-dtd-catalog* :test #'equal)))
   (setf cxml:*catalog* (cxml:make-catalog (remove-if-not #'probe-file *template-dtd-catalog*))


From ksprotte at common-lisp.net  Mon Feb 11 10:13:25 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 05:13:25 -0500 (EST)
Subject: [bknr-cvs] r2459 -
	branches/bos/projects/bos/payment-website/infosystem
Message-ID: <20080211101325.1C8C881007@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 05:13:22 2008
New Revision: 2459

Modified:
   branches/bos/projects/bos/payment-website/infosystem/javascript.js
Log:
Fixed YouTube-Fenster #6 by changing height


Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js
==============================================================================
--- branches/bos/projects/bos/payment-website/infosystem/javascript.js	(original)
+++ branches/bos/projects/bos/payment-website/infosystem/javascript.js	Mon Feb 11 05:13:22 2008
@@ -899,7 +899,7 @@
 	document.getElementById("MovieApplet").innerHTML
 	    = '<object width="360" height="340"> <param name="movie" value=" '
 	    + movie_url + '"> </param> <embed src=" '
-	    + movie_url + '" type="application/x-shockwave-flash" width="360" height="340"> </embed> </object>';
+	    + movie_url + '" type="application/x-shockwave-flash" width="360" height="302"> </embed> </object>';
     }
 }
 


From hhubner at common-lisp.net  Mon Feb 11 10:46:19 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 05:46:19 -0500 (EST)
Subject: [bknr-cvs] r2460 - branches/bos/projects/bos/web
Message-ID: <20080211104619.59E892D1B7@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 05:46:15 2008
New Revision: 2460

Modified:
   branches/bos/projects/bos/web/webserver.lisp
Log:
Fix for #20, set session's language when / page is sent out.


Modified: branches/bos/projects/bos/web/webserver.lisp
==============================================================================
--- branches/bos/projects/bos/web/webserver.lisp	(original)
+++ branches/bos/projects/bos/web/webserver.lisp	Mon Feb 11 05:46:15 2008
@@ -47,8 +47,11 @@
     ((and (not (scan "/" template-name))
 	  (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml")
 					    (template-handler-destination handler)))))
-     (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request)
-						 *default-language*)
+     (unless (session-variable :language)
+       (setf (session-variable :language) (or (find-browser-prefered-language request)
+					      *default-language*)))
+     (setf template-name (format nil "~A/~A"
+				 (session-variable :language)
 				 (if (equal "" template-name)
 				     "index" template-name)))))
   (call-next-method handler template-name))


From ksprotte at common-lisp.net  Mon Feb 11 11:39:57 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 06:39:57 -0500 (EST)
Subject: [bknr-cvs] r2461 - branches/bos/projects/bos/web
Message-ID: <20080211113957.7F1B74D042@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 06:39:55 2008
New Revision: 2461

Modified:
   branches/bos/projects/bos/web/tags.lisp
Log:
added new template var :geo-coord for save-profile and removed sqm-x sqm-y
not tested yet


Modified: branches/bos/projects/bos/web/tags.lisp
==============================================================================
--- branches/bos/projects/bos/web/tags.lisp	(original)
+++ branches/bos/projects/bos/web/tags.lisp	Mon Feb 11 06:39:55 2008
@@ -168,8 +168,11 @@
     (setf (get-template-var :country) (sponsor-country sponsor))
     (setf (get-template-var :infotext) (sponsor-info-text sponsor))
     (setf (get-template-var :name) (user-full-name sponsor))
-    (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract)))))
-    (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract)))))
+    (setf (get-template-var :geo-coord) (multiple-value-bind (left top)
+					    (contract-bounding-box contract)
+					  (apply #'geometry:format-lon-lat nil
+						 (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
+									     (- +nw-utm-y+ top) +utm-zone+ t))))
     (setf (get-template-var :numsqm)
 	  (format nil "~D"
 		  (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))


From hhubner at common-lisp.net  Mon Feb 11 12:13:00 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 07:13:00 -0500 (EST)
Subject: [bknr-cvs] r2462 - branches/bos/projects/bos/web
Message-ID: <20080211121300.AAD7962120@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 07:12:57 2008
New Revision: 2462

Modified:
   branches/bos/projects/bos/web/sponsor-handlers.lisp
Log:
Fix password setting through CMS.


Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/sponsor-handlers.lisp	Mon Feb 11 07:12:57 2008
@@ -181,7 +181,9 @@
 	(let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
 		     (not (equal field-value (slot-value sponsor field-name))))
-	    (change-slot-values sponsor field-name field-value)
+            (if (eq field-name 'password)
+                (set-user-password sponsor field-value)
+                (change-slot-values sponsor field-name field-value))
 	    (setf changed t)
 	    (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
       (dolist (contract (sponsor-contracts sponsor))


From ksprotte at common-lisp.net  Mon Feb 11 12:30:10 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 07:30:10 -0500 (EST)
Subject: [bknr-cvs] r2463 - branches/bos/projects/bos/web
Message-ID: <20080211123010.2FAEA5C16F@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 07:30:08 2008
New Revision: 2463

Modified:
   branches/bos/projects/bos/web/tags.lisp
Log:
added again template-vars :sqm-x, :sqm-y.
Also reindent/untabify


Modified: branches/bos/projects/bos/web/tags.lisp
==============================================================================
--- branches/bos/projects/bos/web/tags.lisp	(original)
+++ branches/bos/projects/bos/web/tags.lisp	Mon Feb 11 07:30:08 2008
@@ -10,13 +10,13 @@
 
 (defun language-options-1 (current-language)
   (loop for (language-symbol language-name) in (website-languages)
-	do (if (equal language-symbol current-language)
-	       (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " "))
-	       (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " ")))))
+     do (if (equal language-symbol current-language)
+            (html ((:option :value (format nil "/~a/index" language-symbol) :selected "selected") " " (:princ language-name) " "))
+            (html ((:option :value (format nil "/~a/index" language-symbol)) " " (:princ language-name) " ")))))
 
 (define-bknr-tag language-chooser (name)
   (html ((:select :name name)
-	 (language-options-1 (current-website-language)))))
+         (language-options-1 (current-website-language)))))
 
 (define-bknr-tag language-options ()
   (language-options-1 (current-website-language)))
@@ -27,7 +27,7 @@
 (define-bknr-tag process-payment (&key children)
   (with-template-vars (cartId transId email country)
     (let* ((contract (get-contract (parse-integer cartId)))
-	   (sponsor (contract-sponsor contract)))
+           (sponsor (contract-sponsor contract)))
       (change-slot-values sponsor 'bknr.web::email email)
       (change-slot-values contract 'bos.m2::worldpay-trans-id transId)
       (sponsor-set-country sponsor country)
@@ -40,13 +40,13 @@
   (with-template-vars (gift email name address want-print)
     (let ((contract (find-store-object (parse-integer (get-template-var :contract-id)))))
       (when (equal want-print "no")
-	(contract-set-download-only-p contract t))
+        (contract-set-download-only-p contract t))
       (contract-issue-cert contract name :address address :language (session-variable :language))
       (mail-worldpay-sponsor-data (get-template-var :request))
       (bknr.web::redirect-request :target (if gift "index"
-					      (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
-						      (uriencode-string name) (uriencode-string email)
-						      (store-object-id (contract-sponsor contract))))))))
+                                              (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
+                                                      (uriencode-string name) (uriencode-string email)
+                                                      (store-object-id (contract-sponsor contract))))))))
 
 (define-bknr-tag urkunde-per-post (&key contract-id min-amount message)
   (let ((contract (get-contract (parse-integer contract-id))))
@@ -60,81 +60,81 @@
 
 (define-bknr-tag maybe-base (&key href)
   (when (and href
-	     (not (equal "" href)))
+             (not (equal "" href)))
     (html ((:base "href" href)))))
 
 (define-bknr-tag buy-sqm (&key children)
   (handler-case
       (with-template-vars (numsqm numsqm1 action gift donationcert-yearly download-only)
-	(let* ((numsqm (parse-integer (or numsqm numsqm1)))
-	       ;; Wer ueber dieses Formular bestellt, ist ein neuer
-	       ;; Sponsor, also ein neues Sponsorenobjekt anlegen.  Eine
-	       ;; Profil-ID wird automatisch zugewiesen, sonstige Daten
-	       ;; haben wir zu diesem Zeitpunkt noch nicht.
-	       ;; ?berweisung wird nur f?r die deutsche und d?nische
-	       ;; Website angeboten, was passenderweise durch die folgende
-	       ;; ?berpr?fung auch sicher gestellt wurde.  Sollte man aber
-	       ;; eventuell noch mal pr?fen und sicher stellen.
-	       (manual-transfer (or (scan #?r"rweisen" action)
-				    (scan #?r"rweisung" action)
-				    (scan #?r"verf" action)))
-	       (language (session-variable :language))
-	       (sponsor (make-sponsor :language language))
-	       (contract (make-contract sponsor numsqm
-					:download-only download-only
-					:expires (+ (if manual-transfer
-							bos.m2::*manual-contract-expiry-time*
-							bos.m2::*online-contract-expiry-time*)
-						    (get-universal-time)))))
-	  (destructuring-bind (price currency)
-	      (case (make-keyword-from-string language)
-		(:da (list (* numsqm 24) "DKK"))
-		(t   (list (* numsqm 3)  "EUR")))
-	    (setf (get-template-var :worldpay-url)
-		  (if manual-transfer
-		      (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]"
-			      (store-object-id contract)
-			      price
-			      numsqm
-			      donationcert-yearly)
-		      (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&currency=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]"
-			      *worldpay-installation-id*
-			      (store-object-id contract)
-			      price
-			      currency
-			      language
-			      (encode-urlencoded (format nil "~A ~A Samboja Lestari"
-							 numsqm
-							 (case (make-keyword-from-string language)
-							   (:de "qm Regenwald in")
-							   (:da "m2 Regnskov i")
-							   (t "sqm rain forest in"))))
-			      (store-object-id sponsor)
-			      (sponsor-master-code sponsor)
-			      (if donationcert-yearly "1" "0")
-			      (if gift "1" "0")
-			      (when *worldpay-test-mode* "&testMode=100"))))))
-	(mapc #'emit-template-node children))
+        (let* ((numsqm (parse-integer (or numsqm numsqm1)))
+               ;; Wer ueber dieses Formular bestellt, ist ein neuer
+               ;; Sponsor, also ein neues Sponsorenobjekt anlegen.  Eine
+               ;; Profil-ID wird automatisch zugewiesen, sonstige Daten
+               ;; haben wir zu diesem Zeitpunkt noch nicht.
+               ;; ?berweisung wird nur f?r die deutsche und d?nische
+               ;; Website angeboten, was passenderweise durch die folgende
+               ;; ?berpr?fung auch sicher gestellt wurde.  Sollte man aber
+               ;; eventuell noch mal pr?fen und sicher stellen.
+               (manual-transfer (or (scan #?r"rweisen" action)
+                                    (scan #?r"rweisung" action)
+                                    (scan #?r"verf" action)))
+               (language (session-variable :language))
+               (sponsor (make-sponsor :language language))
+               (contract (make-contract sponsor numsqm
+                                        :download-only download-only
+                                        :expires (+ (if manual-transfer
+                                                        bos.m2::*manual-contract-expiry-time*
+                                                        bos.m2::*online-contract-expiry-time*)
+                                                    (get-universal-time)))))
+          (destructuring-bind (price currency)
+              (case (make-keyword-from-string language)
+                (:da (list (* numsqm 24) "DKK"))
+                (t   (list (* numsqm 3)  "EUR")))
+            (setf (get-template-var :worldpay-url)
+                  (if manual-transfer
+                      (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]"
+                              (store-object-id contract)
+                              price
+                              numsqm
+                              donationcert-yearly)
+                      (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A&currency=~A&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]"
+                              *worldpay-installation-id*
+                              (store-object-id contract)
+                              price
+                              currency
+                              language
+                              (encode-urlencoded (format nil "~A ~A Samboja Lestari"
+                                                         numsqm
+                                                         (case (make-keyword-from-string language)
+                                                           (:de "qm Regenwald in")
+                                                           (:da "m2 Regnskov i")
+                                                           (t "sqm rain forest in"))))
+                              (store-object-id sponsor)
+                              (sponsor-master-code sponsor)
+                              (if donationcert-yearly "1" "0")
+                              (if gift "1" "0")
+                              (when *worldpay-test-mode* "&testMode=100"))))))
+        (mapc #'emit-template-node children))
     (bos.m2::allocation-areas-exhausted (e)
       (declare (ignore e))
       (bknr.web::redirect-request :target "allocation-areas-exhausted"))))
 
 (define-bknr-tag mail-transfer ()
   (with-query-params ((get-template-var :request)
-		      country
-		      contract-id 
-		      name vorname strasse plz ort)
+                      country
+                      contract-id
+                      name vorname strasse plz ort)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
-	   (download-only (< (contract-price contract) *mail-certificate-threshold*)))
+           (download-only (< (contract-price contract) *mail-certificate-threshold*)))
       (with-transaction (:prepare-before-mail)
-	(setf (contract-download-only contract) download-only)
-	(setf (sponsor-country (contract-sponsor contract)) country))
+        (setf (contract-download-only contract) download-only)
+        (setf (sponsor-country (contract-sponsor contract)) country))
       (contract-issue-cert contract (format nil "~A ~A" vorname name)
-			   :address (format nil "~A ~A~%~A~%~A ~A"
-					    vorname name
-					    strasse
-					    plz ort)
-			   :language (session-variable :language))
+                           :address (format nil "~A ~A~%~A~%~A ~A"
+                                            vorname name
+                                            strasse
+                                            plz ort)
+                           :language (session-variable :language))
       (mail-manual-sponsor-data (get-template-var :request)))))
 
 (define-bknr-tag when-certificate (&key children)
@@ -148,34 +148,36 @@
 
 (define-bknr-tag save-profile (&key children)
   (let* ((sponsor (bknr-request-user (get-template-var :request)))
-	 (contract (first (sponsor-contracts sponsor))))
+         (contract (first (sponsor-contracts sponsor))))
     (with-template-vars (email name password infotext anonymize)
       (when anonymize
-	(change-slot-values sponsor
-			    'full-name nil
-			    'info-text nil
-			    'email nil))
+        (change-slot-values sponsor
+                            'full-name nil
+                            'info-text nil
+                            'email nil))
       (when name
-	(change-slot-values sponsor 'full-name name))
+        (change-slot-values sponsor 'full-name name))
       (when email
-	(change-slot-values sponsor 'bknr.web::email email))
+        (change-slot-values sponsor 'bknr.web::email email))
       (when password
-	(set-user-password sponsor password))
+        (set-user-password sponsor password))
       (when infotext
-	(change-slot-values sponsor 'info-text infotext)))
+        (change-slot-values sponsor 'info-text infotext)))
     (setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor)))
     (setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract)))
     (setf (get-template-var :country) (sponsor-country sponsor))
     (setf (get-template-var :infotext) (sponsor-info-text sponsor))
     (setf (get-template-var :name) (user-full-name sponsor))
+    (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) 
+    (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) 
     (setf (get-template-var :geo-coord) (multiple-value-bind (left top)
-					    (contract-bounding-box contract)
-					  (apply #'geometry:format-lon-lat nil
-						 (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
-									     (- +nw-utm-y+ top) +utm-zone+ t))))
+                                            (contract-bounding-box contract)
+                                          (apply #'geometry:format-lon-lat nil
+                                                 (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
+                                                                             (- +nw-utm-y+ top) +utm-zone+ t))))
     (setf (get-template-var :numsqm)
-	  (format nil "~D"
-		  (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))
+          (format nil "~D"
+                  (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))
   (mapc #'emit-template-node children))
 
 (define-bknr-tag admin-login-page (&key children)
@@ -185,7 +187,7 @@
 
 (define-bknr-tag google-analytics-track ()
   (html ((:script :type "text/javascript")
-	 "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.');
+         "var gaJsHost = (('https:' == document.location.protocol) ? 'https://ssl.' : 'http://www.');
 document.write(unescape('%3Cscript src=%22' + gaJsHost + 'google-analytics.com/ga.js%22 type=%22text/javascript%22%3E%3C/script%3E'));")
-	((:script :type "text/javascript")
-	 (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))
+        ((:script :type "text/javascript")
+         (:princ #?"if (_gat) { var pageTracker = _gat._getTracker('$(*google-analytics-account*)'); pageTracker._initData(); pageTracker._trackPageview(); }"))))


From dverna at common-lisp.net  Mon Feb 11 12:35:18 2008
From: dverna at common-lisp.net (dverna at common-lisp.net)
Date: Mon, 11 Feb 2008 07:35:18 -0500 (EST)
Subject: [bknr-cvs] r2464 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080211123518.61D2972096@common-lisp.net>

Author: dverna
Date: Mon Feb 11 07:35:17 2008
New Revision: 2464

Modified:
   trunk/projects/lisp-ecoop/website/templates/home.xml
   trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
   trunk/projects/lisp-ecoop/website/templates/toplevel.xml
Log:
Fixed workshop location spelling

Modified: trunk/projects/lisp-ecoop/website/templates/home.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/home.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/home.xml	Mon Feb 11 07:35:17 2008
@@ -5,7 +5,7 @@
 
 <h1>5th European Lisp Workshop</h1>
 
-<p>July 07 - Paphos-Cyprus - co-located with ECOOP 2008</p>
+<p>July 07 - Paphos, Cyprus - co-located with ECOOP 2008</p>
 
 <p>
 <!-- Supported by <a href="http://clozure.com/" target="_new">Clozure

Modified: trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	(original)
+++ trunk/projects/lisp-ecoop/website/templates/lisp-ecoop.xsl	Mon Feb 11 07:35:17 2008
@@ -21,7 +21,8 @@
    <body>
     <div id="banner">
      <div id="title">5th European Lisp Workshop</div>
-     <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div>
+     <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/"
+     target="_new">ECOOP 2008</a><br />July 07 - Paphos, Cyprus</div>
      <div id="logo">
       <a href="http://bknr.net/" target="_new">
        <img width="57" height="20" alt="BKNR Logo" src="/static/bknr-logo.png" border="0" />

Modified: trunk/projects/lisp-ecoop/website/templates/toplevel.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/toplevel.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/toplevel.xml	Mon Feb 11 07:35:17 2008
@@ -16,7 +16,8 @@
   <body>
     <div id="banner">
       <div id="title">5th European Lisp Workshop</div>
-      <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/" target="_new">ECOOP 2008</a><br />July 07 - Paphos-Cyprus</div>
+      <div id="subtitle">Co-located with <a href="http://2008.ecoop.org/"
+target="_new">ECOOP 2008</a><br />July 07 - Paphos, Cyprus</div>
       <div id="logo">
 	<a href="http://bknr.net/" target="_new">
 	  <img width="57" height="20" alt="BKNR Logo" src="$(base)image/bknr-logo/thumbnail,,57,20" border="0" />


From ksprotte at common-lisp.net  Mon Feb 11 12:39:02 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 07:39:02 -0500 (EST)
Subject: [bknr-cvs] r2465 - in branches/bos/projects/bos:
	payment-website/templates/da payment-website/templates/de
	payment-website/templates/en web
Message-ID: <20080211123902.CC64781029@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 07:39:01 2008
New Revision: 2465

Modified:
   branches/bos/projects/bos/payment-website/templates/da/profil.xml
   branches/bos/projects/bos/payment-website/templates/de/profil.xml
   branches/bos/projects/bos/payment-website/templates/en/profil.xml
   branches/bos/projects/bos/web/tags.lisp
Log:
fix for #16 Koordinaten in Laenge und Breite - Einbau eines Links auf die Profilseite


Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/da/profil.xml	Mon Feb 11 07:39:01 2008
@@ -55,7 +55,7 @@
      </tr>
      <tr>
       <td class="Label">kvardratmeter</td>
-      <td class="Input">til v?rdi af $(numsqm) m? er blevet opk?bt<br></br>UTM-kordinater: N$(sqm-x) E$(sqm-y)
+      <td class="Input">til v?rdi af $(numsqm) m? er blevet opk?bt<br></br>kordinater: $(geo-coord)
 	<br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td>      
       <td class="Info"></td>
      </tr>

Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/de/profil.xml	Mon Feb 11 07:39:01 2008
@@ -60,7 +60,7 @@
      </tr>
      <tr>
       <td class="Label">Quadratmeter</td>
-      <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />UTM-Koordinate: N$(sqm-x) E$(sqm-y)
+      <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />Koordinate: $(geo-coord)
       <br /><a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td>
       <td class="Info"></td>
      </tr>

Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/en/profil.xml	Mon Feb 11 07:39:01 2008
@@ -60,7 +60,7 @@
      </tr>
      <tr>
       <td class="Label">square metres</td>
-      <td class="Input">a total of $(numsqm) m? has been bought<br />UTM-coordinate: N$(sqm-x) E$(sqm-y)
+      <td class="Input">a total of $(numsqm) m? has been bought<br />coordinate: $(geo-coord)
       <br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td>
       <td class="Info"></td>
      </tr>

Modified: branches/bos/projects/bos/web/tags.lisp
==============================================================================
--- branches/bos/projects/bos/web/tags.lisp	(original)
+++ branches/bos/projects/bos/web/tags.lisp	Mon Feb 11 07:39:01 2008
@@ -170,8 +170,9 @@
     (setf (get-template-var :name) (user-full-name sponsor))
     (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) 
     (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) 
-    (setf (get-template-var :geo-coord) (multiple-value-bind (left top)
+    (setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore)
                                             (contract-bounding-box contract)
+                                          (declare (ignore ignore))
                                           (apply #'geometry:format-lon-lat nil
                                                  (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
                                                                              (- +nw-utm-y+ top) +utm-zone+ t))))


From hhubner at common-lisp.net  Mon Feb 11 13:13:30 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 08:13:30 -0500 (EST)
Subject: [bknr-cvs] r2466 -
	branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat
Message-ID: <20080211131330.9F4875E006@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 08:13:30 2008
New Revision: 2466

Modified:
   branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp
Log:
remove :uffi package alias (not a good idea)


Modified: branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp	(original)
+++ branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi-compat.lisp	Mon Feb 11 08:13:30 2008
@@ -29,7 +29,6 @@
 ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
 
 (defpackage #:cffi-uffi-compat
-  (:nicknames #:uffi) ;; is this a good idea?
   (:use #:cl)
   (:export
 


From ksprotte at common-lisp.net  Mon Feb 11 13:20:25 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 08:20:25 -0500 (EST)
Subject: [bknr-cvs] r2467 -
	branches/trunk-reorg/thirdparty/usocket-0.3.5/test
Message-ID: <20080211132025.B5C50601C2@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 08:20:23 2008
New Revision: 2467

Removed:
   branches/trunk-reorg/thirdparty/usocket-0.3.5/test/usocket.asd
Log:
removed duplicate usocket.asd in usocket-0.3.5/test/


From ksprotte at common-lisp.net  Mon Feb 11 13:21:38 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 08:21:38 -0500 (EST)
Subject: [bknr-cvs] r2468 - branches/trunk-reorg/thirdparty/cl-pdf
Message-ID: <20080211132138.B4A972B0DD@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 08:21:38 2008
New Revision: 2468

Removed:
   branches/trunk-reorg/thirdparty/cl-pdf/
Log:
rm cl-pdf from thirdparty


From ksprotte at common-lisp.net  Mon Feb 11 13:38:50 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 08:38:50 -0500 (EST)
Subject: [bknr-cvs] r2469 - in branches/trunk-reorg/thirdparty/arnesi: .
	docs src src/call-cc t
Message-ID: <20080211133850.8F4EB5B05D@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 08:38:43 2008
New Revision: 2469

Added:
   branches/trunk-reorg/thirdparty/arnesi/
   branches/trunk-reorg/thirdparty/arnesi/COPYING
   branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
   branches/trunk-reorg/thirdparty/arnesi/docs/
   branches/trunk-reorg/thirdparty/arnesi/docs/Makefile
   branches/trunk-reorg/thirdparty/arnesi/docs/print.css
   branches/trunk-reorg/thirdparty/arnesi/docs/style.css
   branches/trunk-reorg/thirdparty/arnesi/src/
   branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/http.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/io.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/list.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/string.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/time.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/
   branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/http.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/list.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/log.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/string.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp
   branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp
Log:
added arnesi to thirdparty

Added: branches/trunk-reorg/thirdparty/arnesi/COPYING
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/COPYING	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,30 @@
+Copyright (c) 2002-2006, Edward Marco Baringer
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+  
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+    
+- Neither the name of Edward Marco Baringer, nor BESE, nor the names
+of its contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

Added: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,131 @@
+;;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :it.bese.arnesi.system)
+    (defpackage :it.bese.arnesi.system
+      (:documentation "ASDF System package for ARNESI.")
+      (:use :common-lisp :asdf))))
+
+(in-package :it.bese.arnesi.system)
+
+(defsystem :arnesi
+  :components ((:static-file "arnesi.asd")
+               (:module :src
+                :components ((:file "accumulation" :depends-on ("packages" "one-liners"))
+                             (:file "asdf" :depends-on ("packages" "io"))
+                             (:file "csv" :depends-on ("packages" "string"))
+                             (:file "compat" :depends-on ("packages"))
+                             (:module :call-cc
+                              :components ((:file "interpreter")
+                                           (:file "handlers")
+                                           (:file "apply")
+                                           (:file "generic-functions")
+                                           (:file "common-lisp-cc"))
+                              :serial t
+                              :depends-on ("packages" "walk" "flow-control" "lambda-list" "list" "string" "defclass-struct"))
+			     (:file "debug" :depends-on ("accumulation"))
+                             (:file "decimal-arithmetic" :depends-on ("packages"))
+                             (:file "defclass-struct" :depends-on ("packages" "list"))
+                             (:file "flow-control" :depends-on ("packages" "one-liners"))
+                             (:file "hash" :depends-on ("packages" "list" "one-liners" "string"))
+                             (:file "http" :depends-on ("packages" "vector" "string"))
+                             (:file "io" :depends-on ("packages" "flow-control" "string"))
+                             (:file "lambda" :depends-on ("packages"))
+			     (:file "lambda-list" :depends-on ("packages" "walk"))
+			     (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk"))
+                             (:file "lexenv" :depends-on ("packages" "one-liners"))
+                             (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control"))
+                             (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
+                             (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners"))
+                             (:file "mop" :depends-on ("packages" "mopp"))
+			     (:file "mopp" :depends-on ("packages" "list" "flow-control"))
+                             (:file "numbers" :depends-on ("packages"))
+                             (:file "one-liners" :depends-on ("packages"))
+                             (:file "packages")
+			     (:file "pf-reader" :depends-on ("packages"))
+			     (:file "posixenv" :depends-on ("packages"))
+                             (:file "queue" :depends-on ("packages"))
+                             (:file "sequence" :depends-on ("packages"))
+                             (:file "bracket-reader" :depends-on ("list"))
+                             (:file "sharpl-reader" :depends-on ("packages" "flow-control" "mopp"))
+                             (:file "specials" :depends-on ("packages" "hash"))
+                             (:file "string" :depends-on ("packages" "list"))
+                             (:file "time" :depends-on ("packages"))
+			     (:file "unwalk" :depends-on ("packages" "walk"))
+                             (:file "vector" :depends-on ("packages" "flow-control"))
+                             (:file "walk" :depends-on ("packages" "list" "mopp" "lexenv" "one-liners")))))
+  :properties ((:features "v1.4.0" "v1.4.1" "v1.4.2" "cc-interpreter"
+                          "join-strings-return-value" "getenv"))
+  :depends-on (:swank))
+
+(defsystem :arnesi.test
+  :components ((:module :t
+		:components ((:file "accumulation" :depends-on ("suite"))
+                             (:file "call-cc" :depends-on ("suite"))
+                             (:file "http" :depends-on ("suite"))
+                             (:file "log" :depends-on ("suite"))
+                             (:file "matcher" :depends-on ("suite"))
+                             (:file "numbers" :depends-on ("suite"))
+                             (:file "queue" :depends-on ("suite"))
+                             (:file "read-macros" :depends-on ("suite"))
+                             (:file "string"  :depends-on ("suite"))
+                             (:file "sequence" :depends-on ("suite"))
+			     (:file "sharpl" :depends-on ("suite"))
+                             (:file "flow-control" :depends-on ("suite"))
+			     (:file "walk" :depends-on ("suite"))
+			     (:file "csv" :depends-on ("suite"))
+                             (:file "suite"))))
+  :depends-on (:arnesi :FiveAM)
+  :in-order-to ((compile-op (load-op :arnesi))))
+
+(defsystem :arnesi.cl-ppcre-extras
+  :components ((:module :src
+                :components ((:file "cl-ppcre-extras"))))
+  :depends-on (:cl-ppcre :arnesi))
+
+(defmethod perform ((op asdf:test-op) (system (eql (find-system :arnesi))))
+  (asdf:oos 'asdf:load-op :arnesi.test)
+  (funcall (intern (string :run!) (string :it.bese.FiveAM))
+           :it.bese.arnesi))
+
+(defmethod operation-done-p ((op test-op) (system (eql (find-system :arnesi))))
+  nil)
+
+;;;; * Introduction
+
+;;;; A collection of various common lisp utilites.
+
+;;;;@include "src/packages.lisp"
+
+
+;; Copyright (c) 2002-2006 Edward Marco Baringer
+;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, Luca Capello, nor
+;;    BESE, nor the names of its contributors may be used to endorse
+;;    or promote products derived from this software without specific
+;;    prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/docs/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/Makefile	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,30 @@
+# Change this to whatever lisp you'r using
+LISP=sbcl
+EVAL=--eval
+QUIT=(sb-ext:quit)
+SYSTEM=ARNESI
+
+docs: pdf html
+
+html:
+	mkdir -p html/
+	${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \
+	        ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \
+		${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \
+                                   :generator (make-instance 'qbook:html-generator \
+                                                             :output-directory \"./html/\" \
+                                                             :title \"${SYSTEM}\"))" \
+		${EVAL} "${QUIT}"
+
+pdf:
+	mkdir -p pdf/
+	${LISP} ${EVAL} "(asdf:oos 'asdf:load-op :qbook)" \
+                ${EVAL} "(asdf:oos 'asdf:load-op :${SYSTEM})" \
+		${EVAL} "(asdf:oos 'qbook:publish-op :${SYSTEM} \
+                                   :generator (make-instance 'qbook:latex-generator \
+                                                             :output-file \"./pdf/${SYSTEM}.tex\" \
+                                                             :title \"${SYSTEM}\"))" \
+		${EVAL} "${QUIT}"
+	(cd pdf && pdflatex ${SYSTEM}.tex)
+	(cd pdf && pdflatex ${SYSTEM}.tex)
+	rm pdf/${SYSTEM}.aux pdf/${SYSTEM}.log pdf/${SYSTEM}.toc pdf/${SYSTEM}.tex

Added: branches/trunk-reorg/thirdparty/arnesi/docs/print.css
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/print.css	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,94 @@
+body {
+  background-color: #FFFFFF;
+  padding: 0px; margin: 0px;
+}
+
+.qbook { 
+  width: 600px; 
+  background-color: #FFFFFF; 
+  padding: 0em;
+  margin: 0px; 
+}
+
+h1, h2, h3, h4, h5, h6 {
+  font-family: verdana; 
+}
+
+h1 { 
+  text-align: center; 
+  padding: 0px;
+  margin: 0px;
+}
+
+h2 { 
+  text-align: center;
+  border-top: 1px solid #000000; 
+  border-bottom: 1px solid #000000; 
+}
+
+h3, h4, h5, h6 { 
+  border-bottom: 1px solid #000000; 
+  padding-left: 1em; 
+}
+
+h3 { border-top: 1px solid #000000; }
+
+p { padding-left: 1em; }
+
+pre.code {
+  border: solid 1px #FFFFFF;
+  padding: 2px;
+  overflow: visible; 
+}
+
+pre .first-line-more-link { display: none; }
+
+pre.code * .paren  { color: #666666; } 
+
+pre.code a:active  { color: #000000; }
+pre.code a:link    { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+pre.code .body, pre.code * .body { display: inline; }
+
+div.contents { 
+  font-family: verdana; 
+  border-bottom: 1em solid #333333;
+  margin-left: -0.5em;
+}
+
+div.contents a:active  { color: #000000; }
+div.contents a:link    { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active  { color: #333333; }
+div.contents div.contents-heading-1 a:link    { color: #333333; }
+div.contents div.contents-heading-1 a:visited { color: #333333; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active  { color: #333333; }
+div.contents div.contents-heading-2 a:link    { color: #333333; }
+div.contents div.contents-heading-2 a:visited { color: #333333; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active  { color: #333333; }
+div.contents div.contents-heading-3 a:link    { color: #333333; }
+div.contents div.contents-heading-3 a:visited { color: #333333; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active  { color: #333333; }
+div.contents div.contents-heading-4 a:link    { color: #333333; }
+div.contents div.contents-heading-4 a:visited { color: #333333; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active  { color: #333333; }
+div.contents div.contents-heading-5 a:link    { color: #333333; }
+div.contents div.contents-heading-5 a:visited { color: #333333; }
+
+.footer { float: bottom-right; color: #000000; font-family: arial; font-size: small; }
+.footer a:active { color: #000000; }
+.footer a:link { color: #000000; }
+.footer a:visited { color: #000000; }

Added: branches/trunk-reorg/thirdparty/arnesi/docs/style.css
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/docs/style.css	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,107 @@
+body {
+  background-color: #FFFFFF;
+  padding: 0px; 
+  margin: 0px;
+}
+
+.qbook { 
+  margin: auto;
+  background-color: #FFFFFF; 
+  width: 40em;
+}
+
+h1, h2, h3, h4, h5, h6 {
+  font-family: verdana;
+}
+
+h1 { 
+  text-align: center; 
+  color: #000000; 
+  padding: 0px;
+  margin: 0px;
+}
+
+h2 { 
+  text-align: center;
+  border-top: 1px solid #000000; 
+  border-bottom: 1px solid #000000; 
+  margin-top: 2em;
+}
+
+h3, h4, h5, h6 {
+  padding-left: 1em;
+  margin-top: 2em;
+}
+
+h3 { 
+  border-top: 1px solid #000000; 
+  border-bottom: 1px solid #000000; 
+}
+
+h4 { 
+  border-bottom: 1px solid #000000; 
+}
+
+h5 { 
+  border-bottom: 1px solid #000000; 
+}
+
+h6 { 
+  border-bottom: 1px solid #000000; 
+}
+
+pre.code {
+  background-color: #eeeeee;
+  border: solid 1px #d0d0d0;
+  overflow: auto;
+}
+
+pre.code * .paren { color: #666666; } 
+
+pre.code a:active  { color: #000000; }
+pre.code a:link    { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+pre.code .body, pre.code * .body { display: none; }
+
+div.contents { 
+  font-family: verdana; 
+}
+
+div.contents a:active  { color: #000000; }
+div.contents a:link    { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active  { color: #333333; }
+div.contents div.contents-heading-1 a:link    { color: #333333; }
+div.contents div.contents-heading-1 a:visited { color: #333333; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active  { color: #333333; }
+div.contents div.contents-heading-2 a:link    { color: #333333; }
+div.contents div.contents-heading-2 a:visited { color: #333333; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active  { color: #333333; }
+div.contents div.contents-heading-3 a:link    { color: #333333; }
+div.contents div.contents-heading-3 a:visited { color: #333333; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active  { color: #333333; }
+div.contents div.contents-heading-4 a:link    { color: #333333; }
+div.contents div.contents-heading-4 a:visited { color: #333333; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active  { color: #333333; }
+div.contents div.contents-heading-5 a:link    { color: #333333; }
+div.contents div.contents-heading-5 a:visited { color: #333333; }
+
+.footer { color: #000000; font-family: arial; font-size: small; }
+.footer a:active { color: #000000; }
+.footer a:link { color: #000000; }
+.footer a:visited { color: #000000; }
+
+.nav-links { font-size: x-small; float: right; margin-top: -2em; }
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/accumulation.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,150 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Reducing and Collecting
+
+;;;; ** Reducing
+
+;;;; reducing is the act of taking values, two at a time, and
+;;;; combining them, with the aid of a reducing function, into a
+;;;; single final value.
+
+(defun make-reducer (function &optional (initial-value nil initial-value-p))
+  "Create a function which, starting with INITIAL-VALUE, reduces
+any other values into a single final value.
+
+FUNCTION will be called with two values: the current value and
+the new value, in that order. FUNCTION should return exactly one
+value.
+
+The reducing function can be called with n arguments which will
+be applied to FUNCTION one after the other (left to right) and
+will return the new value.
+
+If the reducing function is called with no arguments it will
+return the current value.
+
+Example:
+
+ (setf r (make-reducer #'+ 5))
+ (funcall r 0) => 5
+ (funcall r 1 2) => 8
+ (funcall r) => 8"
+  (let ((value initial-value))
+    (lambda (&rest next)
+      (when next
+        ;; supplied a value, reduce
+        (if initial-value-p
+            ;; have a value to test against
+            (dolist (n next)
+              (setf value (funcall function value n)))
+            ;; nothing to test againts yet
+            (setf initial-value-p t
+                  value next)))
+      ;; didn't supply a value, return the current value
+      value)))
+
+(defmacro with-reducer ((name function &optional (initial-value nil))
+                        &body body)
+  "Locally bind NAME to a reducing function. The arguments
+FUNCTION and INITIAL-VALUE are passed directly to MAKE-REDUCER."
+  (with-unique-names (reducer)
+    `(let ((,reducer (make-reducer ,function ,@(list initial-value))))
+       (flet ((,name (&rest items)
+                (if items
+                    (dolist (i items)
+                      (funcall ,reducer i))
+                    (funcall ,reducer))))
+         , at body))))
+
+;;;; ** Collecting
+;;;;
+;;;; Building up a list from multiple values.
+
+(defun make-collector (&optional initial-value)
+  "Create a collector function.
+
+A Collector function will collect, into a list, all the values
+passed to it in the order in which they were passed. If the
+callector function is called without arguments it returns the
+current list of values."
+  (let ((value initial-value)
+        (cdr (last initial-value)))
+    (lambda (&rest items)
+      (if items
+          (progn
+            (if value
+                (if cdr
+                    (setf (cdr cdr) items
+                          cdr (last items))
+                    (setf cdr (last items)))
+                (setf value items
+                      cdr (last items)))
+            items)
+          value))))
+
+(defun make-pusher (&optional initial-value)
+  "Create a function which collects values as by PUSH."
+  (let ((value initial-value))
+    (lambda (&rest items)
+      (if items
+          (progn
+            (dolist (i items)
+              (push i value))
+            items)
+          value))))
+
+(defmacro with-collector ((name &optional initial-value from-end) &body body)
+  "Bind NAME to a collector function and execute BODY. If
+  FROM-END is true the collector will actually be a pusher, (see
+  MAKE-PUSHER), otherwise NAME will be bound to a collector,
+  (see MAKE-COLLECTOR)."
+  (with-unique-names (collector)
+    `(let ((,collector ,(if from-end
+                            `(make-pusher ,initial-value)
+                            `(make-collector ,initial-value))))
+       (flet ((,name (&rest items)
+                (if items
+                    (dolist (i items)
+                      (funcall ,collector i))
+                    (funcall ,collector))))
+         , at body))))
+
+(defmacro with-collectors (names &body body)
+  "Bind multiple collectors. Each element of NAMES should be a
+  list as per WITH-COLLECTOR's first orgument."
+  (if names
+      `(with-collector ,(ensure-list (car names))
+         (with-collectors ,(cdr names) , at body))
+      `(progn , at body)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/asdf.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,100 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * ASDF extras
+
+;;;; ** CLEAN-OP - An intelligent make clean for ASDF
+
+(defclass clean-op (asdf:operation)
+  ((for-op :accessor for-op :initarg :for-op :initform 'asdf:compile-op))
+  (:documentation "Removes any files generated by an asdf component."))
+
+(defmethod asdf:perform ((op clean-op) (c asdf:component))
+  "Delete all the output files generated by the component C."
+  (dolist (f (asdf:output-files (make-instance (for-op op)) c))
+    (when (probe-file f)
+      (delete-file f))))
+
+(defmethod asdf:operation-done-p ((op clean-op) (c asdf:component))
+  "Returns T when the output-files of (for-op OP) C don't exist."
+  (dolist (f (asdf:output-files (make-instance (for-op op)) c))
+    (when (probe-file f) (return-from asdf:operation-done-p nil)))
+  t)
+
+;;;; ** Creating a single .fas or .fasl file
+
+;;;; Instead of creating images another way to distribute systems is
+;;;; to create a single compiled file containing all the code. This is
+;;;; only possible on some lisps, sbcl and clisp are the only ones
+;;;; supported for now.
+
+;;;; NB: Unlike the CLEAN-OP this is experimental (its now to have
+;;;; problems on multiple systems with non-trivial dependencies).
+
+(defun make-single-fasl (system-name
+                         &key (op (make-instance 'asdf:load-op))
+                              output-file)
+  (let* ((system (asdf:find-system system-name))
+         (steps (asdf::traverse op system))
+         (output-file (or output-file
+                          (compile-file-pathname
+                           (make-pathname
+                            :name (asdf:component-name system)
+                            :defaults (asdf:component-pathname system)))))
+         (*buffer* (make-array 4096 :element-type '(unsigned-byte 8)
+                                    :adjustable t)))
+    (declare (special *buffer*))
+    (with-output-to-file (*fasl* output-file
+                          :if-exists :error
+                          :element-type '(unsigned-byte 8))
+      (declare (special *fasl*))
+      (dolist (s steps)
+        (process-step (car s) (cdr s) output-file)))))
+
+(defgeneric process-step (op comp output-file))
+
+(defmethod process-step
+    ((op asdf:load-op) (file asdf:cl-source-file) output-file)
+  (declare (ignore output-file)
+           (special *buffer* *fasl*))
+  (dolist (fasl (asdf:output-files (make-instance 'asdf:compile-op) file))
+    (with-input-from-file (input (truename fasl)
+                           :element-type '(unsigned-byte 8))
+      (setf *buffer* (adjust-array *buffer* (file-length input)))
+      (read-sequence *buffer* input)
+      (write-sequence *buffer* *fasl*))))
+
+(defmethod process-step ((op asdf:operation) (comp asdf:component) output-file)
+  (declare (ignore output-file))
+  (format t "Ignoring step ~S on ~S.~%" op comp))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/bracket-reader.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,88 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * {} syntax for local readtable modifications
+
+(defun |{-reader| (stream char)
+  (declare (ignore char))
+  "A utility read macro for modifying the read table.
+
+The syntax is:
+
+  {SPECIFIER ...}
+
+SPECIFIER is either a symbol naming a function (available at read
+time) or a list (SPECIFIER &rest ARGUMENTS). SPECIFIER is applied
+to ARGUMENTS to produce a function, this is then called and
+passed another function which reads until the #\}
+character. During the executen of the function *readtable* is
+bound to a copy of the current read table.
+
+See WITH-PACKAGE for an example of a specifier function."
+  (let ((*readtable* (copy-readtable *readtable* nil)))
+    (destructuring-bind (specifier &rest arguments)
+        (ensure-list (read stream t nil t))
+      (funcall (apply specifier arguments)
+               (lambda ()
+                 (read-delimited-list #\} stream t))))))
+
+(defmacro enable-bracket-syntax ()
+  "Enable bracket reader for the rest of the file (being loaded or compiled).
+Be careful when using in different situations, because it modifies *readtable*."
+  ;; The standard sais that *readtable* is restored after loading/compiling a file,
+  ;; so we make a copy and alter that. The effect is that it will be enabled
+  ;; for the rest of the file being processed.
+  `(eval-when (:compile-toplevel :execute)
+    (setf *readtable* (copy-readtable *readtable*))
+    (set-macro-character #\{ #'|{-reader| t *readtable*)
+    (set-syntax-from-char #\} #\) *readtable*)))
+
+(defmacro enable-bracket-reader ()
+  "TODO Obsolete, use the enable-bracket-syntax macro."
+  ;; (warn "Use the enable-bracket-syntax macro instead of enable-bracket-reader")
+  `(enable-bracket-syntax))
+
+(defun with-package (package-name)
+  "When used as a specifier for the #\{ reader locally rebinds,
+at read time, the current package to PACKAGE-NAME.
+
+For example, this:
+
+  {(with-package :cl-user) t}
+
+Will always read cl:t, no matter what the current package
+actually is."
+  (lambda (reader)
+    (let ((*package* (find-package package-name)))
+      `(progn ,@(funcall reader)))))
+
+;; Copyright (c) 2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/apply.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,354 @@
+;; -*- lisp -*-
+
+(in-package :arnesi)
+
+;;;; FUNCTION
+
+(defmethod evaluate/cc ((func free-function-object-form) lex-env dyn-env k)
+  (declare (ignore lex-env dyn-env))
+  (multiple-value-bind (definition cc-boundp)
+      (fdefinition/cc (name func))
+    (if cc-boundp
+        (kontinue k definition)
+        (if (fboundp (name func))
+            (kontinue k (fdefinition (name func)))
+            (error "Unbound function ~S." (name func))))))
+
+(defmethod evaluate/cc ((func local-function-object-form) lex-env dyn-env k)
+  (declare (ignore dyn-env))
+  (kontinue k (lookup lex-env :flet (name func) :error-p t)))
+
+(defclass closure/cc ()
+  ((code :accessor code :initarg :code)
+   (env :accessor env :initarg :env))
+  #+sbcl (:metaclass mopp:funcallable-standard-class))
+
+#+sbcl
+(defmethod initialize-instance :after ((fun closure/cc) &rest initargs)
+  (declare (ignore initargs))
+  (mopp:set-funcallable-instance-function 
+   fun 
+   #'(lambda (&rest args)
+       (drive-interpreter/cc 
+	(apply-lambda/cc fun
+			 args
+                         '()
+			 *toplevel-k*)))))
+
+;;;; LAMBDA
+
+(defmethod evaluate/cc ((lambda lambda-function-form) lex-env dyn-env k)
+  (declare (ignore dyn-env))
+  (kontinue k (make-instance 'closure/cc :code lambda :env lex-env)))
+
+;;;; APPLY and FUNCALL
+
+(defk k-for-call/cc (k)
+    (value)
+  (if *call/cc-returns*
+      (kontinue k value)
+      (throw 'done value)))
+
+;;;; apply'ing a free (global) function
+
+(defmethod evaluate/cc ((func free-application-form) lex-env dyn-env k)
+  (cond 
+    ((eql 'call/cc (operator func))
+     (evaluate/cc (make-instance 'free-application-form
+                                  :operator 'funcall
+                                  :arguments (list (first (arguments func))
+                                                   (make-instance 'constant-form :value k :source k))
+                                  :source (source func))
+                  lex-env dyn-env `(k-for-call/cc ,k)))
+    
+    ((eql 'kall (operator func))
+     (evaluate-arguments-then-apply
+      (lambda (arguments)
+        (trace-statement "KALL'ing ~S on ~S" (first arguments) (rest arguments))
+        (apply #'kontinue (first arguments) (cdr arguments)))
+      (arguments func) '()
+      lex-env dyn-env))
+
+    ((and (eql 'call-next-method (operator func))
+	  (second (multiple-value-list (lookup lex-env :next-method t))))
+     (aif (lookup lex-env :next-method t)
+	  (evaluate-arguments-then-apply
+	   (lambda (arguments)
+	     (apply-lambda/cc it arguments dyn-env k))
+	   (arguments func) '() lex-env dyn-env)
+	  (error "no next method")))
+
+    ((and (eql 'next-method-p (operator func))
+	  (second (multiple-value-list (lookup lex-env :next-method t))))
+     (kontinue k (lookup lex-env :next-method t)))
+    
+    ((eql 'funcall (operator func))
+     (evaluate-funcall/cc (arguments func) lex-env dyn-env k))
+    
+    ((eql 'apply (operator func))
+     (evaluate-apply/cc (arguments func) '() lex-env dyn-env k))
+    
+    ((and (symbolp (operator func))
+          (eql 'defun/cc (nth-value 1 (fdefinition/cc (operator func)))))
+     (evaluate-arguments-then-apply
+      (lambda (arguments)
+        (trace-statement "Calling cc function ~S with arguments ~S" (operator func) arguments)
+        (apply-lambda/cc (fdefinition/cc (operator func)) arguments dyn-env k))
+      (arguments func) '()
+      lex-env dyn-env))
+    
+    ((and (symbolp (operator func))
+          (eql 'defmethod/cc (nth-value 1 (fdefinition/cc (operator func)))))
+     (evaluate-arguments-then-apply
+      (lambda (arguments)
+        (trace-statement "Calling cc method ~S with arguments ~S" (operator func) arguments)
+        (apply-lambda/cc (apply (operator func) arguments) arguments dyn-env k))
+      (arguments func) '()
+      lex-env dyn-env))
+       
+    (t
+     (evaluate-arguments-then-apply
+      (lambda (arguments)
+        (multiple-value-bind (vars vals)
+            (export-specials dyn-env)
+          (progv vars vals
+            (trace-statement "Calling function ~S with arguments ~S"
+                             (operator func) arguments)
+            (apply #'kontinue k (multiple-value-list
+                                    (apply (fdefinition (operator func)) arguments))))))
+      (arguments func) '()
+      lex-env dyn-env))))
+
+;; returns a list of variables and values from the dynamic environment that should be exported
+;; these variables will be visible in normal lisp code that is called from cc code
+(defun export-specials (dyn-env)
+  ;; TODO: here we could check each special whether it has to be exported or not
+  ;;       this could be based on something like (declare (export var)) in the cc code
+  (let ((dyn-env (remove-duplicates dyn-env
+                                    :test (lambda (x y) (eq (second x) (second y)))
+                                    :from-end t)))
+    (values (mapcar 'second dyn-env)
+            (mapcar 'cddr dyn-env))))
+
+;;;; apply'ing a local function
+
+(defmethod evaluate/cc ((func local-application-form) lex-env dyn-env k)
+  (evaluate-arguments-then-apply
+   (lambda (arguments)
+     (apply-lambda/cc (lookup lex-env :flet (operator func) :error-p t) arguments dyn-env k))
+   (arguments func) '()
+   lex-env dyn-env))
+
+;;;; apply'ing a lambda
+
+(defmethod evaluate/cc ((lambda lambda-application-form) lex-env dyn-env k)
+  (evaluate-funcall/cc (cons (operator lambda) (arguments lambda)) lex-env dyn-env k))
+
+;;;; Utility methods which do the actual argument evaluation, parsing
+;;;; and control transfer.
+
+(defun evaluate-funcall/cc (arguments lex-env dyn-env k)
+  (evaluate-apply/cc (append (butlast arguments)
+                             (list (make-instance 'free-application-form
+                                                  :operator 'list
+                                                  :source `(list ,(source (car (last arguments))))
+                                                  :arguments (last arguments))))
+                     '()
+                     lex-env dyn-env k))
+
+(defk k-for-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k)
+    (value)
+  (evaluate-apply/cc (cdr remaining-arguments) (cons value evaluated-arguments)
+                     lex-env dyn-env k))
+
+(defun evaluate-apply/cc (remaining-arguments evaluated-arguments lex-env dyn-env k)
+  (if remaining-arguments
+      (evaluate/cc (car remaining-arguments) lex-env dyn-env
+                   `(k-for-apply/cc ,remaining-arguments ,evaluated-arguments ,lex-env ,dyn-env ,k))
+      (let ((arg-list (apply #'list* (reverse evaluated-arguments))))
+        (apply-lambda/cc (first arg-list) (rest arg-list) dyn-env k))))
+
+;;;; Finally this is the function which, given a closure/cc object and
+;;;; a list of (evaluated) arguments parses them, setup the
+;;;; environment and transfers control.
+
+(defmethod apply-lambda/cc ((operator closure/cc) effective-arguments dyn-env k)
+  (trace-statement "Applying cc closure ~S to ~S" (source (code operator)) effective-arguments)
+  (let ((lex-env (env operator))
+        (remaining-arguments effective-arguments)
+        (remaining-parameters (arguments (code operator))))
+    ;; in this code ARGUMENT refers to the values passed to the
+    ;; function. PARAMETER refers to the lambda of the closure
+    ;; object. we walk down the parameters and put the arguments in
+    ;; the environment under the proper names.
+    
+    ;; first the required arguments
+    (loop
+       for parameter = (first remaining-parameters)
+       while remaining-parameters
+       do (typecase parameter
+            (required-function-argument-form
+             (if remaining-arguments
+                 (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments)))
+                 (error "Missing required arguments, expected ~S, got ~S."
+                        (arguments (code operator)) effective-arguments))
+             (pop remaining-parameters))
+            (t (return))))
+
+    ;; handle special variables
+    (setf dyn-env (import-specials (code operator) dyn-env))
+
+    ;; now we start the chain optional->keyword->evaluate-body. We do
+    ;; this because optional and keyword parameters may have default
+    ;; values which may use call/cc.
+    (apply-lambda/cc/optional operator
+                              remaining-parameters remaining-arguments
+                              lex-env dyn-env k)))
+
+(defun apply-lambda/cc/optional (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+  (flet ((done (remaining-parameters)
+           (return-from apply-lambda/cc/optional
+             (apply-lambda/cc/keyword
+              operator remaining-parameters remaining-arguments lex-env dyn-env k))))
+    (loop
+       for head on remaining-parameters
+       for parameter = (first head) 
+       do 
+       (etypecase parameter
+         (rest-function-argument-form
+          (setf lex-env (register lex-env :let (name parameter) remaining-arguments)))
+         (optional-function-argument-form
+          (if remaining-arguments
+              (progn
+                (setf lex-env (register lex-env :let (name parameter) (pop remaining-arguments)))
+                (when (supplied-p-parameter parameter)
+                  (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t))))
+              (return-from apply-lambda/cc/optional
+                ;; we need to evaluate a default-value, since this may
+                ;; contain call/cc we need to setup the continuation
+                ;; and let things go from there (hence the return-from)
+                (evaluate/cc (default-value parameter) lex-env dyn-env
+                             `(k-for-apply/cc/optional-argument-default-value
+                               ;; remaining-arguments is, by
+                               ;; definition, NIL so we needn't pass
+                               ;; it here.
+                               ,operator ,head ,lex-env ,dyn-env ,k)))))
+         ((or keyword-function-argument-form allow-other-keys-function-argument-form)
+          ;; done with the optional args
+          (done head)))
+       finally (done head))))
+
+(defk k-for-apply/cc/optional-argument-default-value
+    (operator remaining-parameters lex-env dyn-env k)
+    (value)
+  (apply-lambda/cc/optional
+   operator (cdr remaining-parameters)
+   ;; nb: if we're evaluating the default value of an optional
+   ;; arguments then we can't have anything left in the arguments
+   ;; list.
+   nil
+   (register lex-env :let (name (first remaining-parameters)) value)
+   dyn-env
+   k))
+
+(defun apply-lambda/cc/keyword (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+  ;; now any keyword parameters
+  (loop
+     for head on remaining-parameters
+     for parameter = (first head) 
+     do (typecase parameter
+          (keyword-function-argument-form
+           (assert (evenp (length remaining-arguments))
+                   (remaining-arguments)
+                   "Odd number of arguments in ~S being applied to ~S."
+                   remaining-arguments
+                   (source (code operator)))
+           (let ((value (getf remaining-arguments
+                              (effective-keyword-name parameter)
+                              parameter)))
+             (if (eql parameter value)
+                 ;; no such keyword. need to evaluate the default value
+                 (return-from apply-lambda/cc/keyword
+                   (evaluate/cc (default-value parameter) lex-env dyn-env
+                                `(k-for-apply-lambda/cc/keyword-default-value
+                                  ,operator ,head ,remaining-arguments
+                                  ,lex-env ,dyn-env ,k)))
+                 ;; keyword passed in explicitly.
+                 (progn
+                   (let ((value (getf remaining-arguments (effective-keyword-name parameter))))
+                     (remf remaining-arguments (effective-keyword-name parameter))
+                     (setf lex-env (register lex-env :let (name parameter) value))
+                   (when (supplied-p-parameter parameter)
+                     (setf lex-env (register lex-env :let (supplied-p-parameter parameter) t))))))))
+          (allow-other-keys-function-argument-form
+           (when (cdr remaining-parameters)
+             (error "Bad lambda list: ~S" (arguments (code operator))))
+           (return))
+          (t (unless (null remaining-parameters)
+               (error "Bad lambda list: ~S" (arguments (code operator)))))))
+  (evaluate-progn/cc (body (code operator)) lex-env dyn-env k))
+
+(defk k-for-apply-lambda/cc/keyword-default-value
+    (operator remaining-parameters remaining-arguments lex-env dyn-env k)
+    (value)
+  (apply-lambda/cc/keyword operator
+                           (cdr remaining-parameters) remaining-arguments
+                           (register lex-env :let (name (first remaining-parameters)) value)
+                           dyn-env
+                           k))
+
+(defmethod apply-lambda/cc ((operator function) effective-arguments dyn-env k)
+  "Method used when we're applying a regular, non cc, function object."
+  (declare (ignore dyn-env))
+  (trace-statement "Applying function ~S to ~S" operator effective-arguments)
+  (apply #'kontinue k (multiple-value-list (apply operator effective-arguments))))
+
+(defmethod apply-lambda/cc ((operator symbol) effective-arguments dyn-env k)
+  "Method used when we're applying a regular, non cc, function object."
+  (apply-lambda/cc (symbol-function operator) effective-arguments dyn-env k))
+
+;;;; Small helper function
+
+(defk k-for-evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env)
+    (value)
+  (evaluate-arguments-then-apply
+   handler
+   remaining-arguments (cons value evaluated-arguments)
+   lex-env dyn-env))
+
+(defun evaluate-arguments-then-apply (handler remaining-arguments evaluated-arguments lex-env dyn-env)
+  (if remaining-arguments
+      (evaluate/cc (car remaining-arguments) lex-env dyn-env
+                    `(k-for-evaluate-arguments-then-apply ,handler ,(cdr remaining-arguments)
+                                                          ,evaluated-arguments ,lex-env ,dyn-env))
+      (funcall handler (reverse evaluated-arguments))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/common-lisp-cc.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,456 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** CC Version of some common lisp functions.
+
+(defmacro redefun/cc (name args &body body)
+  `(progn
+     (setf (fdefinition/cc ',name)
+           (make-instance 'closure/cc
+                          :code (walk-form '(lambda ,args , at body) nil '())
+                          :env '()))
+     ',name))
+
+(defmacro apply-key (key element)
+  `(if ,key
+       (funcall ,key ,element)
+       ,element))
+
+(redefun/cc assoc (item alist &key key (test #'eql) test-not)
+  "Return the cons in ALIST whose car is equal (by TEST) to ITEM."
+  (when test-not
+    (setq test (complement test-not)))
+  (dolist (pair alist nil)
+    (when (and pair (funcall test item (apply-key key (car pair))))
+      (return pair))))
+
+(redefun/cc assoc-if (predicate alist &key key)
+  "Return the cons in ALIST whose car satisfies PREDICATE."
+  (dolist (pair alist nil)
+    (when (and pair (funcall predicate (apply-key key (car pair))))
+      (return pair))))
+
+(redefun/cc assoc-if-not (predicate alist &key key)
+  "Return the cons in ALIST whose car does not satisfy PREDICATE."
+  (assoc-if (complement predicate) alist :key key))
+
+(redefun/cc rassoc (item alist &key key (test #'eql) test-not)
+  "Return the cons in ALIST whose cdr is equal (by TEST) to ITEM."
+  (when test-not
+    (setq test (complement test-not)))
+  (dolist (pair alist nil)
+    (when (and pair (funcall test item (apply-key key (cdr pair))))
+      (return pair))))
+
+(redefun/cc rassoc-if (predicate alist &key key)
+  "Return the cons in ALIST whose cdr satisfies PREDICATE."
+  (dolist (pair alist nil)
+    (when (and pair (funcall predicate (apply-key key (cdr pair))))
+      (return pair))))
+
+(redefun/cc rassoc-if-not (predicate alist &key key)
+  "Return the cons in ALIST whose cdr does not satisfy PREDICATE."
+  (rassoc-if (complement predicate) alist :key key))
+
+(redefun/cc sublis (alist tree &key key (test #'eql) test-not)
+  "Substitute data of ALIST for subtrees matching keys of ALIST."
+  (when test-not
+    (setq test (complement test-not)))
+  (labels ((sub (subtree)
+		(let ((assoc (assoc (apply-key key subtree) alist :test test)))
+		  (cond
+		   (assoc (cdr assoc))
+		   ((atom subtree) subtree)
+		   (t (let ((car (sub (car subtree)))
+			    (cdr (sub (cdr subtree))))
+			(if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+			    subtree
+			  (cons car cdr))))))))
+    (sub tree)))
+
+(redefun/cc nsublis (alist tree &key key (test #'eql) test-not)
+  "Substitute data of ALIST for subtrees matching keys of ALIST destructively."
+  (when test-not
+    (setq test (complement test-not)))
+  (labels ((sub (subtree)
+		(let ((assoc (assoc (apply-key key subtree) alist :test test)))
+		  (cond
+		   (assoc (cdr assoc))
+		   ((atom subtree) subtree)
+		   (t
+		    (rplaca subtree (sub (car subtree)))
+		    (rplacd subtree (sub (cdr subtree)))
+		    subtree)))))
+    (sub tree)))
+
+(redefun/cc subst (new old tree &key key (test #'eql) test-not)
+  "Substitute NEW for subtrees matching OLD."
+  (when test-not
+    (setq test (complement test-not)))
+  (labels ((sub (subtree)
+		(cond
+		 ((funcall test old (apply-key key subtree)) new)
+		 ((atom subtree) subtree)
+		 (t (let ((car (sub (car subtree)))
+			  (cdr (sub (cdr subtree))))
+		      (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+			  subtree
+			(cons car cdr)))))))
+    (sub tree)))
+
+(redefun/cc nsubst (new old tree &key key (test #'eql) test-not)
+  "Substitute NEW for subtrees matching OLD destructively."
+  (when test-not
+    (setq test (complement test-not)))
+  (labels ((sub (subtree)
+		(cond
+		 ((funcall test old (apply-key key subtree)) new)
+		 ((atom subtree) subtree)
+		 (t (rplaca subtree (sub (car subtree)))
+		    (rplacd subtree (sub (cdr subtree)))
+		    subtree))))
+    (sub tree)))
+
+(redefun/cc subst-if (new predicate tree &key key)
+  "Substitute NEW for subtrees for which PREDICATE is true."
+  (labels ((sub (subtree)
+		(cond
+		 ((funcall predicate (apply-key key subtree)) new)
+		 ((atom subtree) subtree)
+		 (t (let ((car (sub (car subtree)))
+			  (cdr (sub (cdr subtree))))
+		      (if (and (eq car (car subtree)) (eq cdr (cdr subtree)))
+			  subtree
+			(cons car cdr)))))))
+    (sub tree)))
+
+(redefun/cc subst-if-not (new predicate tree &key key)
+  "Substitute NEW for subtrees for which PREDICATE is false."
+  (subst-if new (complement predicate) tree :key key))
+
+(redefun/cc nsubst-if (new predicate tree &key key)
+  "Substitute NEW for subtrees for which PREDICATE is true destructively."
+  (labels ((sub (subtree)
+		(cond
+		 ((funcall predicate (apply-key key subtree)) new)
+		 ((atom subtree) subtree)
+		 (t (rplaca subtree (sub (car subtree)))
+		    (rplacd subtree (sub (cdr subtree)))
+		    subtree))))
+    (sub tree)))
+
+(redefun/cc nsubst-if-not (new predicate tree &key key)
+  "Substitute NEW for subtrees for which PREDICATE is false destructively."
+  (nsubst-if new (complement predicate) tree :key key))
+
+(redefun/cc tree-equal (a b &key (test #'eql) test-not)
+  "Test whether two trees are of the same shape and have the same leaves."
+  (when test-not
+    (setq test (complement test-not)))
+  (labels ((teq (a b)
+		(if (atom a)
+		    (and (atom b) (funcall test a b))
+		  (and (consp b)
+		       (teq (car a) (car b))
+		       (teq (cdr a) (cdr b))))))
+    (teq a b)))
+
+(redefun/cc member (item list &key key (test #'eql) test-not)
+  "Return the tail of LIST beginning with an element equal to ITEM."
+  (when test-not
+    (setq test (complement test-not)))
+  (do ((here list (cdr here)))
+      ((or (null here) (funcall test item (apply-key key (car here)))) here)))
+
+(redefun/cc member-if (predicate list &key key)
+  "Return the tail of LIST beginning with an element satisfying PREDICATE."
+  (do ((here list (cdr here)))
+      ((or (endp here) (funcall predicate (apply-key key (car here)))) here)))
+
+(redefun/cc member-if-not (predicate list &key key)
+  "Return the tail of LIST beginning with an element not satisfying PREDICATE."
+  (member-if (complement predicate) list :key key))
+
+(redefun/cc adjoin (item list &key key (test #'eql) test-not)
+  "Add ITEM to LIST unless it is already a member."
+  (when test-not
+    (setq test (complement test-not)))
+  (if (member (apply-key key item) list :key key :test test)
+      list
+    (cons item list)))
+
+(redefun/cc intersection (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the intersection of LIST-1 and LIST-2."
+  (when test-not
+    (setq test (complement test-not)))
+  (let (result)
+    (dolist (element list-1)
+      (when (member (apply-key key element) list-2 :key key :test test)
+	(push element result)))
+    result))
+
+(redefun/cc nintersection (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the intersection of LIST-1 and LIST-2 destructively modifying LIST-1."
+  (when test-not
+    (setq test (complement test-not)))
+  (let* ((result (list nil))
+	 (splice result))
+    (do ((list list-1 (cdr list)))
+	((endp list) (rplacd splice nil) (cdr result))
+      (when (member (apply-key key (car list)) list-2 :key key :test test)
+	(setq splice (cdr (rplacd splice list)))))))
+
+(redefun/cc union (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the union of LIST-1 and LIST-2."
+  (when test-not
+    (setq test (complement test-not)))
+  (let ((result list-2))
+    (dolist (element list-1)
+      (unless (member (apply-key key element) list-2 :key key :test test)
+	(push element result)))
+    result))
+
+(redefun/cc nunion (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the union of LIST-1 and LIST-2 destructively modifying them."
+  (when test-not
+    (setq test (complement test-not)))
+  (do* ((result list-2)
+	(list-1 list-1)
+	tmp)
+      ((endp list-1) result)
+    (if (member (apply-key key (car list-1)) list-2 :key key :test test)
+	(setq list-1 (cdr list-1))
+      (setq tmp (cdr list-1)
+	    result (rplacd list-1 result)
+	    list-1 tmp))))
+
+(redefun/cc subsetp (list-1 list-2 &key key (test #'eql) test-not)
+  "Return T if every element in LIST-1 is also in LIST-2."
+  (when test-not
+    (setq test (complement test-not)))
+  (dolist (element list-1 t)
+    (unless (member (apply-key key element) list-2 :key key :test test)
+      (return nil))))
+
+(redefun/cc set-difference (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the elements of LIST-1 which are not in LIST-2."
+  (when test-not
+    (setq test (complement test-not)))
+  (let ((result nil))
+    (dolist (element list-1)
+      (unless (member (apply-key key element) list-2 :key key :test test)
+	(push element result)))
+    result))
+
+(redefun/cc nset-difference (list-1 list-2 &key key (test #'eql) test-not)
+  "Return the elements of LIST-1 which are not in LIST-2, modifying LIST-1."
+  (when test-not
+    (setq test (complement test-not)))
+  (do* ((result nil)
+	(list-1 list-1)
+	tmp)
+      ((endp list-1) result)
+    (if (member (apply-key key (car list-1)) list-2 :key key :test test)
+	(setq list-1 (cdr list-1))
+      (setq tmp (cdr list-1)
+	    result (rplacd list-1 result)
+	    list-1 tmp))))
+
+(redefun/cc set-exclusive-or (list-1 list-2 &key key (test #'eql) test-not)
+  "Return a list of elements that appear in exactly one of LIST-1 and LIST-2."
+  (when test-not
+    (setq test (complement test-not)))
+  (let ((result nil))
+    (dolist (element list-1)
+      (unless (member (apply-key key element) list-2 :key key :test test)
+	(push element result)))
+    (dolist (element list-2)
+      (unless (member (apply-key key element) list-1 :key key :test test)
+	(push element result)))
+    result))
+
+(redefun/cc nset-exclusive-or (list-1 list-2 &key key (test #'eql) test-not)
+  "The destructive version of set-exclusive-or."
+  (when test-not
+    (setq test (complement test-not)))
+  (do* ((head-1 (cons nil list-1))
+	(head-2 (cons nil list-2))
+	(p-1 head-1))
+      ((or (endp (cdr p-1)) (endp (cdr head-2)))
+       (progn (rplacd (last p-1) (cdr head-2))
+	      (cdr head-1)))
+    (do ((p-2 head-2 (cdr p-2)))
+	((endp (cdr p-2)) (setq p-1 (cdr p-1)))
+      (when (funcall test (apply-key key (cadr p-1)) (apply-key key (cadr p-2)))
+	(rplacd p-1 (cddr p-1))
+	(rplacd p-2 (cddr p-2))
+	(return)))))
+
+(redefun/cc mapc (function list &rest more-lists)
+  "Apply FUNCTION to successive elements of lists, return LIST."
+  (do* ((lists (cons list more-lists))
+	(args (make-list (length lists))))
+      ((do ((l lists (cdr l))
+	    (a args (cdr a)))
+	   ((or (null l) (endp (car l))) l)
+	 (rplaca a (caar l))
+	 (rplaca l (cdar l)))
+       list)
+    (apply function args)))
+
+(redefun/cc mapcar (function list &rest more-lists)
+  "Apply FUNCTION to successive elements of lists, return list of results."
+  (do* ((lists (cons list more-lists))
+	(len (length lists))
+	(args (make-list len) (make-list len))
+	(result (list nil))
+	(splice result))
+       ((do ((l lists (cdr l))
+	     (a args (cdr a)))
+	    ((or (null l) (endp (car l))) l)
+	  (rplaca a (caar l))
+	  (rplaca l (cdar l)))
+	(cdr result))
+    (setq splice (cdr (rplacd splice (list (apply function args)))))))
+
+(redefun/cc mapcan (function list &rest more-lists)
+  "Apply FUNCTION to successive elements of lists, return nconc of results."
+  (apply #'nconc (apply #'mapcar function list more-lists)))
+
+(redefun/cc mapl (function list &rest more-lists)
+  "Apply FUNCTION to successive sublists of list, return LIST."
+  (do* ((lists (cons list more-lists)))
+      ((member nil lists) list)
+    (apply function lists)
+    (do ((l lists (cdr l)))
+	((endp l))
+      (rplaca l (cdar l)))))
+
+(redefun/cc maplist (function list &rest more-lists)
+  "Apply FUNCTION to successive sublists of list, return list of results."
+  (do* ((lists (cons list more-lists))
+	(result (list nil))
+	(splice result))
+      ((member nil lists) (cdr result))
+    (setq splice (cdr (rplacd splice (list (apply function lists)))))    
+    (do ((l lists (cdr l)))
+	((endp l))
+      (rplaca l (cdar l)))))
+
+(redefun/cc mapcon (function list &rest more-lists)
+  "Apply FUNCTION to successive sublists of lists, return nconc of results."
+  (apply #'nconc (apply #'maplist function list more-lists)))
+
+(redefun/cc complement (function)
+  (lambda (&rest arguments)
+    (not (apply function arguments))))
+
+(redefun/cc list-delete-if (test list start end count key)
+  (let* ((head (cons nil list))
+	 (splice head))
+    (do ((i 0 (1+ i))
+	 (x list (cdr x)))
+	((endp x) (rplacd splice nil) (cdr head))
+      (when (and count (<= count 0))
+	(rplacd splice x)
+	(return (cdr head)))
+      (if (and (<= start i) (or (null end) (< i end))
+	       (funcall test (apply-key key (car x))))
+	  (when count (decf count))
+          (setq splice (cdr (rplacd splice x)))))))
+
+(redefun/cc vector-delete-if (test vector start end count key)
+  (let* ((length (length vector))
+	 (end (or end length))
+	 (count (or count length))
+	 (i 0))
+    (do* ((j 0 (1+ j))
+	  element)
+         ((>= j length))
+      (setq element (aref vector j))
+      (if (and (<= start j) (< j end)
+	       (plusp count)
+	       (funcall test (apply-key key element)))
+	  (when count (decf count))
+          (progn
+            (setf (aref vector i) element)
+            (incf i))))
+    (cond
+      ((array-has-fill-pointer-p vector)
+       (setf (fill-pointer vector) i)
+       vector)
+      ((adjustable-array-p vector) (adjust-array vector i))
+      (t (subseq vector 0 i))))) 
+
+(redefun/cc delete-if (predicate sequence &key from-end (start 0) end count key)
+  "Modify SEQUENCE by deleting elements satisfying PREDICATE."
+  (if from-end
+      (let ((length (length sequence)))
+	(nreverse (delete-if predicate (nreverse sequence)
+			     :start (- length (or end length))
+			     :end (- length start)
+			     :count count :key key)))
+    (etypecase sequence
+      (null nil)
+      (cons (list-delete-if predicate sequence start end count key))
+      (vector (vector-delete-if predicate sequence start end count key)))))
+
+(redefun/cc delete (item sequence &key from-end (test #'eql) test-not (start 0) end
+		    count key)
+  "Modify SEQUENCE by deleting elements equal to ITEM."
+  (when test-not (setq test (complement test-not)))
+  (delete-if #'(lambda (arg) (funcall test item arg)) sequence
+	     :from-end from-end :start start :end end :count count :key key))
+
+(redefun/cc delete-if-not (predicate sequence &key from-end (start 0) end count key)
+  "Modify SEQUENCE by deleting elements not satisfying PREDICATE."
+  (delete-if (complement predicate) sequence :from-end from-end
+	     :start start :end end :count count :key key))
+
+(redefun/cc remove-if (predicate sequence &key from-end (start 0) end count key)
+  "Return a copy of SEQUENCE with elements satisfying PREDICATE removed."
+  (delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end
+	     :count count :key key))
+
+(redefun/cc remove (item sequence &key from-end (test #'eql) test-not (start 0)
+		    end count key)
+  "Return a copy of SEQUENCE with elements equal to ITEM removed."
+  (when test-not (setq test (complement test-not)))
+  (remove-if #'(lambda (arg) (funcall test item arg)) sequence
+	     :from-end from-end :start start :end end :count count :key key))
+
+(redefun/cc remove-if-not (predicate sequence &key from-end (start 0) end count key)
+  "Return a copy of SEQUENCE with elements not satisfying PREDICATE removed."
+  (remove-if (complement predicate) sequence :from-end from-end
+	     :start start :end end :count count :key key))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/generic-functions.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,154 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** Functions, Generic Functions, Methods and standard-combination
+
+;;;; DEFUN/CC
+
+(defmacro defun/cc (name arguments &body body)
+  `(progn
+     (setf (fdefinition/cc ',name 'defun/cc)
+           (make-instance 'closure/cc
+                          :code (walk-form '(lambda ,arguments
+                                             (block ,name , at body))
+                                           nil nil)
+                          :env nil))
+     (defun ,name ,arguments
+       (declare (ignore ,@(extract-argument-names arguments)))
+       (error "Sorry, /CC function are not callable outside of with-call/cc."))))
+
+;;;; DEFGENERIC/CC
+
+(defmacro defgeneric/cc (name args &rest options)
+  "Trivial wrapper around defgeneric designed to alert readers that these methods are cc methods."
+  (assert (not (find :method options :key #'first)) () "TODO: defgeneric/cc does not walk the :method entries yet, use standalone defmethod/cc's")
+  `(progn
+     (defgeneric ,name ,args
+       , at options
+       (:method-combination cc-standard))
+     (setf (fdefinition/cc ',name 'defmethod/cc) t)))
+
+;;;; DEFMETHOD/CC
+
+; for emacs:  (setf (get 'defmethod/cc 'common-lisp-indent-function) 'lisp-indent-defmethod)
+
+(defmacro defmethod/cc (name &rest args)
+  (let ((qlist (list (if (and (symbolp (car args))
+				  (not (null (car args))))
+                         (pop args)
+                         :primary))))
+    (let ((arguments (car args))
+	  (body (cdr args)))
+      `(progn
+	 (unless (eq 'defmethod/cc (second (multiple-value-list (fdefinition/cc ',name))))
+           (setf (fdefinition/cc ',name 'defmethod/cc) t)
+           (defgeneric/cc ,name ,(if arguments 
+                                     (convert-to-generic-lambda-list arguments)
+                                     '())))
+	 (defmethod ,name , at qlist ,arguments
+           ,(when arguments 
+	     `(declare (ignorable ,@(extract-argument-names arguments :allow-specializers t))))
+	   ,@(when (stringp (first body))
+              (list (pop body)))
+	   (make-instance 'closure/cc
+			  :code (walk-form '(lambda ,(clean-argument-list arguments)
+					     (block ,name , at body))
+					   nil nil)
+			  :env nil))))))
+
+;;;; CC-STANDARD (standard-combination for cc methods)
+
+(defun closure-with-nextmethod (closure next)
+  (make-instance 'closure/cc 
+		 :code (code closure)
+		 :env (register (env closure) :next-method t next)))
+
+(defun closure-with-befores (closure befores)
+  (make-instance 'closure/cc 
+		 :code (walk-form `(lambda (&rest args)
+				     ,@(loop 
+					  for before in befores
+					  collect `(apply ,before args))
+				     (apply ,closure args)))
+		 :env nil))
+
+(defun closure-with-afters (closure afters)
+  (make-instance 'closure/cc 
+		 :code (walk-form `(lambda (&rest args)
+				     (prog1 
+					 (apply ,closure args)
+				       ,@(loop 
+					    for after in afters
+					    collect `(apply ,after args)))))
+		 :env nil))
+
+(define-method-combination cc-standard
+    (&key (around-order :most-specific-first)
+          (before-order :most-specific-first)
+          (primary-order :most-specific-first)
+          (after-order :most-specific-last))
+  ((around (:around))
+   (before (:before))
+   (primary (:primary) :required t)
+   (after (:after)))
+  
+  (labels ((effective-order (methods order)
+             (ecase order
+               (:most-specific-first methods)
+               (:most-specific-last (reverse methods))))
+	   (primary-wrap (methods &optional nextmethod)
+	     (case (length methods)
+	       (1 `(closure-with-nextmethod 
+		    (call-method ,(first methods))
+		    ,nextmethod))
+	       (t `(closure-with-nextmethod 
+		    (call-method ,(first methods))
+		    ,(primary-wrap (cdr methods) nextmethod)))))
+	   (call-methods (methods)
+	     `(list ,@(loop 
+			 for m in methods
+			 collect `(call-method ,m)))))
+    (let* (;; reorder the methods based on the -order arguments
+           (around  (effective-order around around-order))
+           (before  (effective-order before before-order))
+           (primary (effective-order primary primary-order))
+           (after   (effective-order after after-order))
+           (form    (primary-wrap primary)))
+      (when after 
+	(setf form `(closure-with-afters ,form ,(call-methods after))))
+      (when before 
+	(setf form `(closure-with-befores ,form ,(call-methods before))))
+      (when around
+	(setf form (primary-wrap around form)))
+      form)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/handlers.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,334 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; ** Handlres for common-lisp special operators
+
+;;;; Variable References
+
+(defmethod evaluate/cc ((var local-variable-reference) lex-env dyn-env k)
+  (declare (ignore dyn-env))
+  (kontinue k (lookup lex-env :let (name var) :error-p t)))
+
+(defmethod evaluate/cc ((var local-lexical-variable-reference) lex-env dyn-env k)
+  (declare (ignore dyn-env))
+  (kontinue k (funcall (first (lookup lex-env :lexical-let (name var) :error-p t)))))
+
+(defmethod evaluate/cc ((var free-variable-reference) lex-env dyn-env k)
+  (declare (ignore lex-env))
+  (multiple-value-bind (value foundp)
+      (lookup dyn-env :let (name var))
+    (if foundp
+        (kontinue k value)
+        (kontinue k (symbol-value (name var))))))
+
+;;;; Constants
+
+(defmethod evaluate/cc ((c constant-form) lex-env dyn-env k)
+  (declare (ignore lex-env dyn-env))
+  (kontinue k (value c)))
+
+;;;; BLOCK/RETURN-FROM
+
+(defmethod evaluate/cc ((block block-form) lex-env dyn-env k)
+  (evaluate-progn/cc (body block)
+                     (register lex-env :block (name block) k)
+                     dyn-env k))
+
+(defmethod evaluate/cc ((return return-from-form) lex-env dyn-env k)
+  (declare (ignore k))
+  (evaluate/cc (result return)
+               lex-env dyn-env
+               (lookup lex-env :block (name (target-block return)) :error-p t)))
+
+;;;; CATCH/THROW
+
+(defmethod evaluate/cc ((catch catch-form) lex-env dyn-env k)
+  (evaluate/cc (tag catch) lex-env dyn-env
+               `(catch-tag-k ,catch ,lex-env ,dyn-env ,k)))
+
+(defk catch-tag-k (catch lex-env dyn-env k)
+    (tag)
+  (evaluate-progn/cc (body catch) lex-env (register dyn-env :catch tag k) k))
+
+(defmethod evaluate/cc ((throw throw-form) lex-env dyn-env k)
+  (evaluate/cc (tag throw) lex-env dyn-env
+               `(throw-tag-k ,throw ,lex-env ,dyn-env ,k)))
+
+(defk throw-tag-k (throw lex-env dyn-env k)
+    (tag)
+  (evaluate/cc (value throw) lex-env dyn-env
+               (lookup dyn-env :catch tag :error-p t)))
+
+;;;; FLET/LABELS
+
+(defmethod evaluate/cc ((flet flet-form) lex-env dyn-env k)
+  (let ((new-env lex-env))
+    (dolist* ((name . form) (binds flet))
+      (setf new-env (register new-env :flet name (make-instance 'closure/cc
+                                                                :code form
+                                                                :env lex-env))))
+    (evaluate-progn/cc (body flet) new-env dyn-env k)))
+
+(defmethod evaluate/cc ((labels labels-form) lex-env dyn-env k)
+  (let ((closures '()))
+    (dolist* ((name . form) (binds labels))
+      (let ((closure (make-instance 'closure/cc :code form)))
+        (setf lex-env (register lex-env :flet name closure))
+        (push closure closures)))
+    (dolist (closure closures)
+      (setf (env closure) lex-env))
+    (evaluate-progn/cc (body labels) lex-env dyn-env k)))
+
+;;;; LET/LET*
+
+;; returns a dynamic environment that holds the special variables imported for let
+;; these variables are captured from the caller normal lisp code and stored within
+;; the continuation. The mixin might be a binding-form-mixin and implicit-progn-with-declare-mixin.
+(defun import-specials (mixin dyn-env)
+  (dolist (declaration (declares mixin))
+    (let ((name (name declaration)))
+      (if (and (typep declaration 'special-declaration-form)
+               (or (not (typep mixin 'binding-form-mixin))
+                   (not (find name (binds mixin) :key 'first)))
+               (not (lookup dyn-env :let name)))
+          (setf dyn-env (register dyn-env :let name (symbol-value name))))))
+  dyn-env)
+
+(defmethod evaluate/cc ((let let-form) lex-env dyn-env k)
+  (evaluate-let/cc (binds let) nil (body let) lex-env (import-specials let dyn-env) k))
+
+(defk k-for-evaluate-let/cc (var remaining-bindings evaluated-bindings body lex-env dyn-env k)
+    (value)
+  (evaluate-let/cc remaining-bindings
+                   (cons (cons var value) evaluated-bindings)
+                   body lex-env dyn-env k))
+
+(defun evaluate-let/cc (remaining-bindings evaluated-bindings body lex-env dyn-env k)
+  (if remaining-bindings
+      (destructuring-bind (var . initial-value)
+          (car remaining-bindings)
+        (evaluate/cc
+         initial-value
+         lex-env dyn-env
+         `(k-for-evaluate-let/cc
+           ,var
+           ,(cdr remaining-bindings)
+           ,evaluated-bindings
+           ,body
+           ,lex-env ,dyn-env ,k)))
+      (dolist* ((var . value) evaluated-bindings
+                (evaluate-progn/cc body lex-env dyn-env k))
+        (if (special-var-p var (parent (first body)))
+            (setf dyn-env (register dyn-env :let var value))
+            (setf lex-env (register lex-env :let var value))))))
+
+(defun special-var-p (var declares-mixin)
+  (or (find-if (lambda (declaration)
+                 (and (typep declaration 'special-declaration-form)
+                      (eq (name declaration) var)))
+               (declares declares-mixin))
+      (boundp var)
+      ;; This is the only portable way to check if a symbol is
+      ;; declared special, without being boundp, i.e. (defvar 'foo).
+      ;; Maybe we should make it optional with a compile-time flag?
+      #+nil(eval `((lambda ()
+                (flet ((func ()
+                         (symbol-value ',var)))
+                  (let ((,var t))
+                    (declare (ignorable ,var))
+                    (ignore-errors (func)))))))))
+
+(defmethod evaluate/cc ((let* let*-form) lex-env dyn-env k)
+  (evaluate-let*/cc (binds let*) (body let*) lex-env (import-specials let* dyn-env) k))
+
+(defk k-for-evaluate-let*/cc (var bindings body lex-env dyn-env k)
+    (value)
+  (if (special-var-p var (parent (first body)))
+      (evaluate-let*/cc bindings body
+                        lex-env
+                        (register dyn-env :let var value)
+                        k)
+      (evaluate-let*/cc bindings body
+                        (register lex-env :let var value)
+                        dyn-env
+                        k)))
+
+(defun evaluate-let*/cc (bindings body lex-env dyn-env k)
+  (if bindings
+      (destructuring-bind (var . initial-value)
+          (car bindings)
+        (evaluate/cc initial-value lex-env dyn-env
+                      `(k-for-evaluate-let*/cc ,var ,(cdr bindings) ,body ,lex-env ,dyn-env ,k)))
+      (evaluate-progn/cc body lex-env dyn-env k)))
+
+;;;; IF
+
+(defk k-for-evaluate-if/cc (then else lex-env dyn-env k)
+    (value)
+  (if value
+      (evaluate/cc then lex-env dyn-env k)
+      (evaluate/cc else lex-env dyn-env k)))
+
+(defmethod evaluate/cc ((if if-form) lex-env dyn-env k)
+  (evaluate/cc (consequent if) lex-env dyn-env
+                `(k-for-evaluate-if/cc ,(then if) ,(else if) ,lex-env ,dyn-env ,k)))
+
+;;;; LOCALLY
+
+(defmethod evaluate/cc ((locally locally-form) lex-env dyn-env k)
+  (evaluate-progn/cc (body locally) lex-env dyn-env k))
+
+;;;; MACROLET
+
+(defmethod evaluate/cc ((macrolet macrolet-form) lex-env dyn-env k)
+  ;; since the walker already performs macroexpansion there's nothing
+  ;; left to do here.
+  (evaluate-progn/cc (body macrolet) lex-env dyn-env k))
+
+;;;; multiple-value-call
+
+(defk k-for-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k)
+    (value other-values)
+  (evaluate-m-v-c
+   remaining-arguments (append evaluated-arguments (list value) other-values)
+   lex-env dyn-env k))
+
+(defun evaluate-m-v-c (remaining-arguments evaluated-arguments lex-env dyn-env k)
+  (if remaining-arguments
+      (evaluate/cc (car remaining-arguments) lex-env dyn-env
+                   `(k-for-m-v-c  ,(cdr remaining-arguments) ,evaluated-arguments ,lex-env ,dyn-env ,k))
+      (destructuring-bind (function &rest arguments)
+          evaluated-arguments
+        (etypecase function
+          (closure/cc (apply-lambda/cc function arguments dyn-env k))
+          (function (apply #'kontinue k (multiple-value-list
+                                         (multiple-value-call function (values-list arguments)))))))))
+
+(defmethod evaluate/cc ((m-v-c multiple-value-call-form) lex-env dyn-env k)
+  (evaluate-m-v-c (list* (func m-v-c) (arguments m-v-c)) '() lex-env dyn-env k))
+
+;;;; PROGN
+
+(defmethod evaluate/cc ((progn progn-form) lex-env dyn-env k)
+  (evaluate-progn/cc (body progn) lex-env dyn-env k))
+
+(defk k-for-evaluate-progn/cc (rest-of-body lex-env dyn-env k)
+    ()
+  (evaluate-progn/cc rest-of-body lex-env dyn-env k))
+
+(defun evaluate-progn/cc (body lex-env dyn-env k)
+  (cond
+    ((cdr body)
+      (evaluate/cc (first body) lex-env dyn-env
+                    `(k-for-evaluate-progn/cc ,(cdr body) ,lex-env ,dyn-env ,k)))
+    (body
+     (evaluate/cc (first body) lex-env dyn-env k))
+    (t
+     (kontinue k nil))))
+
+;;;; SETQ
+
+(defk k-for-local-setq (var lex-env dyn-env k)
+    (value)
+  (setf (lookup lex-env :let var :error-p t) value)
+  (kontinue k value))
+
+(defk k-for-free-setq (var lex-env dyn-env k)
+    (value)
+  (setf (symbol-value var) value)
+  (kontinue k value))
+
+(defk k-for-local-lexical-setq (var lex-env dyn-env k)
+    (value)
+  (funcall (second (lookup lex-env :lexical-let var :error-p t)) value)
+  (kontinue k value))
+
+(defmethod evaluate/cc ((setq setq-form) lex-env dyn-env k)
+  (macrolet ((if-found (&key in-env of-type kontinue-with)
+               `(multiple-value-bind (value foundp)
+                    (lookup ,in-env ,of-type (var setq))
+                  (declare (ignore value))
+                  (when foundp
+                    (return-from evaluate/cc
+                      (evaluate/cc (value setq) lex-env dyn-env
+                                   `(,',kontinue-with ,(var setq) ,lex-env ,dyn-env ,k)))))))
+    (if-found :in-env lex-env
+              :of-type :let
+              :kontinue-with k-for-local-setq)
+    (if-found :in-env dyn-env
+              :of-type :let
+              :kontinue-with k-for-special-setq)
+    (if-found :in-env lex-env
+              :of-type :lexical-let
+              :kontinue-with k-for-local-lexical-setq)
+    (evaluate/cc (value setq)
+                       lex-env dyn-env
+                       `(k-for-free-setq ,(var setq) ,lex-env ,dyn-env ,k))))
+
+;;;; SYMBOL-MACROLET
+
+(defmethod evaluate/cc ((symbol-macrolet symbol-macrolet-form) lex-env dyn-env k)
+  ;; like macrolet the walker has already done all the work needed for this.
+  (evaluate-progn/cc (body symbol-macrolet) lex-env dyn-env k))
+
+;;;; TAGBODY/GO
+
+(defk tagbody-k (k)
+    ()
+  (kontinue k nil))
+
+(defmethod evaluate/cc ((tagbody tagbody-form) lex-env dyn-env k)
+  (evaluate-progn/cc (body tagbody)
+                     (register lex-env :tag tagbody k) dyn-env
+                     `(tagbody-k ,k)))
+
+(defmethod evaluate/cc ((go-tag go-tag-form) lex-env dyn-env k)
+  (declare (ignore go-tag lex-env dyn-env))
+  (kontinue k nil))
+
+(defmethod evaluate/cc ((go go-form) lex-env dyn-env k)
+  (declare (ignore k))
+  (evaluate-progn/cc (target-progn go) lex-env dyn-env
+                     (lookup lex-env :tag (enclosing-tagbody go) :error-p t)))
+
+;;;; THE
+
+(defmethod evaluate/cc ((the the-form) lex-env dyn-env k)
+  (evaluate/cc (value the) lex-env dyn-env k))
+
+;;;; LOAD-TIME-VALUE
+
+(defmethod evaluate/cc ((c load-time-value-form) lex-env dyn-env k)
+  (declare (ignore lex-env dyn-env))
+  (kontinue k (value c)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/call-cc/interpreter.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,206 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Common Lisp interpreter with support for continuations.
+
+;;;; Notes:
+
+;;;; This interpreter is dependent on the object tree built up by the
+;;;; code walker in walk.lisp.
+
+;;;; One of the, final, goals of this interpeter was to allow
+;;;; continuations to be serializable. Due to this constraint we
+;;;; represent continuations as regular lists which, when the cdr
+;;;; (which must be clos objects or literals) is applied to the car
+;;;; (which must be a symbol) the actual contiunation (a regular
+;;;; common lisp function) is returned. 
+
+(defvar *call/cc-returns* nil)
+
+(defmacro with-call/cc (&environment e &body body)
+  "Execute BODY with delimited partial continuations.
+
+  Within the code of BODY almost all common lisp forms maintain
+  their normal semantics. The following special forms are
+  allowed:
+
+  (call/cc LAMBDA) - LAMBDA, a one argument function, will be
+  passed a continuation. This object may then be passed to the
+  function KALL which will cause execution to resume around the
+  call/cc form. "
+  (let ((walk-env (make-walk-env e))
+        (evaluate-env nil))
+    (dolist* ((type name &rest data) (car walk-env))
+      (declare (ignore data))
+      (when (eql :lexical-let type)
+        (push (list 'list
+                    :lexical-let
+                    `(quote ,name)
+                    ;; NB: this makes the environment, and therefore
+                    ;; continuations, unserializable. we would need to
+                    ;; change this to a regular :let and not allow the
+                    ;; setting of lexical variables.
+                    `(lambda () ,name)
+                    (with-unique-names (v)
+                      `(lambda (,v) (setf ,name ,v))))
+              evaluate-env)))
+    (setf evaluate-env `(list ,@(nreverse evaluate-env)))
+    `(drive-interpreter/cc
+      (evaluate/cc ,(walk-form (if (rest body)
+                                   `(progn , at body)
+                                   (first body))
+                               nil walk-env)
+                   ,evaluate-env nil
+                   *toplevel-k*))))
+
+(defun kall (k &optional (primary-value nil primary-value-p)
+               &rest other-values)
+  "Continue the continuation K.
+
+This function can be used within the lexical scope of
+with-call/cc and outside, though it has slightly different
+semantics."
+  (drive-interpreter/cc
+   (lambda ()
+     (let ((k (apply (car k) (cdr k))))
+       (cond
+         (other-values (apply k primary-value other-values))
+         (primary-value-p (funcall k primary-value))
+         (t (funcall k nil)))))))
+
+(defvar *cc-functions* (make-hash-table :test 'eql))
+
+(defun fmkunbound/cc (function-name)
+  (remhash function-name *cc-functions*))
+
+(defun fdefinition/cc (function-name)
+  (values-list (gethash function-name *cc-functions*)))
+
+(defun (setf fdefinition/cc) (closure-object function-name &optional (type 'defun/cc))
+  (setf (gethash function-name *cc-functions*) (list closure-object type)))
+
+(defvar *debug-evaluate/cc* nil
+  "When non NIL the evaluator will print, at each evaluation
+  step, what it's evaluating and the value passed in from the
+  previous step.
+
+If set to :FULL then at each step we print the form, the
+environment and the continuation. If set to T we just print the
+form being evaluated.")
+
+;;;; Implementation
+
+(defun drive-interpreter/cc (code)
+  (catch 'done
+    (loop for thunk = code then (funcall thunk))))
+
+(defmacro let/cc (k &body body)
+  `(call/cc (lambda (,k) , at body)))
+
+(defmacro retk ()
+  `(let/cc k k))
+
+(defmacro klambda ((&optional (value (gensym) valuep) (other-values (gensym) other-values-p))
+                   &body body)
+  (cond
+    (other-values-p `(lambda (&optional ,value &rest ,other-values)
+                       (lambda ()
+                         , at body)))
+    (valuep `(lambda (&optional ,value &rest ,other-values)
+               (declare (ignore ,other-values))
+               (lambda ()
+                 , at body)))
+    (t `(lambda (&optional ,value &rest ,other-values)
+          (declare (ignore ,value ,other-values))
+          (lambda ()
+            , at body)))))
+
+(defvar *trace-cc* nil
+  "Variable which controls the tracing of WITH-CALL/CC code.
+
+When not NIL the interepreter will report what code it is
+evaluating and what it returns.")
+
+(defmacro trace-statement (format-control &rest format-args)
+  `(when *trace-cc*
+     (format *trace-output* ,(strcat "~&" format-control "~%") , at format-args)))
+
+(defun kontinue (k &optional (primary-value nil primary-value-p) &rest other-values)
+  (trace-statement "Got ~S~{; ~S~}" primary-value other-values)
+  (let ((k (apply (car k) (cdr k))))
+    (cond
+      (other-values (apply k primary-value other-values))
+      (primary-value-p (funcall k primary-value))
+      (t (funcall k)))))
+
+(defmacro defk (name args k-args &body body)
+  `(defun ,name ,args
+     (declare (ignorable , at args))
+     (klambda ,k-args
+       (when *debug-evaluate/cc*
+         (format *debug-io* "~&(~S~{~^ ~S~}) Got (values~{~^ ~S~}).~%" ',name (list , at args) (list , at k-args)))
+       , at body)))
+
+(defgeneric evaluate/cc (form lexical-environment dynamic-environment k))
+
+(defmethod evaluate/cc ((form t) lex-env dyn-env k)
+  (declare (ignore lex-env dyn-env k))
+  (error "No EVALUATE/CC method defined for ~S." form))
+
+(defmethod evaluate/cc :around ((form form) lex-env dyn-env k)
+  (declare (ignore lex-env dyn-env k))
+  (trace-statement "Evaluating ~S." (source form))
+  (call-next-method))
+
+(defun print-debug-step (form lex-env dyn-env k)
+  (let ((*print-pretty* nil))
+    (ecase *debug-evaluate/cc*
+      (:full
+       (format *debug-io*
+               "~&Evaluating: ~S~%~3TLex Env: ~S~%~3TDyn Env: ~S~%~3TK: ~S~%"
+               form lex-env dyn-env k))
+      ((t)
+       (format *debug-io* "~&Evaluating: ~S~%" form))
+      ((nil) ;; do nothing
+       nil))))
+
+(defmethod evaluate/cc :before (form lex-env dyn-env k)
+  (when *debug-evaluate/cc*
+    (print-debug-step form lex-env dyn-env k)))
+
+(defun toplevel-k ()
+  (klambda (value other-values)
+    (throw 'done (values-list (cons value other-values)))))
+
+(defparameter *toplevel-k* '(toplevel-k))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/cl-ppcre-extras.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,107 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+(defpackage :it.bese.arnesi.cl-ppcre-extras
+  (:use)
+  (:nicknames :rx)
+  (:export
+   #:=~
+   #:!~
+   #:$1
+   #:$2
+   #:$3
+   #:$4
+   #:$5
+   #:$6
+   #:$7
+   #:$8
+   #:$9))
+
+(defparameter rx::$_ nil
+  "The current default target for regexp matching.")
+(defparameter rx::$1 nil "The string matched by the first group in the last regexp match.")
+(defparameter rx::$2 nil "The string matched by the second group in the last regexp match.")
+(defparameter rx::$3 nil "The string matched by the third group in the last regexp match.")
+(defparameter rx::$4 nil "The string matched by the fourth group in the last regexp match.")
+(defparameter rx::$5 nil "The string matched by the fifth group in the last regexp match.")
+(defparameter rx::$6 nil "The string matched by the sixth group in the last regexp match.")
+(defparameter rx::$7 nil "The string matched by the seventh group in the last regexp match.")
+(defparameter rx::$8 nil "The string matched by the eight group in the last regexp match.")
+(defparameter rx::$9 nil "The string matched by the ninth group in the last regexp match.")
+
+(defmacro rx::=~ (regexp &optional (target 'rx::$_) (then t) (else nil))
+  "Equivalent to perl's if (TARGET =~ REGEXP) { THEN } else { ELSE }.
+
+Attempt to match REGEXP agains TARGET, if the match succedes THEN
+is evaluated with $1, .. $9 bound to the groups in
+REGEXP. Otherwise ELSE is executed."
+  (destructuring-bind (regexp &rest create-scanner-args) (if (listp regexp)
+                                                             regexp
+                                                             (list regexp))
+    (destructuring-bind (trgt &key start end) (if (listp target)
+                                                  target
+                                                  (list target))
+      (let ((match-start (gensym))
+            (match-end (gensym))
+            (register-starts (gensym))
+            (register-ends (gensym))
+            (num-registers (gensym))
+            (target (gensym)))
+        (flet ((gen-$-var (index)
+                 `(if (< ,num-registers ,index)
+                      nil
+                      (let ((start (aref ,register-starts (1- ,index)))
+                            (end (aref ,register-ends (1- ,index))))
+                        (if (null start)
+                            nil
+                            (make-array (- end start) :displaced-to ,target :displaced-index-offset start))))))
+          `(let ((,target ,trgt))
+             (multiple-value-bind (,match-start ,match-end ,register-starts ,register-ends)
+                 (cl-ppcre:scan (cl-ppcre:create-scanner ,regexp , at create-scanner-args)
+                       ,trgt ,@(when start `(:start ,start))
+                             ,@(when end `(:end ,end)))
+               (declare (ignore ,match-end))
+               (if (not (null ,match-start))
+                   (let* ((,num-registers (length ,register-starts)))
+                     (setf rx::$1 ,(gen-$-var 1)
+                           rx::$2 ,(gen-$-var 2)
+                           rx::$3 ,(gen-$-var 3)
+                           rx::$4 ,(gen-$-var 4)
+                           rx::$5 ,(gen-$-var 5)
+                           rx::$6 ,(gen-$-var 6)
+                           rx::$7 ,(gen-$-var 7)
+                           rx::$8 ,(gen-$-var 8)
+                           rx::$9 ,(gen-$-var 9))
+                     ,then)
+                   ,else))))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/compat.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,47 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Trivial Compatibility Layer
+
+;;;; Here we only have the QUIT function, see mopp.lisp for a MOP
+;;;; compatibility layer.
+
+(defun quit (&optional (exit-code 0))
+  #+openmcl (ccl:quit exit-code)
+  #+sbcl (sb-ext:quit :unix-status exit-code)
+  #+clisp (ext:quit exit-code)
+  #+(or cmu allegro) (declare (ignore exit-code))
+  #+cmu (ext:quit)
+  #+lispworks (lispworks:quit :status exit-code)
+  #+allegro (excl:exit))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/csv.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,117 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Reading and Writing files in Comma-Seperated-Values format
+
+;;;; Generating CSV files from lisp data
+
+(defun princ-csv (items csv-stream
+                  &key (quote #\")
+                       (separator #\,)
+                       (ignore-nulls t)
+                       (newline +CR-LF+)
+                       (princ #'princ-to-string))
+  "Write the list ITEMS to csv-stream."
+  (flet ((write-word (word)
+           (write-char quote csv-stream)
+           (loop
+              for char across (funcall princ word)
+              if (char= quote char) do
+                (progn
+                  (write-char quote csv-stream)
+                  (write-char quote csv-stream))
+              else do
+                (write-char char csv-stream))
+           (write-char quote csv-stream)))
+    (when items
+      (write-word (car items))
+      (dolist (i (cdr items))
+        (write-char separator csv-stream)
+        (if ignore-nulls
+            (when (not (null i))
+              (write-word i))
+            (write-word i)))
+      (write-sequence newline csv-stream))))
+
+(defun princ-csv-to-string (items)
+  (with-output-to-string (csv)
+    (princ-csv items csv)))
+
+;;;; Reading in CSV files
+
+(defun parse-csv-string (line &key (separator #\,) (quote #\"))
+  "Parse a csv line into a list of strings using seperator as the
+  column seperator and quote as the string quoting character."
+  (let ((items '())
+        (offset 0)
+        (current-word (make-array 20
+                                  :element-type 'character
+                                  :adjustable t
+                                  :fill-pointer 0))
+        (state :read-word))
+    (loop
+       (when (= offset (length line))
+         ;; all done
+         (ecase state
+           (:in-string
+            (error "Unterminated string."))
+           (:read-word
+            (return-from parse-csv-string
+              (nreverse (cons current-word items))))))
+       (cond
+         ((char= separator (aref line offset))
+          (ecase state
+            (:in-string
+             (vector-push-extend (aref line offset) current-word))
+            (:read-word
+             (push current-word items)
+             (setf current-word (make-array 20
+                                            :element-type 'character
+                                            :adjustable t
+                                            :fill-pointer 0)))))
+         ((char= quote (aref line offset))
+          (ecase state
+            (:in-string
+             (let ((offset+1 (1+ offset)))
+	       (cond
+		 ((and (/= offset+1 (length line))
+		       (char= quote (aref line offset+1)))
+		  (vector-push-extend quote current-word)
+		  (incf offset))
+		 (t (setf state :read-word)))))
+            (:read-word
+             (setf state :in-string))))
+         (t
+          (vector-push-extend (aref line offset) current-word)))
+       (incf offset))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/debug.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,108 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Debugging Utilties
+
+;;;; (These were far more useful in the pre-slime days.)
+
+(defmacro ppm1 (form)
+  "(pprint (macroexpand-1 ',form)).
+
+NB: C-RET is even shorter."
+  `(pprint (macroexpand-1 ',form)))
+
+(defmacro ppm (form)
+  `(pprint (macroexpand ',form)))
+
+;;;; A portable flexible APROPOS implementation
+
+(defun apropos-list* (string &key (fbound nil fbound-supplied-p)
+                                  (bound nil bound-supplied-p)
+                                  (package nil package-supplied-p)
+                                  (distance 0 distance-supplied-p))
+  (let ((symbols '()))
+    (do-all-symbols (sym)
+      (block collect-symbol
+        (when fbound-supplied-p
+          (when (xor fbound (fboundp sym))
+            (return-from collect-symbol)))
+        (when bound-supplied-p
+          (when (xor bound (boundp sym))
+            (return-from collect-symbol)))
+       (when package-supplied-p
+         (unless (eql package (symbol-package sym))
+           (return-from collect-symbol)))
+       (when distance-supplied-p
+         (unless (and
+                  (<= (abs (- (length (symbol-name sym)) 
+                              (length string)))
+                      distance)
+                  (<= (levenshtein-distance string (symbol-name sym))
+                      distance))
+           (return-from collect-symbol)))
+       (when (not distance-supplied-p)
+         ;; regular string= test
+         (unless (search string (symbol-name sym) :test #'char-equal)
+           (return-from collect-symbol)))
+       ;; all the checks we wanted to perform passed.
+       (push sym symbols)))
+    symbols))
+
+(defun apropos* (&rest apropos-args)
+  (flet ((princ-length (sym)
+           (if (keywordp sym)
+               (+ 1 (length (symbol-name sym)))
+               (+ (length (package-name (symbol-package sym)))
+                  1
+                  (length (symbol-name sym))))))
+    (let* ((syms (apply #'apropos-list* apropos-args))
+           (longest (apply #'max (mapcar #'princ-length syms))))
+      (dolist (sym syms)
+        (if (keywordp sym)
+            (progn
+              (princ ":" *debug-io*)
+              (princ (symbol-name sym) *debug-io*))
+            (progn
+              (princ (package-name (symbol-package sym)) *debug-io*)
+              (princ ":" *debug-io*)
+              (princ (symbol-name sym) *debug-io*)))
+        (princ (make-string (- longest (princ-length sym))
+                            :initial-element #\Space)
+               *debug-io*)
+        (when (fboundp sym)
+          (princ " [FUNC] " *debug-io*))
+        (when (boundp sym)
+          (princ " [VAR] " *debug-io*))
+        (terpri *debug-io*))))
+  (values))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/decimal-arithmetic.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,120 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Decimal Arithmetic
+
+;;;; Converting to and from external representations
+
+(defvar *precision* 2
+  "Default precision.")
+
+(defmacro with-precision (prec &body body)
+  "Evalute BODY with *precision* bound to PREC."
+  (let ((precision (gensym)))
+    `(let ((,precision ,prec))
+       (assert (integerp ,precision)
+	       (,precision)
+	       "Precision must be an integer, not ~S" ,precision)
+       (let ((*precision* (10^ ,precision)))
+	 (declare (special *precision*))
+	 , at body))))
+
+(defun decimal-from-float (float
+                           &optional (precision *precision*)
+                                     (rounding-method #'round-half-up))
+  "Convert FLOAT to an exact value with precision PRECISION using
+  ROUNDING-METHOD to do any neccessary rounding."
+  (funcall rounding-method float precision))
+
+(defun float-from-decimal (decimal)
+  "Convert the exact decimal value DECIMAL to a (not neccassily
+  equal) floating point value."
+  (float decimal))
+
+;;;; Rounding functions
+
+(defun round-down (number &optional (precision *precision*))
+  "Round towards 0."
+  (if (minusp number)
+      (round-ceiling number precision)
+      (round-floor   number precision)))
+
+(defun round-half-up (number &optional (precision *precision*))
+  "Round towards the nearest value allowed with the current
+precision. If the current value is exactly halfway between two logal
+values round away from 0."
+  (multiple-value-bind (value discarded)
+      (floor (* number precision))
+    (if (<= 1/2 discarded)
+	(/ (1+ value) precision)
+        (/ value precision))))
+
+(defun round-half-even (number &optional (precision *precision*))
+  "Round towards the nearest value allowed with the current
+precision. If the current value is exactly halfway between two legal
+values round towards the nearest even value."
+  (multiple-value-bind (value discarded)
+      (floor (* number precision))
+    (cond
+     ((< discarded 1/2) ;; down
+      (/ value precision))
+     ((= discarded 1/2) ;; goto even
+      (if (evenp value)
+	  (/ value precision)
+	  (/ (1+ value) precision)))
+     (t ;; (>= discarded 1/2)
+      (/ (1+ value) precision)))))
+	
+(defun round-ceiling (number &optional (precision *precision*))
+  "Round towards positive infintity"
+  (/ (ceiling (* number precision)) precision))
+
+(defun round-floor (number &optional (precision *precision*))
+  "Round towards negative infinity."
+  (/ (floor (* number precision)) precision))
+
+(defun round-half-down (number &optional (precision *precision*))
+  "Round towards the nearest legal value. If the current value is
+exactly half way between two legal values round towards 0."
+  (multiple-value-bind (value discarded)
+      (floor number)
+    (if (< 1/2 discarded)
+	(/ (1+ value) precision)
+        (/ value precision))))
+
+(defun round-up (number &optional (precision *precision*))
+  "Round away from 0."
+  (if (minusp number)
+      (round-floor number precision)
+      (round-ceiling number precision)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/defclass-struct.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,100 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Defining classes with DEFSTRUCT's syntax
+
+(defmacro defclass-struct (name-and-options supers &rest slots)
+  "DEFCLASS with a DEFSTRUCT api.
+
+NAME-AND-OPTIONS:
+
+  name-symbol |
+  ( name-symbol [ (:conc-name conc-name ) ]
+                [ (:predicate predicate-name ) ]
+                class-option* )
+
+SUPERS - a list of super classes passed directly to DEFCLASS.
+
+SLOTS - a list of slot forms:
+
+  name |
+  ( name [ init-arg ] [ slot-options* ] )"
+  (generate-defclass (first (ensure-list name-and-options))
+                     (cdr (ensure-list name-and-options))
+                     supers slots))
+
+(defun generate-defclass (class-name options supers slots)
+  (let ((conc-name nil)
+        (predicate nil)
+        (predicate-forms nil)
+        (class-options '()))
+    (loop
+       for (option-name . args) in options
+       do (case option-name
+            (:conc-name
+             (when conc-name
+               (error "Can't specify the :CONC-NAME argument more than once."))
+             (setf conc-name (first args)))
+            (:predicate
+             (when predicate
+               (error "Can't specify the :PREDICATE argument more than once."))
+             (setf predicate (if (eql t (first args))
+                                 (intern (strcat class-name :-p) *package*)
+                                 (first args))))
+            (t
+             (push (cons option-name args) class-options))))
+    (setf slots
+          (mapcar
+           (lambda (slot-spec)
+             (destructuring-bind (name
+                                  &optional initform
+                                  &rest options)
+                 (ensure-list slot-spec)
+               `(,name
+                 :initform ,initform
+                 ,@(when conc-name
+                     `(:accessor ,(intern (strcat conc-name name)
+                                          (symbol-package conc-name))))
+                 :initarg ,(intern (symbol-name name) :keyword)
+                 , at options)))
+           slots)
+          predicate-forms
+          (if predicate
+              (with-unique-names (obj)
+                `((defmethod ,predicate ((,obj ,class-name)) t)
+                  (defmethod ,predicate ((,obj t)) nil)))
+              nil))
+    `(prog1
+         (defclass ,class-name ,supers ,slots ,@(nreverse class-options))
+       , at predicate-forms)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/flow-control.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,235 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Various flow control operators
+
+;;;; ** Anaphoric conditionals
+
+(defmacro if-bind (var test &body then/else)
+  "Anaphoric IF control structure.
+
+VAR (a symbol) will be bound to the primary value of TEST. If
+TEST returns a true value then THEN will be executed, otherwise
+ELSE will be executed."
+  (assert (first then/else)
+          (then/else)
+          "IF-BIND missing THEN clause.")
+  (destructuring-bind (then &optional else)
+      then/else
+    `(let ((,var ,test))
+       (if ,var ,then ,else))))
+
+(defmacro aif (test then &optional else)
+  "Just like IF-BIND but the var is always IT."
+  `(if-bind it ,test ,then ,else))
+
+(defmacro when-bind (var test &body body)
+  "Just like when except VAR will be bound to the
+  result of TEST in BODY."
+  `(if-bind ,var ,test (progn , at body)))
+
+(defmacro awhen (test &body body)
+  "Just like when expect the symbol IT will be
+  bound to the result of TEST in BODY."
+  `(when-bind it ,test , at body))
+
+(defmacro cond-bind (var &body clauses)
+  "Just like COND but VAR will be bound to the result of the
+  condition in the clause when executing the body of the clause."
+  (if clauses
+      (destructuring-bind ((test &rest body) &rest others)
+          clauses
+        `(if-bind ,var ,test
+           (progn ,@(if body body (list var)))
+           (cond-bind ,var , at others)))
+      nil))
+
+(defmacro acond (&rest clauses)
+  "Just like cond-bind except the var is automatically IT."
+  `(cond-bind it , at clauses))
+
+(defmacro aand (&rest forms)
+  `(and-bind it , at forms))
+
+(defmacro and-bind (var &rest forms)
+  (cond
+    ((cdr forms)
+     `(when-bind ,var ,(first forms)
+        (and-bind ,var ,@(cdr forms))))
+    (forms (first forms))
+    (t 't)))
+
+;;;; ** Multiple value anaphoric conditionals
+
+(defmacro if2-bind (var test &body then/else)
+  "Anaphoric IF control structure for multiple values.
+
+VAR (a symbol) will be bound to the primary value of TEST.  If
+TEST's second value is true then THEN will be executed, otherwise
+ELSE will be executed."
+  (assert (first then/else)
+          (then/else)
+          "IF-BIND missing THEN clause.")
+  (destructuring-bind (then &optional else)
+      then/else
+    (with-unique-names (bool)
+      `(multiple-value-bind (,var ,bool) ,test
+	 (if ,bool ,then ,else)))))
+
+(defmacro aif2 (test then &optional else)
+  "Just like IF-BIND but the var is always IT.
+
+Very useful with functions like GETHASH."
+  `(if2-bind it ,test ,then ,else))
+
+;;;; ** Looping
+
+(defmacro while (test &body body)
+  "Repeat BODY while TEST is true.
+
+You may exit the loop with (RETURN-FROM WHILE)."
+  `(block while
+     (loop
+	(if ,test
+	    (progn , at body)
+	    (return-from while)))))
+
+(defmacro awhile (test &body body)
+  "Just like WHILE, but the result of TEST is bound to IT.
+
+You may exit the loop with (RETURN-FROM AWHILE)."
+  `(block awhile
+     (loop
+	(aif ,test
+	     (progn , at body)
+	     (return-from awhile)))))
+
+(defmacro until (test &body body)
+  "Repeat BODY until TEST is false.
+
+You may exit the loop with (RETURN-FROM UNTIL)."
+  `(block until
+     (loop
+	(if (not ,test)
+	    (progn , at body)
+	    (return-from until)))))
+
+;;;; ** Whichever
+
+(defmacro whichever (&rest possibilities)
+  "Evaluates one (and only one) of its args, which one is chosen at random"
+  `(ecase (random ,(length possibilities))
+     ,@(loop for poss in possibilities
+             for x from 0
+             collect (list x poss))))
+
+;;;; ** XOR - The missing conditional
+
+(defmacro xor (&rest datums)
+  "Evaluates the args one at a time. If more than one arg returns true
+  evaluation stops and NIL is returned. If exactly one arg returns
+  true that value is returned."
+  (let ((state (gensym "XOR-state-"))
+        (block-name (gensym "XOR-block-"))
+        (arg-temp (gensym "XOR-arg-temp-")))
+    `(let ((,state nil)
+           (,arg-temp nil))
+       (block ,block-name
+         ,@(loop
+              for arg in datums
+              collect `(setf ,arg-temp ,arg)
+              collect `(if ,arg-temp
+                           ;; arg is T, this can change the state
+                           (if ,state
+                               ;; a second T value, return NIL
+                               (return-from ,block-name nil)
+                               ;; a first T, swap the state
+                               (setf ,state ,arg-temp))))
+         (return-from ,block-name ,state)))))
+
+;;;; ** Switch
+
+(defmacro switch ((obj &key (test #'eql)) &body clauses)
+  "Evaluate the first clause whose car satisfies (funcall test
+  car obj)."
+  ;; NB: There is no need to do the find-if and the remove here, we
+  ;; can just as well do them with in the expansion
+  (let ((default-clause (find-if (lambda (c) (eq t (car c))) clauses)))
+    (when default-clause
+      (setf clauses (remove default-clause clauses :test #'equalp)))
+    (let ((obj-sym (gensym))
+          (test-sym (gensym)))
+      `(let ((,obj-sym ,obj)
+             (,test-sym ,test))
+         (cond
+           ,@(mapcar (lambda (clause)
+                       (let ((keys (ensure-list (car clause)))
+                             (form (cdr clause)))
+                         `((or ,@(mapcar (lambda (key)
+					   `(funcall ,test-sym ',key ,obj-sym))
+					 keys))
+			   , at form)))
+                     clauses)
+           ,@(when default-clause
+                   `((t ,@(cdr default-clause)))))))))
+
+(defmacro eswitch ((obj &key (test #'eql)) &body body)
+  "Like switch but signals an error if no clause succeeds."
+  (rebinding (obj test)
+    `(switch (,obj :test ,test)
+       , at body
+       (t
+        (error "Unmatched SWITCH. Testing against ~S with ~S."
+               ,obj ,test)))))
+
+(defmacro cswitch ((obj &key (test #'eql)) &body body)
+  "Like SWITCH but signals a continuable error if no clause
+  matches."
+  (rebinding (obj test)
+    `(switch (,obj :test ,test)
+       , at body
+       (t
+        (cerror "Unmatched SWITCH. Testing against ~S with ~S."
+                ,obj ,test)))))
+
+;;;; ** Eliminating Nesting
+
+(defmacro with* (&body body)
+  (cond
+    ((cddr body)
+     (append (first body) `((with* ,@(cdr body)))))
+    ((cdr body)
+     `(,@(first body) ,(second body)))
+    (body (first body))
+    (t nil)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/hash.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,105 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Convience functions for working with hash tables.
+
+(defun build-hash-table (hash-spec inital-contents)
+  "Create a hash table containing ``INITAL-CONTENTS``."
+  (let ((ht (apply #'make-hash-table hash-spec)))
+    (dolist* ((key value) inital-contents)
+      (setf (gethash key ht) value))
+    ht))
+
+(defmacro deflookup-table
+    (name &key (var    (make-lookup-name name "*" name "*"))
+               (reader (make-lookup-name name "GET-" name))
+               (writer (make-lookup-name name "GET-" name))
+               (rem-er (make-lookup-name name "REM-" name))
+               (at-redefinition :warn)
+               (documentation
+                (format nil "Global var for the ~S lookup table" name))
+               (test 'eql)
+               (initial-contents nil))
+  "Creates a hash table and the associated accessors."
+  ;; if they explicitly pass in NIL we make the name a gensym
+  (unless var
+    (setf var    (gensym (strcat "var for " name " lookup table "))))
+  (unless reader
+    (setf reader (gensym (strcat "reader for " name " lookup table "))))
+  (unless writer
+    (setf writer (gensym (strcat "writer for " name " lookup table "))))
+  (assert (symbolp name) (name)
+          "The name of the lookup table must be a symbol.")
+  (assert (symbolp var) (var)
+          "The name of the underlying var must be a symbol.")
+  (assert (symbolp reader) (reader)
+          "The name of the reader for a lookup table must be a symbol.")
+  (assert (symbolp writer) (writer)
+          "The name of the writer for a lookup table must be a symbol.")
+  `(progn
+     (defvar ,var
+       (build-hash-table '(:test ,test) ,initial-contents)
+       ,documentation)
+     (defun ,reader (key &optional default)
+       (gethash key ,var default))
+     (defun (setf ,writer) (value key)
+       ,(when at-redefinition
+          `(when (gethash key ,var)
+             ,(case at-redefinition
+                (:warn `(warn "Redefining ~A in deflookup-table named ~S"
+                         (let ((*package* (find-package "KEYWORD")))
+                           (format nil "~S" key))
+                         ',name))
+                (t at-redefinition))))
+       (setf (gethash key ,var) value))
+     (defun ,rem-er (key)
+       (remhash key ,var))
+     (list ',name ',var ',reader '(setf ,writer) ',rem-er)))
+
+(defun make-lookup-name (name &rest parts)
+  (funcall #'intern-concat parts (symbol-package name)))
+
+(defun hash-to-alist (hash-table)
+  (loop for k being the hash-keys of hash-table
+        collect (cons k (gethash k hash-table))))
+
+(defun hash-table-keys (hash-table)
+  (loop
+     for k being the hash-keys of hash-table
+     collect k))
+
+(defun hash-table-values (hash-table)
+  (loop
+     for v being the hash-values of hash-table
+     collect v))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/http.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/http.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,255 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * HTTP/HTML utilities
+
+;;;; ** URIs/URLs
+;;;; http://www.faqs.org/rfcs/rfc2396.html
+
+(eval-always
+  (defvar *uri-escaping-ok-table* (make-array 256
+                                              :element-type 'boolean
+                                              :initial-element nil))
+  (loop
+      ;; The list of characters which don't need to be escaped when writing URIs.
+      ;; This list is inherently a heuristic, because different uri components may have
+      ;; different escaping needs, but it should work fine for http.
+      for ok-char across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.,/" do
+      (setf (aref *uri-escaping-ok-table* (char-code ok-char)) t))
+  (setf *uri-escaping-ok-table* (coerce *uri-escaping-ok-table* '(simple-array boolean (256)))))
+
+(defun escape-as-uri (string)
+  "Escapes all non alphanumeric characters in STRING following
+  the URI convention. Returns a fresh string."
+  (with-output-to-string (escaped)
+    (write-as-uri string escaped)))
+
+(defun write-as-uri (string stream)
+  (declare (type vector string)
+           (type stream stream)
+           (optimize (speed 3) (debug 0)))
+  (loop
+      for char-code :of-type (unsigned-byte 8) :across (the (vector (unsigned-byte 8))
+                                                         (string-to-octets string :utf-8)) do
+      (if (aref (the (simple-array boolean (256)) (load-time-value *uri-escaping-ok-table* t)) char-code)
+          (write-char (code-char char-code) stream)
+          (format stream "%~2,'0X" char-code))))
+
+(define-condition uri-parse-error (error)
+  ((what :initarg :what :reader uri-parse-error.what)))
+
+(define-condition expected-digit-uri-parse-error (uri-parse-error) ())
+
+(defun continue-as-is (c)
+  (declare (ignore c))
+  (awhen (find-restart 'continue-as-is)
+    (invoke-restart it)))
+
+(defun try-other-encoding (c encoding)
+  (declare (ignore c))
+  (awhen (find-restart 'try-other-encoding)
+    (invoke-restart it encoding)))
+
+(defun unescape-as-uri-non-strict (string)
+  (handler-bind ((uri-parse-error #'continue-as-is)
+                 (serious-condition #'(lambda (c)
+                                        (try-other-encoding c :iso-8859-1)) ))
+    (%unescape-as-uri string)))
+
+(defun %unescape-as-uri (input)
+  "URI unescape based on http://www.ietf.org/rfc/rfc2396.txt"
+  (declare (type string input)
+           (optimize (speed 3) (debug 0)))
+  (let ((input-length (length input)))
+    (when (zerop input-length)
+      (return-from %unescape-as-uri ""))
+    (let* ((input-index 0)
+           (output (make-array input-length :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
+      (declare (type fixnum input-length input-index))
+      (labels ((read-next-char (must-exists-p)
+                 (when (>= input-index input-length)
+                   (if must-exists-p
+                       (error 'uri-parse-error :what input)
+                       (return-from %unescape-as-uri
+                         (restart-case
+                             (octets-to-string output :utf-8)
+                           (try-other-encoding (encoding)
+                             :report "Try converting uri using other encoding"
+                             (octets-to-string output encoding))))))
+                 (prog1 (aref input input-index)
+                   (incf input-index)))
+               (write-next-byte (byte)
+                 (vector-push-extend byte output)
+                 (values))
+               (char-to-int (char)
+                 (let ((result (digit-char-p char 16)))
+                   (unless result
+                     (error 'expected-digit-uri-parse-error :what char))
+                   result))
+               (parse ()
+                 (let ((next-char (read-next-char nil)))
+                   (case next-char
+                     (#\% (char%))
+                     (#\+ (char+))
+                     (t (write-next-byte (char-code next-char))))
+                   (parse)))
+               (char% ()
+                 (let ((restart-input-index input-index))
+                   (restart-case
+                    (write-next-byte (+ (ash (char-to-int (read-next-char t)) 4)
+                                        (char-to-int (read-next-char t))))
+                    (continue-as-is ()
+                                    :report "Continue reading uri without attempting to convert the escaped-code to a char."
+                                    (setf input-index restart-input-index)
+                                    (write-next-byte #.(char-code #\%)))))
+                 (values))
+               (char+ ()
+                 (write-next-byte #.(char-code #\Space))))
+        (parse)))))
+
+(declaim (inline unescape-as-uri))
+(defun unescape-as-uri (string)
+  (%unescape-as-uri string))
+
+(declaim (inline nunescape-as-uri))
+(defun nunescape-as-uri (string)
+  (%unescape-as-uri string))
+
+
+
+;;;; ** HTML
+
+;;;; This so blatently wrong its not even funny, and while this is
+;;;; exactly what I need I would do well to start using a "real" html
+;;;; escaping library (there are a couple to choose from).
+
+(defun make-html-entities ()
+  (let ((ht (make-hash-table :test 'equalp)))
+    (flet ((add-mapping (char escaped)
+             (setf (gethash char ht) escaped
+                   (gethash escaped ht) char)))
+      (add-mapping #\< "&lt;")
+      (add-mapping #\> "&gt;")
+      (add-mapping #\& "&amp;")
+      (add-mapping #\" "&quot;")
+      (add-mapping #\space "&nbsp;")
+      (add-mapping "a`" "&#224;")
+      (add-mapping "a'" "&#225;")
+      (add-mapping "e`" "&#232;")
+      (add-mapping "e'" "&#233;")
+      (add-mapping "i'" "&#236;")
+      (add-mapping "i`" "&#237;")
+      (add-mapping "o`" "&#242;")
+      (add-mapping "o'" "&#243;")
+      (add-mapping "u`" "&#249;")
+      (add-mapping "u'" "&#250;"))
+    ht))
+
+(defparameter *html-entites* (make-html-entities))
+
+(defun html-entity->char (entity &optional (default #\?))
+  (let ((res (gethash entity *html-entites*)))
+    (if res
+        (if (stringp res)
+            (char res 0)
+            res)
+        default)))
+
+(defun write-as-html (string &key (stream t) (escape-whitespace nil))
+  (loop
+     for char across string
+     do (cond
+          ((char= char #\Space)
+           (if escape-whitespace
+               (princ "&nbsp;" stream)
+               (write-char char stream)))
+          ((gethash char *html-entites*)
+           (princ (gethash char *html-entites*) stream))
+          (t (write-char char stream)))))
+
+(defun escape-as-html (string &key (escape-whitespace nil))
+  (with-output-to-string (escaped)
+    (write-as-html string
+                   :stream escaped
+                   :escape-whitespace escape-whitespace))) 
+
+(define-condition html-escape-error (error)
+  ((what :accessor html-escape-error.what :initarg :what)))
+
+(define-condition unterminated-html-entity (html-escape-error)
+  ())
+
+(define-condition unknown-html-entity (html-escape-error)
+  ())
+
+(define-condition unknown-char-escape (warning)
+  ((what :accessor html-escape-error.what :initarg :what)))
+
+(defun unescape-as-html (string)
+  (with-output-to-string (unescaped)
+    (loop
+       for offset upfrom 0 below (length string)
+       for char = (aref string offset)
+       if (char= #\& char)
+         do (progn
+              (aif (position #\; string :start offset)
+                   (let ((escape-tag (subseq string offset (1+ it))))
+                     (aif (gethash escape-tag *html-entites*)
+                          (progn
+                            (princ it unescaped)
+                            (incf offset (1- (length escape-tag))))
+                          (if (char= #\# (aref escape-tag 1))
+                              ;; special code, ignore
+                              (restart-case
+                                  (warn 'unknown-char-escape :what escape-tag)
+                                (continue-delete ()
+                                  :report "Continue processing, delete this char."
+                                  (incf offset (1- (length escape-tag)))))
+                              (restart-case
+                                  (error 'unknown-html-entity :what escape-tag)
+                                (continue-as-is ()
+                                  :report "Continue processing, leaving the string as is."
+                                  (write-char #\& unescaped))
+                                (continue-delete ()
+                                  :report "Continue processing, delete this entity."
+                                  (incf offset (1- (length escape-tag))))))))
+                   (restart-case
+                       (error 'unterminated-html-entity
+                              :what (subseq string offset
+                                            (min (+ offset 20)
+                                                 (length string))))
+                     (continue-as-is ()
+                       :report "Continue processing, leave the string as is."
+                       (write-char #\& unescaped)))))
+       else do (write-char char unescaped))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/io.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/io.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,156 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Utilites for file system I/O
+
+(defmacro with-input-from-file ((stream-name file-name &rest args &key
+                                             (direction nil direction-provided-p)
+                                             external-format
+                                             &allow-other-keys)
+                                &body body)
+  "Evaluate BODY with STREAM-NAME bound to an
+  input-stream from file FILE-NAME. ARGS is passed
+  directly to open."
+  (declare (ignore direction))
+  (when direction-provided-p
+    (error "Can't specifiy :DIRECTION in WITH-INPUT-FILE."))
+  (remf-keywords args :external-format)
+  `(with-open-file (,stream-name ,file-name :direction :input
+                    ,@(when external-format
+                        `(:external-format
+                          ,(if (keywordp external-format)
+                               `(encoding-keyword-to-native ,external-format)
+                               external-format)))
+                    , at args)
+     , at body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args &key
+                                             (direction nil direction-provided-p)
+                                             external-format
+                                             &allow-other-keys)
+                               &body body)
+  "Evaluate BODY with STREAM-NAME to an output stream
+  on the file named FILE-NAME. ARGS is sent as is to
+  the call te open."
+  (declare (ignore direction))
+  (when direction-provided-p
+    (error "Can't specifiy :DIRECTION in WITH-OUTPUT-FILE."))
+  (remf-keywords args :external-format)
+  `(with-open-file (,stream-name ,file-name :direction :output
+                    ,@(when external-format
+                        `(:external-format
+                          ,(if (keywordp external-format)
+                               `(encoding-keyword-to-native ,external-format)
+                               external-format)))
+                    , at args)
+     , at body))
+
+(defun read-string-from-file (pathname &key (buffer-size 4096)
+                                            (element-type 'character)
+                                            (external-format :us-ascii))
+  "Return the contents of PATHNAME as a fresh string.
+
+The file specified by PATHNAME will be read one ELEMENT-TYPE
+element at a time, the EXTERNAL-FORMAT and ELEMENT-TYPEs must be
+compatible.
+
+The EXTERNAL-FORMAT parameter will be passed to
+ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to
+possible values."
+  (with-input-from-file
+      (file-stream pathname :external-format (encoding-keyword-to-native external-format))
+    (with-output-to-string (datum) 
+      (let ((buffer (make-array buffer-size :element-type element-type)))
+	(loop for bytes-read = (read-sequence buffer file-stream)
+	      do (write-sequence buffer datum :start 0 :end bytes-read)
+	      while (= bytes-read buffer-size))))))
+
+(defun write-string-to-file (string pathname &key (if-exists :error)
+                                                  (if-does-not-exist :error)
+                                                  (external-format :us-ascii))
+  "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed to
+ENCODING-KEYWORD-TO-NATIVE, see ENCODING-KEYWORD-TO-NATIVE to
+possible values."
+  (with-output-to-file (file-stream pathname :if-exists if-exists
+                                    :if-does-not-exist if-does-not-exist
+                                    :external-format (encoding-keyword-to-native external-format))
+    (write-sequence string file-stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+                               (element-type '(unsigned-byte 8)))
+  (with*
+   (with-input-from-file (input  from :element-type element-type))
+   (with-output-to-file  (output to   :element-type element-type
+                                      :if-exists if-to-exists))
+   (progn
+     (copy-stream input output))))
+
+(defun copy-stream (input output &optional (element-type (stream-element-type input)))
+  "Reads data from FROM and writes it to TO. Both FROM and TO
+  must be streams, they will be passed to
+  read-sequence/write-sequence and must have compatable
+  element-types."
+  (loop
+     with buffer-size = 4096
+     with buffer = (make-array buffer-size :element-type element-type)
+     for bytes-read = (read-sequence buffer input)
+     while (= bytes-read buffer-size)
+     do (write-sequence buffer output)
+     finally (write-sequence buffer output :end bytes-read)))
+
+(defmacro defprint-object ((self class-name &key (identity t) (type t) with-package
+                                 (muffle-errors t))
+                           &body body)
+  "Define a print-object method using print-unreadable-object.
+  An example:
+  (defprint-object (self parenscript-dispatcher)
+    (when (cachep self)
+      (princ \"cached\")
+      (princ \" \"))
+    (princ (parenscript-file self)))"
+  (with-unique-names (stream)
+    `(defmethod print-object ((,self ,class-name) ,stream)
+      (print-unreadable-object (,self ,stream :type ,type :identity ,identity)
+        (let ((*standard-output* ,stream))
+          (block printing
+            (,@(if muffle-errors
+                   `(handler-bind ((error (lambda (error)
+                                            (declare (ignore error))
+                                            (write-string "<<error printing object>>")
+                                            (return-from printing)))))
+                   `(progn))
+               (let (,@(when with-package `((*package* ,(find-package with-package)))))
+                 , at body))))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lambda-list.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,92 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Lambda-lists
+
+(defun extract-argument-names (lambda-list &key allow-specializers)
+  "Returns a list of symbols representing the names of the
+  variables bound by the lambda list LAMBDA-LIST."
+  (mapcan (lambda (argument)
+	    (let1 vars '()
+	      (dolist (slot-name '(name supplied-p-parameter))
+		(awhen (and (slot-exists-p argument slot-name)
+			    (slot-boundp   argument slot-name)
+			    (slot-value    argument slot-name))
+		  (push it vars)))
+	      (nreverse vars)))
+	  (walk-lambda-list lambda-list nil '() :allow-specializers allow-specializers)))
+
+(defun convert-to-generic-lambda-list (defmethod-lambda-list)
+  (loop
+     with generic-lambda-list = '()
+     for arg in (walk-lambda-list defmethod-lambda-list
+                                  nil nil
+                                  :allow-specializers t)
+     do (etypecase arg
+          ((or required-function-argument-form
+               specialized-function-argument-form)
+           (push (name arg) generic-lambda-list))
+          (keyword-function-argument-form
+           (pushnew '&key generic-lambda-list)
+           (if (keyword-name arg)
+               (push (list (list (keyword-name arg)
+                                 (name arg)))
+                     generic-lambda-list)
+               (push (list (name arg)) generic-lambda-list)))
+          (rest-function-argument-form
+           (push '&rest generic-lambda-list)
+           (push (name arg) generic-lambda-list))
+          (optional-function-argument-form
+           (pushnew '&optional generic-lambda-list)
+           (push (name arg) generic-lambda-list))
+          (allow-other-keys-function-argument-form
+           (unless (member '&key generic-lambda-list)
+             (push '&key generic-lambda-list))
+           (push '&allow-other-keys generic-lambda-list)))
+     finally (return (nreverse generic-lambda-list))))
+
+(defun clean-argument-list (lambda-list)
+  (loop
+     for head on lambda-list
+     for argument = (car head)
+     if (member argument '(&optional &key &rest &allow-other-keys))
+       return (append cleaned head)
+     else
+       collect (if (listp argument)
+                   (first argument)
+                   argument)
+       into cleaned
+     finally (return cleaned)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; Copyright (c)      2006, Hoan Ton-That
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor
+;;    BESE, nor the names of its contributors may be used to endorse
+;;    or promote products derived from this software without specific
+;;    prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lambda.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,120 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Higher order functions
+
+(defun compose (f1 &rest functions)
+  "Returns a function which applies the arguments in order.
+
+ (funcall (compose #'list #'+) 1 2 3) ==> (6)"
+  (case (length functions)
+    (0 f1)
+    (1 (lambda (&rest args)
+         (funcall f1 (apply (car functions) args))))
+    (2 (lambda (&rest args)
+         (funcall f1
+                  (funcall (first functions)
+                           (apply (second functions) args)))))
+    (3 (lambda (&rest args)
+         (funcall f1
+                  (funcall (first functions)
+                           (funcall (second functions)
+                                    (apply (third functions) args))))))
+    (t
+     (let ((funcs (nreverse (cons f1 functions))))
+       (lambda (&rest args)
+         (loop
+            for f in funcs
+            for r = (multiple-value-list (apply f args))
+               then (multiple-value-list (apply f r))
+            finally (return (values-list r))))))))
+
+(defun conjoin (&rest predicates)
+  (case (length predicates)
+    (0 (constantly t))
+    (1 (car predicates))
+    (2 (lambda (&rest args)
+         (and (apply (first predicates) args)
+              (apply (second predicates) args))))
+    (3 (lambda (&rest args)
+         (and (apply (first predicates) args)
+              (apply (second predicates) args)
+              (apply (third predicates) args))))
+    (t
+     (lambda (&rest args)
+       (loop
+          for p in predicates
+          for val = (apply p args)
+          while val
+          finally (return val))))))
+
+(defun curry (function &rest initial-args)
+  "Returns a function which will call FUNCTION passing it
+  INITIAL-ARGS and then any other args.
+
+ (funcall (curry #'list 1) 2) ==> (list 1 2)"
+  (lambda (&rest args)
+    (apply function (append initial-args args))))
+
+(defun rcurry (function &rest initial-args)
+  "Returns a function which will call FUNCTION passing it the
+  passed args and then INITIAL-ARGS.
+
+ (funcall (rcurry #'list 1) 2) ==> (list 2 1)"
+  (lambda (&rest args)
+    (apply function (append args initial-args))))
+
+(defun noop (&rest args)
+  "Do nothing."
+  (declare (ignore args))
+  (values))
+
+(defmacro lambda-rec (name args &body body)
+  "Just like lambda except BODY can make recursive calls to the
+  lambda by calling the function NAME."
+  `(lambda ,args
+     (labels ((,name ,args , at body))
+       (,name , at args))))
+
+;;;; ** Just for fun
+
+(defun y (lambda)
+  (funcall (lambda (f)
+             (funcall (lambda (g)
+                        (funcall g g))
+                      (lambda (x)
+                        (funcall f
+                                 (lambda ()
+                                   (funcall x x))))))
+           lambda))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lexenv.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,588 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Portable lexical environment access
+
+(defgeneric environment-p (environment)
+  (:documentation "Returns T if ENVIRONMENT is a lexical
+  environment object (something suitable for passing to
+  macroexpand-1 or similar)"))
+
+(defgeneric lexical-variables (environment)
+  (:documentation "Return the names of all the local variables
+  in ENVIRONMENT. Does not return neither symbol-macrolets nor
+  ignared variables."))
+
+(defgeneric lexical-functions (environment)
+  (:documentation "Returns the names of all the local functions
+  in ENVIRONMENT. Names may be symbols of lists of the form (setf
+  name)."))
+
+(defgeneric lexical-macros (environment)
+  (:documentation "Returns the lexical macro definitions in
+  ENVIRONMENT. The return value is a list of elements of form
+  (SYMBOL . MACRO-FUNCTION. MACRO-FUNCTION can be called like
+  functions returned by macro-function."))
+
+(defgeneric lexical-symbol-macros (environment)
+  (:documentation "Returns the lexical symbol macro definitions 
+  in ENVIRONMENT. The return value is a list of elements of form
+  (SYMBOL . EXPANSION)."))
+
+(defmethod lexical-variables ((environment t))
+  '())
+
+(defmethod lexical-functions ((environment t))
+  '())
+
+(defmethod lexical-macros ((environment t))
+  '())
+
+(defmethod lexical-symbol-macros ((environment t))
+  '())
+
+;;;; ** OpenMCL
+
+#+openmcl
+(defmethod environment-p ((e ccl::lexical-environment))
+  t)
+
+#+openmcl
+(defmethod lexical-variables ((environment ccl::lexical-environment))
+  (loop
+     for env = environment
+          then (ccl::lexenv.parent-env env)
+     while (and env
+                (not (ccl::istruct-typep env 'ccl::definition-environment)))
+     for vars = (ccl::lexenv.variables env)
+     when (listp vars)
+     ;; we now weed out all symbol-macros and ignored variables
+     append (remove-if (lambda (var-name)
+                         (let ((decs (assoc var-name (ccl::lexenv.vdecls env))))
+                           (and decs
+                                (eql 'cl:ignore (second decs))
+                                (eql 'cl:t (cddr decs)))))
+                       (mapcar (lambda (var)
+                                 ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
+                                 (ccl::var-name var))
+                               (remove-if (lambda (var-spec)
+                                            (and (ccl::var-ea var-spec)
+                                                 (consp (ccl::var-ea var-spec))
+                                                 (eql :symbol-macro (car (ccl::var-ea var-spec)))))
+                                          vars)))))
+
+#+openmcl
+(defmethod lexical-functions ((environment ccl::lexical-environment))
+  (loop
+     for env = environment
+          then (ccl::lexenv.parent-env env)
+     while (and env
+                (not (ccl::istruct-typep env 'ccl::definition-environment)))
+     for funs = (ccl::lexenv.functions env)
+     when (listp funs)
+     ;; we now weed out all symbol-macros and ignored variables
+     append (mapcar (lambda (func-spec)
+                      ;; convert the function name to a "real" function name
+                      (let ((name (first func-spec)))
+                        (if (eql (symbol-package (first func-spec))
+                                 (find-package :SETF))
+                            (list 'cl:setf (read-from-string (symbol-name name)))
+                            name)))
+                    (remove-if (lambda (func-spec)
+                                 ;; weed out all the macrolets
+                                 (eql 'ccl::macro (second func-spec)))
+                               funs))))
+
+;;;; ** SBCL
+ 
+#+sbcl
+(defmethod environment-p ((environment sb-kernel:lexenv))
+  t)
+
+#+sbcl
+(defmethod lexical-variables ((environment sb-kernel:lexenv))
+  (loop
+     for var-spec in (sb-c::lexenv-vars environment)
+     when (and (atom (cdr var-spec))
+               (not (and (typep (cdr var-spec) 'sb-c::lambda-var)
+			 (sb-c::lambda-var-ignorep (cdr var-spec)))))
+     collect (car var-spec)))
+
+#+sbcl
+(defmethod lexical-functions ((environment sb-kernel:lexenv))
+  (loop
+   for fun-spec in (sb-c::lexenv-funs environment)
+   when (not (consp (cdr fun-spec)))
+   collect (car fun-spec)))
+
+#+sbcl
+(defmethod lexical-macros ((environment sb-kernel:lexenv))
+  (loop
+   for mac-spec in (sb-c::lexenv-funs environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'sb-sys::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+sbcl
+(defmethod lexical-symbol-macros ((environment sb-kernel:lexenv))
+  (loop
+   for mac-spec in (sb-c::lexenv-vars environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'sb-sys::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+;;;; ** CMUCL
+
+#+cmu
+(defmethod environment-p ((environment c::lexenv))
+  t)
+
+#+cmu
+(defmethod lexical-variables ((environment c::lexenv))
+  (loop
+     for var-spec in (c::lexenv-variables environment)
+     ;; variable refs are (NAME . LAMBDA-VAR), we want to void
+     ;; symbol-macrolets which are (NAME SYSTEM:MACRO . EXPANSION)
+     when (and (atom (cdr var-spec))
+               ;; don't return ignored vars
+               (not (eq (type-of (cdr var-spec)) 'c::global-var))
+               (not (c::lambda-var-ignorep (cdr var-spec))))
+     collect (car var-spec)))
+
+#+cmu
+(defmethod lexical-functions ((environment c::lexenv))
+  (loop
+     for func-spec in (c::lexenv-functions environment)
+     ;; flet and labels function look like ((FLET ACTUAL-NAME) . STUFF)
+     if (and (consp (first func-spec))
+             (member (car (first func-spec)) '(flet labels)))
+       collect (second (first func-spec))
+     ;; macrolets look like (NAME SYSTEM:MACRO . STUFF)
+     else if (and (consp (cdr func-spec))
+                  (eql 'system:macro (second func-spec)))
+     ;; except that we don't return macros for now
+     do (progn)
+     ;; handle the case  (NAME . #<C::FUNCTIONAL>)
+     else if (typep (cdr func-spec) 'C::FUNCTIONAL)
+       collect (car func-spec)
+     ;; if we get here we're confused :(
+     else
+       do (error "Sorry, don't know how to handle the lexcial function spec ~S."
+                 func-spec)))
+
+#+cmu
+(defmethod lexical-macros ((environment c::lexenv))
+  (loop
+   for mac-spec in (c::lexenv-functions environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'system::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+#+cmu
+(defmethod lexical-symbol-macros ((environment c::lexenv))
+  (loop
+   for mac-spec in (c::lexenv-variables environment)
+   when (and (consp (cdr mac-spec))
+	     (eq 'system::macro (cadr mac-spec)))
+   collect (cons (car mac-spec) (cddr mac-spec))))
+
+;;;; ** CLISP
+
+#+clisp
+(defmethod environment-p ((environment vector))
+  (= 2 (length environment)))
+
+#+clisp
+(defun walk-vector-tree (function vector-tree)
+  (labels ((%walk (vector-tree)
+             (loop
+                for index upfrom 0 by 2
+                for tree-top = (aref vector-tree index)
+                if (null tree-top)
+                  do (return-from %walk nil)
+                else if (vectorp tree-top)
+                  do (return-from %walk
+                       (%walk tree-top))
+                else
+                  do (funcall function
+                              (aref vector-tree index)
+                              (aref vector-tree (1+ index))))))
+    (%walk vector-tree)))
+
+#+clisp
+(defmethod lexical-variables ((environment vector))
+  (let ((vars '()))
+    (when (aref environment 0)
+      (walk-vector-tree (lambda (var-name var-spec)
+                          (unless (system::symbol-macro-p var-spec)
+                            (push var-name vars)))
+                        (aref environment 0)))
+    vars))
+
+#+clisp
+(defmethod lexical-functions ((environment vector))
+  (let ((vars '()))
+    (when (aref environment 1)
+      (walk-vector-tree (lambda (func-name func-spec)
+                          (push func-name vars))
+                        (aref environment 1)))
+    vars))
+
+#+clisp
+(defmethod lexical-macros ((environment vector))
+  (let ((macros '()))
+    (when (aref environment 1)
+      (walk-vector-tree 
+       (lambda (macro-name macro-spec)
+	 (if (system::macrop macro-spec)
+	     (push (cons macro-name 
+			 (macro-function macro-name environment))
+		   macros)))
+       (aref environment 1)))
+    macros))
+
+#+clisp
+(defmethod lexical-symbol-macros ((environment vector))
+  (let (symbol-macros '())
+    (when (aref environment 0)
+      (walk-vector-tree 
+       (lambda (macro-name macro-spec)
+	 (if (system::symbol-macro-p macro-spec)
+	     (push (cons macro-name
+			 (macroexpand-1 macro-name environment))
+		   symbol-macros)))
+       (aref environment 0)))
+    symbol-macros))
+      
+;;;; ** LispWorks
+
+#+(and lispworks macosx)
+(defmethod environment-p ((environment system::augmented-environment))
+  t)
+
+#+(and lispworks macosx)
+(defmethod lexical-variables ((environment system::augmented-environment))
+  (mapcar (lambda (venv)
+            (slot-value venv 'compiler::name))
+          (remove-if (lambda (venv)
+                       ;; regular variables, the ones we're interested
+                       ;; in, appear to have a NIL in this slot.
+                       (slot-value venv 'compiler::kind))
+                     (slot-value environment 'compiler::venv))))
+
+#+(and lispworks macosx)
+(defmethod lexical-functions ((environment system::augmented-environment))
+  (mapcar #'car
+          (remove-if (lambda (fenv)
+                       ;; remove all the macros
+                       (eql 'compiler::macro (slot-value (cdr fenv) 'compiler::function-or-macro)))
+                     (slot-value environment 'compiler::fenv))))
+
+#+(and lispworks macosx)
+(defmethod environment-p ((environment compiler::environment))
+  t)
+
+#+(and lispworks macosx)
+(defmethod lexical-variables ((environment compiler::environment))
+  (mapcar (lambda (venv)
+            (slot-value venv 'compiler::name))
+          (remove-if (lambda (venv)
+                       ;; regular variables, the ones we're interested
+                       ;; in, appear to have a NIL in this slot.
+                       (slot-value venv 'compiler::kind))
+                     (slot-value environment 'compiler::venv))))
+
+#+(and lispworks macosx)
+(defmethod lexical-functions ((environment compiler::environment))
+  (mapcar #'car
+          (remove-if (lambda (fenv)
+                       ;; remove all the macros
+                       (macro-function (car fenv) environment))
+                     (slot-value environment 'compiler::fenv))))
+
+#+(and lispworks (or win32 linux))
+(defmethod environment-p ((environment lexical::environment))
+  t)
+
+#+(and lispworks (or win32 linux))
+(defun lexical-runtime-p (value)
+  (and (symbolp value)
+       (eq (symbol-package value) nil)))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-variables ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::variables)
+        if (lexical-runtime-p (cdr candidate))
+        collect (car candidate)))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-functions ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::functions)
+        if (lexical-runtime-p (cdr candidate))
+        collect (car candidate)))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-symbol-macros ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::variables)
+        unless (lexical-runtime-p (cdr candidate))
+        collect candidate))
+
+#+(and lispworks (or win32 linux))
+(defmethod lexical-macros ((environment lexical::environment))
+  (loop for candidate in (slot-value environment 'lexical::functions)
+        unless (lexical-runtime-p (cdr candidate))
+        collect candidate))
+
+;;;; ** Allegro
+
+#+(and allegro (version>= 7 0))
+(defmethod environment-p ((env sys::augmentable-environment)) t)
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-variables ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-variables
+     (lambda (symbol type rest)
+       (declare (ignore rest))
+       (when (and (eq type :lexical)
+                  (sys:variable-information symbol env))
+	 (push symbol fns)))
+     env)
+    fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-functions ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-functions
+     (lambda (name type rest)
+       (when (and (eq type :function)
+                  (sys:function-information name env))
+	 (push name fns)))
+     env)
+    fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-macros ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-functions
+     (lambda (name type rest)
+       (when (eq type :macro)
+         (push (cons name (car rest)) fns)))
+     env)
+    fns))
+
+#+(and allegro (version>= 7 0))
+(defmethod lexical-symbol-macros ((env sys::augmentable-environment))
+  (let (fns)
+    (system::map-over-environment-variables
+     (lambda (symbol type rest)
+       (when (eq type :symbol-macro)
+         (push (cons symbol (car rest)) fns)))
+     env)
+    fns))
+
+
+;; These functions are a half-assed implementation of section 8.5 in CLtL2
+;; (environment manipulation)
+;; I really don't feel like implementing THAT interface for every supported
+;; Lisp.
+
+(defgeneric augment-with-variable (env var))
+
+(defgeneric augment-with-function (env fun))
+
+(defgeneric augment-with-macro (env mac def))
+
+(defgeneric augment-with-symbol-macro (env symmac def))
+
+(defmethod augment-with-variable ((env t) var)
+  (declare (ignore var))
+  env)
+
+(defmethod augment-with-function ((env t) fun)
+  (declare (ignore fun))
+  env)
+
+(defmethod augment-with-macro ((env t) mac def)
+  (declare (ignore mac def))
+  env)
+
+(defmethod augment-with-symbol-macro ((env t) symmac def)
+  (declare (ignore symmac def))
+  env)
+
+#+sbcl
+(defmethod augment-with-variable ((env sb-kernel:lexenv) var)
+  (sb-c::make-lexenv :default env :vars (list (cons var t))))
+
+#+sbcl
+(defmethod augment-with-function ((env sb-kernel:lexenv) fun)
+  (sb-c::make-lexenv :default env :funs (list (cons fun t))))
+
+#+sbcl
+(defmethod augment-with-macro ((env sb-kernel:lexenv) mac def)
+  (sb-c::make-lexenv :default env :funs (list (list* mac 'sb-sys::macro def))))
+
+#+sbcl
+(defmethod augment-with-symbol-macro ((env sb-kernel:lexenv) symmac def)
+  (sb-c::make-lexenv :default env :vars (list (list* symmac 'sb-sys::macro def))))
+
+#+cmu
+(defmethod augment-with-variable ((env c::lexenv) var)
+  (c::make-lexenv :default env 
+		  :variables (list (cons var (c::make-lambda-var :name var)))))
+
+#+cmu
+(defmethod augment-with-function ((env c::lexenv) fun)
+  (c::make-lexenv :default env 
+		  :functions (list (cons fun (lambda () 42)))))
+
+#+cmu
+(defmethod augment-with-macro ((env c::lexenv) mac def)
+  (c::make-lexenv :default env 
+		  :functions (list (list* mac 'system::macro def))))
+
+#+cmu
+(defmethod augment-with-symbol-macro ((env c::lexenv) symmac def)
+  (c::make-lexenv :default env 
+		  :variables (list (list* symmac 'system::macro def))))
+
+
+#+clisp
+(defun augment-with-var-and-fun (env &key var fun)
+  (let* ((old-vars (aref env 0))
+	 (old-funs (aref env 1))
+	 (new-vars (if (eq var nil)
+		       (make-array '(1) :initial-contents (list old-vars))
+		       (make-array '(3) :initial-contents (list (car var) (cdr var) old-vars))))
+	 (new-funs (if (eq fun nil)
+		       (make-array '(1) :initial-contents (list old-funs))
+		       (make-array '(3) :initial-contents (list (car fun) (cdr fun) old-funs)))))
+    (make-array '(2) :initial-contents (list new-vars new-funs))))
+
+;; I don't know whether t is an acceptable value to store here,
+;; but CLISP does not complain.
+#+clisp
+(defmethod augment-with-variable ((env vector) var)
+  (augment-with-var-and-fun env :var (cons var t)))
+
+#+clisp
+(defmethod augment-with-function ((env vector) fun)
+  (augment-with-var-and-fun env :fun (cons fun t)))
+
+#+clisp
+(defmethod augment-with-macro ((env vector) mac def)
+  (augment-with-var-and-fun env :fun (cons mac (system::make-macro def))))
+
+#+clisp
+(defmethod augment-with-symbol-macro ((env vector) symmac def)
+  (augment-with-var-and-fun env :var
+			    (cons symmac 
+				  (system::make-symbol-macro def))))
+
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-variable ((env lexical::environment) var)
+  (harlequin-common-lisp:augment-environment
+   env :variable (list var)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-function ((env lexical::environment) fun)
+  (harlequin-common-lisp:augment-environment
+   env :function (list fun)))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-macro ((env lexical::environment) mac def)
+  (harlequin-common-lisp:augment-environment
+   env :macro (list (list mac def))))
+
+#+(and lispworks (or win32 linux))
+(defmethod augment-with-symbol-macro ((env lexical::environment) symmac def)
+  (harlequin-common-lisp:augment-environment
+   env :symbol-macro (list (list symmac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-variable ((env sys::augmentable-environment) var)
+  (system:augment-environment env :variable (list var)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-function ((env sys::augmentable-environment) fun)
+  (system:augment-environment env :function (list fun)))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-macro ((env sys::augmentable-environment) mac def)
+  (system:augment-environment env :macro (list (list mac def))))
+
+#+(and allegro (version>= 7 0))
+(defmethod augment-with-symbol-macro ((env sys::augmentable-environment) symmac def)
+  (system:augment-environment env :symbol-macro (list (list symmac def))))
+
+
+(defun macroexpand-all (form &optional env)
+  (unwalk-form (walk-form form nil (make-walk-env env))))
+
+;; Sort of parse-macro from CLtL2.
+
+(defun parse-macro-definition (name lambda-list body env)
+  (declare (ignore name))
+  (let* ((environment-var nil) 
+	 (lambda-list-without-environment
+	  (loop 
+	   for prev = nil then i
+	   for i in lambda-list
+	   if (not (or (eq '&environment i) (eq '&environment prev)))
+	   collect i
+	   if (eq '&environment prev)
+	   do (if (eq environment-var nil)
+		  (setq environment-var i)
+		  (error "Multiple &ENVIRONMENT clauses in macro lambda list: ~S" lambda-list))))
+	 (handler-env (if (eq environment-var nil) (gensym "ENV-") environment-var))
+	 whole-list lambda-list-without-whole)
+    (if (eq '&whole (car lambda-list-without-environment))
+	(setq whole-list (list '&whole (second lambda-list-without-environment))
+	      lambda-list-without-whole (cddr lambda-list-without-environment))
+	(setq whole-list '()
+	      lambda-list-without-whole lambda-list-without-environment))
+    (eval
+     (with-unique-names (handler-args form-name)
+       `(lambda (,handler-args ,handler-env)
+          ,@(if (eq environment-var nil) 
+              `((declare (ignore ,handler-env)))
+              nil)
+          (destructuring-bind (, at whole-list ,form-name , at lambda-list-without-whole)
+              ,handler-args
+            (declare (ignore ,form-name))
+            ,@(mapcar (lambda (form) (macroexpand-all form env)) body)))))))
+
+    
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/lisp1.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,255 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Entry point
+
+(defgeneric lisp1 (form)
+  (:documentation "Translate FORM from Lisp-1 to Lisp-2.
+
+Define methods on this generic function with DEFLISP1-WALKER."))
+
+(defmethod lisp1 (form)
+  "If FORM isn't a FORM object, we'll convert it to one, apply
+the transformation and convert it back."
+  (unwalk-form (lisp1 (walk-form form))))
+
+(defmacro with-lisp1 (form)
+  "Execute FORM as if it were run in a Lisp-1."
+  (lisp1 form))
+
+(defmacro deflisp1-walker (class (&rest slots) &body body)
+  "Define a Lisp-1 to Lisp-2 walker.
+
+It takes the class of a CL form object, and its slots as
+arguments.  It also captures the variable FORM for convenience."
+  `(defmethod lisp1 ((form ,class))
+     (with-slots ,slots form
+       , at body)))
+
+;;;; * Special Variables
+
+(defvar *bound-vars* nil
+  "When walking code, this variable contains a list of
+variables (represented by symbols) which have been bound in
+the variable namespace.
+
+In essence these variables do not have to be sharp-quoted.")
+
+(defvar *bound-funs* nil
+  "When walking code, this variable contains a list of
+variables (represented by symbols) which have been bound in
+the function namespace.
+
+In essence these variables must be sharp-quoted.")
+
+(defmacro with-bound-vars (vars &body body)
+  "Execute BODY with VARS added to the variable namespace and
+VARS removed from the function namespace.
+
+This should only be used when code-walking."
+  `(let ((*bound-vars* (append         *bound-vars* ,vars))
+	 (*bound-funs* (set-difference *bound-funs* ,vars)))
+     , at body))
+
+(defmacro with-bound-funs (funs &body body)
+  "Execute BODY with FUNS added to the function namespace and
+FUNS removed from the variable namespace.
+
+This should only be used when code-walking."  
+  `(let ((*bound-funs* (append         *bound-funs* ,funs))
+	 (*bound-vars* (set-difference *bound-vars* ,funs)))
+     , at body))
+
+;;;; * Definers
+
+(defmacro defun1 (name (&rest args) &body body)
+  "Define a function with BODY written in Lisp-1 style.
+
+This is just like DEFUN."
+  (with-bound-vars (extract-argument-names args :allow-specializers nil)
+    `(defun ,name ,args
+       ,(lisp1 `(block ,name , at body)))))
+
+(defmacro defmethod1 (name (&rest args) &body body)
+  "Define a method with BODY written in Lisp-1 style.
+
+This is just like DEFMETHOD."
+  (with-bound-vars (extract-argument-names args :allow-specializers t)
+    `(defmethod ,name ,args
+       ,(lisp1 `(block ,name , at body)))))
+
+;;;; * Utils
+
+(defun lisp1s (forms)
+  "Convert a list of forms to Lisp-1 style."
+  (mapcar #'lisp1 forms))
+
+(defun lisp1b (binds)
+  "Convert an alist of (VAR . FORM) to Lisp-1 style."
+  (mapcar (lambda (bind)
+	    (cons (car bind)
+		  (lisp1 (cdr bind))))
+	  binds))
+
+;;;; * Walkers
+
+(deflisp1-walker form ()
+  ;; By default all forms will stay the same.
+  form)
+
+(deflisp1-walker if-form (consequent then else)
+  ;; Transform the test and branches recursively.
+  (new 'if-form
+       :consequent (lisp1 consequent)
+       :then       (lisp1 then)
+       :else       (lisp1 else)))
+
+(deflisp1-walker lambda-function-form (arguments body)
+  ;; For any function-form (ie lambda), we just transform the body.
+  ;; We also must add the parameters to the variable namespace, and
+  ;; remove the parameters from the function namespace.
+  (with-bound-vars (mapcar #'name arguments)
+    (new 'lambda-function-form
+	 :arguments arguments
+	 :body      (lisp1s body))))
+
+(deflisp1-walker variable-reference (name)
+  ;; If a free variable is bound in the toplevel, *and* not bound by
+  ;; an enclosing lambda, then we'll return that function.  Also, if
+  ;; the variable has been bound by an enclosing function binding form
+  ;; then we'll return that function.  We take advantage of the fact
+  ;; that the `name' slot is shared.
+  (if (or (and (fboundp name) (not (member name *bound-vars*)))
+	  (member name *bound-funs*))
+      (change-class form 'free-function-object-form)
+      form))
+
+(deflisp1-walker application-form (operator arguments)
+  ;; We transform all applications so they use explicit funcall.  We
+  ;; also must take into account ((a b) c ...) which must also
+  ;; transform the operator accordingly.
+  (new 'free-application-form
+       :operator  'funcall
+       :arguments (cons (if (not (typep operator 'form))
+			    (lisp1 (walk-form operator))
+			    (lisp1 operator))
+			(lisp1s arguments))))
+
+(deflisp1-walker function-binding-form (binds body)
+  ;; Add all the bindings to the function namespace to be sharp
+  ;; quoted.
+  (with-bound-funs (mapcar #'car binds)
+    (new (class-name-of form)
+	 :binds (lisp1b binds)
+	 :body  (lisp1s body))))
+
+(deflisp1-walker variable-binding-form (binds body)
+  ;; Add all the bindings to the variable namespace so they aren't
+  ;; sharp-quoted.
+  (with-bound-vars (mapcar #'car binds)
+    (new (class-name-of form)
+	 :binds (lisp1b binds)
+	 :body  (lisp1s body))))
+
+;; Walking all the other Common Lisp forms is rather straight-forward.
+
+(deflisp1-walker setq-form (var value)
+  (new 'setq-form
+       :var   var
+       :value (lisp1 value)))
+
+(deflisp1-walker progn-form (body)
+  (new 'progn-form
+       :body (lisp1s body)))
+
+(deflisp1-walker progv-form (vars-form values-form)
+  (new 'progv-form
+       :vars-form   vars-form
+       :values-form (lisp1s values-form)))
+
+(deflisp1-walker block-form (name body)
+  (new 'block-form
+       :name name
+       :body (lisp1s body)))
+
+(deflisp1-walker return-from-form (target-block result)
+  (new 'return-from-form
+       :target-block target-block
+       :result       (lisp1 result)))
+
+(deflisp1-walker catch-form (tag body)
+  (new 'catch-form
+       :tag  tag
+       :body (lisp1s body)))
+
+(deflisp1-walker throw-form (tag value)
+  (new 'throw-form
+       :tag   tag
+       :value (lisp1 value)))
+
+(deflisp1-walker eval-when-form (body eval-when-times)
+  (new 'eval-when-form
+       :eval-when-times eval-when-times
+       :body            (lisp1s body)))
+
+(deflisp1-walker multiple-value-call-form (func arguments)
+  (new 'multiple-value-call-form
+       :func      (lisp1  func)
+       :arguments (lisp1s arguments)))
+
+(deflisp1-walker multiple-value-prog1-form (first-form other-forms)
+  (new 'multiple-value-prog1-form
+       :first-form  (lisp1  first-form)
+       :other-forms (lisp1s other-forms)))
+
+(deflisp1-walker symbol-macrolet-form (binds body)
+  (new 'symbol-macrolet-form
+       :binds (lisp1b binds)
+       :body  (lisp1s body)))
+
+(deflisp1-walker tagbody-form (body)
+  (new 'tagbody-form
+       :body (lisp1s body)))
+
+(deflisp1-walker the-form (type-form value)
+  (new 'the-form
+       :type-form type-form
+       :value     (lisp1 value)))
+
+(deflisp1-walker unwind-protect-form (protected-form cleanup-form)
+  (new 'unwind-protect-form
+       :protected-form (lisp1  protected-form)
+       :cleanup-form   (lisp1s cleanup-form)))
+
+;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/82994055009163e9
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Hoan Ton-That, nor the names of the
+;;    contributors may be used to endorse or promote products derived
+;;    from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/list.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,223 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Working with lists
+
+(defmacro dolist* ((iterator list &optional return-value) &body body)
+  "Like DOLIST but destructuring-binds the elements of LIST.
+
+If ITERATOR is a symbol then dolist* is just like dolist EXCEPT
+that it creates a fresh binding."
+  (if (listp iterator)
+      (let ((i (gensym "DOLIST*-I-")))
+        `(dolist (,i ,list ,return-value)
+           (destructuring-bind ,iterator ,i
+             , at body)))
+      `(dolist (,iterator ,list ,return-value)
+         (let ((,iterator ,iterator))
+           , at body))))
+
+(defun ensure-list (thing)
+  "Returns THING as a list.
+
+If THING is already a list (as per listp) it is returned,
+otherwise a one element list containing THING is returned."
+  (if (listp thing)
+      thing
+      (list thing)))
+
+(defun ensure-cons (thing)
+  (if (consp thing)
+      thing
+      (cons thing nil)))
+
+(defun partition (list &rest lambdas)
+  "Split LIST into sub lists according to LAMBDAS.
+
+Each element of LIST will be passed to each element of LAMBDAS,
+the first function in LAMBDAS which returns T will cause that
+element to be collected into the corresponding list.
+
+Examples:
+
+ (partition '(1 2 3) #'oddp #'evenp) => ((1 3) (2))
+
+ (partition '(1 2 3) #'oddp t) => ((1 3) (1 2 3))
+
+ (partition '(1 2 3) #'oddp #'stringp) => ((1 3) nil)"
+  (let ((collectors (mapcar (lambda (predicate)
+                              (cons (case predicate
+                                      ((t :otherwise) 
+                                       (constantly t))
+                                      ((nil)
+                                       (constantly nil))
+                                      (t predicate))
+                                    (make-collector)))
+                            lambdas)))
+    (dolist (item list)
+      (dolist* ((test-func . collector-func) collectors)
+        (when (funcall test-func item)
+          (funcall collector-func item))))
+    (mapcar #'funcall (mapcar #'cdr collectors))))
+
+(defun partitionx (list &rest lambdas)
+  (let ((collectors (mapcar (lambda (l)
+                              (cons (if (and (symbolp l)
+					     (member l (list :otherwise t)
+                                                     :test #'string=))
+                                        (constantly t)
+                                        l)
+                                    (make-collector)))
+                            lambdas)))
+    (dolist (item list)
+      (block item
+        (dolist* ((test-func . collector-func) collectors)
+          (when (funcall test-func item)
+            (funcall collector-func item)
+            (return-from item)))))
+    (mapcar #'funcall (mapcar #'cdr collectors))))
+
+(defmacro dotree ((name tree &optional ret-val) &body body)
+  "Evaluate BODY with NAME bound to every element in TREE. Return RET-VAL."
+  (with-unique-names (traverser list list-element)
+    `(progn
+       (labels ((,traverser (,list)
+                  (dolist (,list-element ,list)
+                    (if (consp ,list-element)
+                        (,traverser ,list-element)
+                        (let ((,name ,list-element))
+                          , at body)))))
+         (,traverser ,tree)
+         ,ret-val))))
+
+(define-modify-macro push* (&rest items)
+  (lambda (list &rest items)
+    (dolist (i items)
+      (setf list (cons i list)))
+    list)
+  "Pushes every element of ITEMS onto LIST. Equivalent to calling PUSH
+  with each element of ITEMS.")
+
+(defun proper-list-p (object)
+  "Tests whether OBJECT is properlist.
+
+A proper list is a non circular cons chain whose last cdr is eq
+to NIL."
+  (or
+   (null object)
+   (and (consp object)
+	;; check if the last cdr of object is null. deal with
+	;; circular lists.
+	(loop 
+	 for turtoise = object then (cdr turtoise)
+	 for hare = (cdr object) then (cddr hare)
+	 ;; we need to agressivly check hare's cdr so that the call to
+	 ;; cddr doesn't signal an error
+	 when (eq turtoise hare) return nil
+	 when (null turtoise) return t
+	 when (null hare) return t
+	 when (not (consp hare)) return nil
+	 when (null (cdr hare)) return t
+	 when (not (consp (cdr hare))) return nil
+	 when (null (cddr hare)) return t
+	 when (not (consp (cddr hare))) return nil))))
+
+;;;; ** Simple list matching based on code from Paul Graham's On Lisp.
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (with-unique-names (val foundp)
+        (destructuring-bind ((test &rest progn) &rest others)
+            clauses
+          `(multiple-value-bind (,val ,foundp)
+               ,test
+             (if (or ,val ,foundp)
+                 (let ((it ,val))
+                   (declare (ignorable it))
+                   , at progn)
+                 (acond2 , at others)))))))
+
+(defun varsymp (x)
+  (and (symbolp x) (eq (aref (symbol-name x) 0) #\?)))
+
+(defun binding (x binds)
+  (labels ((recbind (x binds)
+             (aif (assoc x binds)
+                  (or (recbind (cdr it) binds)
+                      it))))
+    (let ((b (recbind x binds)))
+      (values (cdr b) b))))
+
+(defun list-match (x y &optional binds)
+  (acond2
+    ((or (eql x y) (eql x '_) (eql y '_))
+     (values binds t))
+    ((binding x binds) (list-match it y binds))
+    ((binding y binds) (list-match x it binds))
+    ((varsymp x) (values (cons (cons x y) binds) t))
+    ((varsymp y) (values (cons (cons y x) binds) t))
+    ((and (consp x) (consp y) (list-match (car x) (car y) binds))
+     (list-match (cdr x) (cdr y) it))
+    (t (values nil nil))))
+
+(defun vars (match-spec)
+  (let ((vars nil))
+    (labels ((find-vars (spec)
+               (cond
+                 ((null spec) nil)
+                 ((varsymp spec) (push spec vars))
+                 ((consp spec)
+                  (find-vars (car spec))
+                  (find-vars (cdr spec))))))
+      (find-vars match-spec))
+    (delete-duplicates vars)))
+
+(defmacro list-match-case (target &body clauses)
+  (if clauses
+      (destructuring-bind ((test &rest progn) &rest others)
+          clauses
+        (with-unique-names (tgt binds success)
+          `(let ((,tgt ,target))
+             (multiple-value-bind (,binds ,success)
+                 (list-match ,tgt ',test)
+               (declare (ignorable ,binds))
+               (if ,success
+                   (let ,(mapcar (lambda (var)
+                                   `(,var (cdr (assoc ',var ,binds))))
+                                 (vars test))
+                     (declare (ignorable ,@(vars test)))
+                     , at progn)
+                   (list-match-case ,tgt , at others))))))
+      nil))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/log.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,512 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Trivial logging facility
+
+;;;; A logger is a way to have the system generate a text message and
+;;;; have that messaged saved somewhere for future review. Logging can
+;;;; be used as a debugging mechanism or for just reporting on the
+;;;; status of a system.
+
+;;;; Logs are sent to a particular log category, each log category
+;;;; sends the messages it receives to its handlers. A handler's job
+;;;; is to take a message and write it somewhere. Log categories are
+;;;; organized in a hierarchy and messages sent to a log category will
+;;;; also be sent to that category's ancestors.
+
+;;;; Each log category has a log level which is used to determine
+;;;; whether are particular message should be processed or
+;;;; not. Categories inherit their log level from their ancestors. If a
+;;;; category has multiple fathers its log level is the min of the
+;;;; levels of its fathers.
+
+;;;; ** Log Levels
+
+(eval-always
+  (defconstant +dribble+ 0)
+  (defconstant +debug+   1)
+  (defconstant +info+    2)
+  (defconstant +warn+    3)
+  (defconstant +error+   4)
+  (defconstant +fatal+   5)
+
+  (defparameter *log-level-names* (coerce '(+dribble+ +debug+ +info+ +warn+ +error+ +fatal+)
+                                          'simple-vector))
+  (deflookup-table logger))
+
+(defun log-level-name-of (level)
+  (when (not (<= 0 level #.(1- (length *log-level-names*))))
+    (error "~S is an invalid log level" level))
+  (aref *log-level-names* level))
+
+;;;; ** Log Categories
+
+(defclass log-category ()
+  ((ancestors :initform '()     :accessor ancestors :initarg :ancestors
+              :documentation "The log categories this category inherits from.")
+   (children  :initform '()     :accessor children  :initarg :children
+              :documentation "The log categories which inherit from this category.")
+   (appenders :initform '()     :accessor appenders :initarg :appenders
+              :documentation "A list of appender objects this category sholud send messages to.")
+   (level     :initform nil :initarg :level :accessor level
+              :type (or null integer)
+              :documentation "This category's log level.")
+   (compile-time-level
+              :initform +dribble+ :initarg :compile-time-level :accessor compile-time-level
+              :type integer
+              :documentation "This category's compile time log level. Any log expression below this level will macro-expand to NIL.")
+   (name      :initarg :name :accessor name)))
+
+(defmethod make-load-form ((self log-category) &optional env)
+  (declare (ignore env))
+  `(let ((result (get-logger ',(name self))))
+     (assert result)
+     result))
+
+(defmethod print-object ((category log-category) stream)
+  (print-unreadable-object (category stream :type t :identity t)
+    (if (slot-boundp category 'name)
+        (format stream "~S" (name category))
+        (format stream "#<NO NAME>"))))
+
+(defmethod shared-initialize :after ((l log-category) slot-names
+                                     &key ancestors &allow-other-keys)
+  (declare (ignore slot-names))
+  (dolist (anc ancestors)
+    (pushnew l (children anc) :test (lambda (a b)
+				     (eql (name a) (name b))))))
+
+(defun log-level-setter-inspector-action-for (prompt current-level setter)
+  (lambda ()
+    (with-simple-restart
+        (abort "Abort setting log level")
+      (let ((value-string (swank::eval-in-emacs
+                           `(condition-case c
+                             (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list)))))
+                               (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level))
+                                                  :initial-value ,(string-downcase (log-level-name-of current-level))))
+                             (quit nil)))))
+        (when (and value-string
+                   (not (string= value-string "")))
+          (funcall setter (eval (let ((*package* #.(find-package :arnesi)))
+                                  (read-from-string value-string)))))))))
+
+(defmethod swank:inspect-for-emacs ((category log-category))
+  (let ((class (class-of category)))
+    (values "A log-category."
+            `("Class: " (:value ,class) (:newline)
+              "Runtime level: " (:value ,(log.level category)
+                                 ,(string (log-level-name-of (log.level category))))
+              " "
+              (:action "[set level]" ,(log-level-setter-inspector-action-for
+                                       "Set runtime log level to (evaluated): "
+                                       (log.level category)
+                                       (lambda (value)
+                                         (setf (log.level category) value))))
+              (:newline)
+              "Compile-time level: " (:value ,(log.compile-time-level category)
+                                      ,(string (log-level-name-of (log.compile-time-level category))))
+               " "
+              (:action "[set level]" ,(log-level-setter-inspector-action-for
+                                       "Set compile-time log level to (evaluated): "
+                                       (log.compile-time-level category)
+                                       (lambda (value)
+                                         (setf (log.compile-time-level category) value))))
+              (:newline)
+              ,@(swank::all-slots-for-inspector category)))))
+
+;;; Runtime levels
+(defmethod enabled-p ((cat log-category) level)
+  (>= level (log.level cat)))
+
+(defmethod log.level ((cat log-category))
+  (or (level cat)
+      (if (ancestors cat)
+          (loop for ancestor in (ancestors cat)
+                minimize (log.level ancestor))
+          (error "Can't determine level for ~S" cat))))
+
+(defmethod log.level ((cat-name symbol))
+  (log.level (get-logger cat-name)))
+
+(defmethod (setf log.level) (new-level (cat log-category)
+                             &optional (recursive t))
+  "Change the log level of CAT to NEW-LEVEL. If RECUSIVE is T the
+  setting is also applied to the sub categories of CAT."
+  (setf (slot-value cat 'level) new-level)
+  (when recursive
+    (dolist (child (children cat))
+      (setf (log.level child) new-level)))
+  new-level)
+
+(defmethod (setf log.level) (new-level (cat-name symbol) &optional (recursive t))
+  (setf (log.level (get-logger cat-name) recursive) new-level))
+
+(defmethod (setf log.level) (new-level (cat-name null) &optional (recursive t))
+  (declare (ignore new-level cat-name recursive))
+  (error "NIL does not specify a category."))
+
+;;; Compile time levels
+(defmethod compile-time-enabled-p ((cat log-category) level)
+  (>= level (log.compile-time-level cat)))
+
+(defmethod log.compile-time-level ((cat log-category))
+  (or (compile-time-level cat)
+      (if (ancestors cat)
+          (loop for ancestor in (ancestors cat)
+                minimize (log.compile-time-level ancestor))
+          (error "Can't determine compile time level for ~S" cat))))
+
+(defmethod log.compile-time-level ((cat-name symbol))
+  (log.compile-time-level (get-logger cat-name)))
+
+(defmethod (setf log.compile-time-level) (new-level (cat log-category)
+                                          &optional (recursive t))
+  "Change the compile time log level of CAT to NEW-LEVEL. If RECUSIVE is T the
+  setting is also applied to the sub categories of CAT."
+  (setf (slot-value cat 'compile-time-level) new-level)
+  (when recursive
+    (dolist (child (children cat))
+      (setf (log.compile-time-level child) new-level)))
+  new-level)
+
+(defmethod (setf log.compile-time-level) (new-level (cat-name symbol) &optional (recursive t))
+  (setf (log.compile-time-level (get-logger cat-name) recursive) new-level))
+
+(defmethod (setf log.compile-time-level) (new-level (cat-name null) &optional (recursive t))
+  (declare (ignore new-level cat-name recursive))
+  (error "NIL does not specify a category."))
+
+(defmacro with-logger-level (logger-name new-level &body body)
+  "Set the level of the listed logger(s) to NEW-LEVEL and restore the original value in an unwind-protect."
+  (cond ((consp logger-name)
+         `(with-logger-level ,(pop logger-name) ,new-level
+           ,(if logger-name
+                `(with-logger-level ,logger-name ,new-level
+                  , at body)
+                `(progn
+                  , at body))))
+        ((symbolp logger-name)
+         (with-unique-names (logger old-level)
+           `(let* ((,logger (get-logger ',logger-name))
+                   (,old-level (level ,logger)))
+             (setf (level ,logger) ,new-level)
+             (unwind-protect
+                  (progn , at body)
+               (setf (level ,logger) ,old-level)))))
+        (t (error "Don't know how to interpret ~S as a logger name" logger-name))))
+
+;;;; ** Handling Messages
+
+(defmacro with-logging-io (&body body)
+  `(let ((*print-right-margin* most-positive-fixnum)
+         (*print-readably* nil)
+         (*print-length* 64)
+         (*package* #+ecl (find-package "COMMON-LISP")
+                    #-ecl #.(find-package "COMMON-LISP")))
+    , at body))
+
+(defgeneric handle (category message level)
+  (:documentation "Message is either a string or a list. When it's a list and the first element is a string then it's processed as args to cl:format."))
+
+(defmethod handle :around ((cat log-category) message level)
+  ;; turn off line wrapping for the entire time while inside the loggers
+  (with-logging-io
+    (call-next-method)))
+
+(defmethod handle ((cat log-category) message level)
+  (if (appenders cat)
+      ;; if we have any appenders send them the message
+      (dolist (appender (appenders cat))
+	(append-message cat appender message level))
+      ;; send the message to our ancestors
+      (dolist (ancestor (ancestors cat))
+	(handle ancestor message level))))
+
+(defgeneric append-message (category log-appender message level)
+  (:method :around (category log-appender message level)
+    ;; what else should we do?
+    (ignore-errors
+      (call-next-method))))
+
+;;;; *** Stream log appender
+
+(defclass appender ()
+  ((verbosity :initform 2 :initarg :verbosity :accessor verbosity-of)))
+  
+(defclass stream-log-appender (appender)
+  ((stream :initarg :stream :accessor log-stream))
+  (:documentation "Human readable to the console logger."))
+
+(defmethod make-instance ((class (eql (find-class 'stream-log-appender)))
+                          &rest initargs)
+  (declare (ignore initargs))
+  (error "STREAM-LOG-APPENDER is an abstract class. You must use either brief-stream-log-appender or verbose-stream-log-appender objects."))
+
+(defmethod append-message :around (category (appender stream-log-appender) (message cons) level)
+  (append-message category appender (apply #'format nil message) level))
+
+(defclass brief-stream-log-appender (stream-log-appender)
+  ((last-message-year :initform 0)
+   (last-message-month :initform 0)
+   (last-message-day :initform 0))
+  (:documentation "A subclass of stream-log-appender with minimal
+  'overhead' text in log messages. This amounts to: not printing
+  the package names of log categories and log levels and a more
+  compact printing of the current time."))
+
+(defclass verbose-stream-log-appender (stream-log-appender)
+  ()
+  (:documentation "A subclass of stream-log-appender which
+  attempts to be as precise as possible, category names and log
+  level names are printed with a package prefix and the time is
+  printed in long format."))
+
+(defmethod append-message :around ((category log-category) (s stream-log-appender)
+                                   message level)
+  (restart-case
+      (call-next-method)
+    (use-*debug-io* ()
+      :report "Use the current value of *debug-io*"
+      (setf (log-stream s) *debug-io*)
+      (append-message category s message level))
+    (use-*standard-output* ()
+      :report "Use the current value of *standard-output*"
+      (setf (log-stream s) *standard-output*)
+      (append-message category s message level))
+    (silence-logger ()
+      :report "Ignore all future messages to this logger."
+      (setf (log-stream s) (make-broadcast-stream)))))
+
+(eval-always
+  (defparameter *max-category-name-length* 12))
+
+(defmethod append-message ((category log-category) (s brief-stream-log-appender)
+                           message level)
+  (multiple-value-bind (second minute hour day month year)
+      (decode-universal-time (get-universal-time))
+    (declare (ignore second))
+    (with-slots (last-message-year last-message-month last-message-day)
+        s
+      (unless (and (= year last-message-year)
+                   (= month last-message-month)
+                   (= day last-message-day))
+        (format (log-stream s) "--TIME MARK ~4,'0D-~2,'0D-~2,'0D--~%"
+                year month day)
+        (setf last-message-year year
+              last-message-month month
+              last-message-day day)))
+    (let* ((category-name (symbol-name (name category)))
+           (level-name (symbol-name level))
+           (category-length (length category-name)))
+      (format (log-stream s)
+              #.(strcat "~2,'0D:~2,'0D ~"
+                        *max-category-name-length*
+                        "@A ~7A ")
+              hour minute
+              (subseq category-name
+                      (max 0 (- category-length
+                                *max-category-name-length*))
+                      category-length)
+              (subseq level-name 1 (1- (length level-name)))))
+    (format (log-stream s) "~A~%" message)))
+
+(defmethod append-message ((category log-category) (s verbose-stream-log-appender)
+                            message level)
+  (multiple-value-bind (second minute hour date month year)
+      (decode-universal-time (get-universal-time))
+    (format (log-stream s)
+            "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D.~2,'0D ~S/~S: "
+            year month date hour minute second
+            (name category) level)
+    (format (log-stream s) "~A~%" message)))
+
+(defun make-stream-log-appender (&rest args &key (stream *debug-io*) (verbosity 2) &allow-other-keys)
+  (remf-keywords args :stream :verbosity)
+  (apply #'make-instance (case verbosity
+                           ((0 1) 'brief-stream-log-appender)
+                           (t 'verbose-stream-log-appender))
+         :stream stream
+         :verbosity verbosity
+         args))
+
+(defclass slime-repl-log-appender (appender)
+  ()
+  (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection.
+
+You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations:
+
+\(add-hook 'slime-repl-mode-hook
+          (lambda ()
+            (setf parse-sexp-lookup-properties nil)))
+"))
+
+(defun swank::present-in-emacs (value-or-values &key (separated-by " "))
+  "Present VALUE in the Emacs repl buffer of the current thread."
+  (unless (consp value-or-values)
+    (setf value-or-values (list value-or-values)))
+  (flet ((present (value)
+           (if (stringp value)
+               (swank::send-to-emacs `(:write-string ,value))
+               (let ((id (swank::save-presented-object value)))
+                 (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
+    (map nil (let ((first-time-p t))
+               (lambda (value)
+                 (when (and (not first-time-p)
+                            separated-by)
+                   (present separated-by))
+                 (present value)
+                 (setf first-time-p nil)))
+         value-or-values))
+  (values))
+
+(defmethod append-message ((category log-category) (appender slime-repl-log-appender)
+                           message level)
+  (when (swank::default-connection)
+    (swank::with-connection ((swank::default-connection))
+      (multiple-value-bind (second minute hour day month year)
+          (decode-universal-time (get-universal-time))
+        (declare (ignore second day month year))
+        (swank::present-in-emacs (format nil
+                                         "~2,'0D:~2,'0D ~A/~A: "
+                                         hour minute
+                                         (symbol-name (name category))
+                                         (symbol-name level))))
+      (if (consp message)
+          (let ((format-control (when (stringp (first message))
+                                  (first message)))
+                (args (if (stringp (first message))
+                          (rest message)
+                          message)))
+            (when format-control
+              (setf message (apply #'format nil format-control args)))
+            (swank::present-in-emacs message)
+            (awhen (and format-control
+                        (> (verbosity-of appender) 1)
+                        (remove-if (lambda (el)
+                                     (or (stringp el)
+                                         (null el)))
+                                   args))
+              (swank::present-in-emacs " (")
+              (swank::present-in-emacs it)
+              (swank::present-in-emacs ")")))
+          (swank::present-in-emacs message))
+      (swank::present-in-emacs #.(string #\Newline)))))
+
+(defun arnesi-logger-inspector-lookup-hook (form)
+  (when (symbolp form)
+    (if-bind logger (get-logger form)
+      (values logger t)
+      (when-bind logger-name (get form 'logger)
+        (when-bind logger (get-logger logger-name)
+          (values logger t))))))
+
+(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank)
+  (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it)))
+
+(defun make-slime-repl-log-appender (&rest args &key (verbosity 2))
+  (remf-keywords args :verbosity)
+  (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args))
+
+(defclass file-log-appender (stream-log-appender)
+  ((log-file :initarg :log-file :accessor log-file
+             :documentation "Name of the file to write log messages to."))
+  (:documentation "Logs to a file. the output of the file logger
+  is not meant to be read directly by a human."))
+
+(defmethod append-message ((category log-category) (appender file-log-appender)
+                           message level)
+  (with-output-to-file (log-file (log-file appender)
+				 :if-exists :append
+				 :if-does-not-exist :create)
+    (format log-file "(~S ~D ~S ~S)~%" level (get-universal-time) (name category) message)))
+
+(defun make-file-log-appender (file-name)
+  (make-instance 'file-log-appender :log-file file-name))
+
+;;;; ** Creating Loggers
+
+(defmacro deflogger (name ancestors &key compile-time-level level appender appenders documentation)
+  (declare (ignore documentation)
+           (type symbol name))
+  (unless (eq (symbol-package name) *package*)
+    (warn "When defining a logger named ~A the home package of the symbol is not *package* (not (eq ~A ~A)) "
+          (let ((*package* (find-package "KEYWORD")))
+            (format nil "~S" name))
+          (symbol-package name) *package*))
+  (when appender
+    (setf appenders (append appenders (list appender))))
+  (let ((ancestors (mapcar (lambda (ancestor-name)
+			     `(or (get-logger ',ancestor-name)
+				  (error "Attempt to define a sub logger of the undefined logger ~S."
+					 ',ancestor-name)))
+			   ancestors)))
+    (flet ((make-log-helper (suffix level)
+	     (let ((logger-macro-name (intern (strcat name "." suffix))))
+               `(progn
+                 (setf (get ',logger-macro-name 'logger) ',name)
+                 (defmacro ,logger-macro-name (message-control &rest message-args)
+                     ;; first check at compile time
+                     (if (compile-time-enabled-p (get-logger ',name) ,level)
+                         ;; then check at runtime
+                         `(progn
+                           (when (enabled-p (load-time-value (get-logger ',',name)) ,',level)
+                             ,(if message-args
+                                  `(handle (load-time-value (get-logger ',',name)) (list ,message-control , at message-args)
+                                    ',',level)
+                                  `(handle (load-time-value (get-logger ',',name)) ,message-control ',',level)))
+                           (values))
+                         (values)))))))
+      `(progn
+         (eval-when (:load-toplevel :execute)
+           (setf (get-logger ',name) (make-instance 'log-category
+                                                    :name ',name
+                                                    ,@(cond (level
+                                                             `(:level ,level))
+                                                            ((not ancestors)
+                                                             `(:level +debug+))
+                                                            (t '()))
+                                                    ,@(when compile-time-level
+                                                        `(:compile-time-level ,compile-time-level))
+                                                    :appenders (remove nil (list , at appenders))
+                                                    :ancestors (list , at ancestors))))
+	 ,(make-log-helper '#:dribble '+dribble+)
+	 ,(make-log-helper '#:debug '+debug+)
+	 ,(make-log-helper '#:info '+info+)
+	 ,(make-log-helper '#:warn '+warn+)
+	 ,(make-log-helper '#:error '+error+)
+	 ,(make-log-helper '#:fatal '+fatal+)
+        (values)))))
+
+
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/matcher.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,341 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A fare-like matchingfacility
+
+;;;; The code is written in CPS style, it's hard to understand at
+;;;; first but once you "get it" it's actually quite simple. Basically
+;;;; the idea is that at every point during a match one of two things
+;;;; can happen, the match can succeed or it can fail. What we do is
+;;;; we pass every match two functions (closures usually), one which
+;;;; specifies what to if it succeeds and one which specifies what to
+;;;; do if it fails. These two closures can refer to the original
+;;;; match parameter and hence we can easily "backtrack" if we
+;;;; fail. Another important aspect is that we explicitly pass the
+;;;; target against which to match, if we didn't do this it would be
+;;;; impossible to really backtrack.
+
+;;;; ** The matching and compiling environment
+
+(deflookup-table match-handler
+  :documentation "Table mapping symbol names to the matching function")
+
+(defstruct (match-state (:conc-name ||))
+  target
+  bindings
+  matched)
+
+(defun copy-state (orig-state
+		   &key (target nil target-supp)
+		        (bindings nil bindings-supp)
+			(matched nil matched-supp))
+  "Make a copy ORIG-STATE."
+  (make-match-state :target (if target-supp
+				target
+  			        (target orig-state))
+		    :bindings (if bindings-supp
+				  bindings
+				  (bindings orig-state))
+		    :matched (if matched-supp
+				 matched
+			         (matched orig-state))))
+
+(defmacro def-matcher (name args &body body)
+  `(progn (setf (get-match-handler ',name)
+		(lambda ,args , at body))
+	  ',name))
+
+(defmacro def-matcher-macro (name args &body body)
+  `(progn (setf (get-match-handler ',name)
+		(lambda ,args
+		  (%make-matcher (progn , at body))))
+	  ',name))
+
+;;;; ** Matching
+
+(defun make-matcher (spec)
+  "Create a matcher function from SPEC."
+  (let ((%bind-vars% '()))
+    (declare (special %bind-vars%))
+    (values (%make-matcher spec)
+	    %bind-vars%)))
+
+(defun %make-matcher (spec)
+  ;; NIL means many different things, deal with it explicitly
+  (if (eql nil spec)
+      (%make-matcher `(:eql ,spec))
+      (if (listp spec)
+          (aif (get-match-handler (car spec))
+               (apply it (cdr spec))
+               (error "Don't know how to handle ~S" spec))
+          (aif (get-match-handler spec)
+               ;; we allow :x as a an abbreviation for (:x)
+               (funcall it)
+               (if (and (symbolp spec)
+                        (not (keywordp spec)))
+                   (%make-matcher `(:bind :anything ,spec))
+                   (if (constantp spec)
+                       (%make-matcher `(:eql ,spec))
+                       (error "Don't know how to deal with ~S" spec)))))))
+
+(defun match (matcher target)
+  "Attempt to match MATCHER against TARGET. MATCHER can be either a
+function or a list."
+  (if (functionp matcher)
+      (funcall matcher
+	       (make-match-state :target target
+				 :bindings '()
+				 :matched nil)
+	       (lambda (s k q)
+		 (declare (ignore k q))
+		 (return-from match (values t
+					    (matched s)
+					    (bindings s))))
+	       (lambda (s k q)
+		 (declare (ignore s k q))
+		 (return-from match (values nil nil nil))))
+      (match (make-matcher matcher) target)))
+
+(defmacro match-case (form &rest clauses)
+  "NB: the clauses wil be compiled at macro expansion time."
+  (when clauses
+    (destructuring-bind ((spec &rest body) &rest other-clauses) clauses
+      (with-unique-names (form-sym matched-p dummy bindings)
+        (multiple-value-bind (matcher-func vars)
+	    (make-matcher spec)
+	  (declare (ignore matcher-func))
+	  `(let ((,form-sym ,form))
+	     (multiple-value-bind (,matched-p ,dummy ,bindings)
+		 (match (make-matcher ',spec) ,form-sym)
+	       (declare (ignore ,dummy) (ignorable ,bindings))
+	       (if ,matched-p
+		   (let ,vars
+		     ,@(mapcar (lambda (var-name)
+				 `(setf ,var-name (cdr (assoc ',var-name ,bindings))))
+			       vars)
+		     , at body)
+		   (match-case ,form-sym , at other-clauses)))))))))
+
+;;;; ** Matching forms
+
+(def-matcher :bind (spec var)
+  "The :bind matcher attempts to match MATCHER and bind whatever
+   MATCHER consumnd to VAR. group is equivalent to SPEC except the value
+   of matched when spec has matched will be bound to var."
+  (declare (special %bind-vars%))
+  (push var %bind-vars%)
+  (let ((spec-matcher (%make-matcher spec)))
+    (lambda (s k q)
+      (funcall spec-matcher s
+	       (lambda (s. k. q.)
+		 (declare (ignore k.))
+		 ;; SPEC succeded, bind var
+		 (funcall k (copy-state s. :bindings (cons (cons var (matched s.)) (bindings s.)))
+			  k q.))
+	       q))))
+
+(def-matcher :ref (var &key (test #'eql))
+  (lambda (s k q)
+    (if (and (assoc var (bindings s))
+	     (funcall test (target s) (cdr (assoc var (bindings s)))))
+	(funcall k (copy-state s :matched (target s))
+		 k q)
+        (funcall q s k q))))
+
+(def-matcher :alternation (a-spec b-spec)
+  (let ((a (%make-matcher a-spec))
+	(b (%make-matcher b-spec)))
+    (lambda (s k q)
+      ;; first try A
+      (funcall a s k
+	       ;; a failed, try B
+	       (lambda (s. k. q.)
+		 (declare (ignore s. k. q.))
+		 (funcall b s k q))))))
+
+(def-matcher-macro :alt (&rest possibilities)
+  (case (length possibilities)
+    (0 `(:fail))
+    (1 (car possibilities))
+    (t `(:alternation ,(car possibilities) (:alt ,@(cdr possibilities))))))
+
+(def-matcher :fail ()
+  (lambda (s k q)
+    (funcall q s k q)))
+
+(def-matcher :not (match)
+  (let ((m (%make-matcher match)))
+    (lambda (s k q)
+      (funcall m s q k))))
+
+(def-matcher :anything ()
+  (lambda (s k q)
+    (funcall k (copy-state s :matched (target s))
+	     k q)))
+
+;;;; ** Matching within a sequence
+
+(defun next-target ()
+  (declare (special *next-target*))
+  (funcall *next-target*))
+
+(defun make-greedy-star (m)
+  (lambda (s k q)
+    (if (funcall m (target s))
+        (funcall (make-greedy-star m) (copy-state s
+                                                  :matched (target s)
+                                                  :target (next-target))
+                 k (lambda (s. k. q.)
+                     (declare (ignore k. s.))
+                     (funcall k s k q.)))
+        (funcall q s k q))))
+
+(def-matcher :greedy-star (match)
+  (make-greedy-star (%make-matcher match)))
+
+;;;; ** The actual matching operators
+
+;;;; All of the above allow us to build matchers but non of them
+;;;; actually match anything.
+
+(def-matcher :test (predicate)
+  "Matches if the current matches satisfies PREDICATE."
+  (lambda (s k q)
+    (if (funcall predicate (target s))
+	(funcall k (copy-state s :matched (target s))
+		 k q)
+        (funcall q s k q))))
+
+(def-matcher-macro :test-not (predicate)
+  `(:not (:test ,predicate)))
+
+(def-matcher-macro :satisfies-p (predicate)
+  `(:test ,(lambda (target) (funcall predicate target))))
+
+(def-matcher-macro :eq (object)
+  `(:test ,(lambda (target) (eq object target))))
+
+(def-matcher-macro :eql (object)
+  `(:test ,(lambda (target) (eql object target))))
+
+(def-matcher-macro cl:quote (constant)
+  `(:eql ,constant))
+
+(def-matcher-macro :equal (object)
+  `(:test ,(lambda (target) (equal object target))))
+
+(def-matcher-macro :equalp (object)
+  `(:test ,(lambda (target) (equalp object target))))
+
+(def-matcher :cons (car-spec cdr-spec)
+  (let ((car (%make-matcher car-spec))
+	(cdr (%make-matcher cdr-spec)))
+    (lambda (s k q)
+      (if (consp (target s))
+	  (funcall car (copy-state s :target (car (target s)))
+		   (lambda (s. k. q.)
+		     (declare (ignore k.))
+		     ;; car matched, try cdr
+		     (funcall cdr (copy-state s. :target (cdr (target s)))
+			      (lambda (s.. k.. q..)
+				(declare (ignore k.. q..))
+				;; cdr matched, ok, we've matched!
+				(funcall k (copy-state s.. :matched (target s))
+					 k q))
+			      q.))
+		   q)
+	  (funcall q s k q)))))
+
+(def-matcher-macro :list (&rest items)
+  `(:list* , at items nil))
+
+(def-matcher-macro :list* (&rest items)
+  (case (length items)
+    (1 (car items))
+    (2 `(:cons ,(first items) ,(second items)))
+    (t
+     `(:cons ,(first items) (:list* ,@(cdr items))))))
+
+(def-matcher :property (key value-spec)
+  (let ((value (%make-matcher value-spec)))
+    (lambda (s k q)
+      (if (listp (target s))
+	  (aif (getf (target s) key)
+	       (funcall value (copy-state s :target it)		
+			(lambda (s. k. q.)
+			  (declare (ignore k. q.))
+			  (funcall k (copy-state s. :matched (target s))
+				   k q))
+			q)
+	       (funcall q s k q))
+	  (funcall q s k q)))))
+
+(def-matcher :accessor (type accessor value-spec)
+  (let ((value (%make-matcher value-spec)))
+    (lambda (s k q)
+      (if (typep (target s) type)
+	  (funcall value (copy-state s :target (funcall accessor (target s)))		
+		   (lambda (s. k. q.)
+		     (declare (ignore k. q.))
+		     (funcall k (copy-state s. :matched (target s))
+			      k q))
+		   q)
+	  (funcall q s k q)))))
+
+(def-matcher :and (a-spec b-spec)
+  (let ((a (%make-matcher a-spec))
+	(b (%make-matcher b-spec)))
+    (lambda (s k q)
+      (funcall a s
+	       (lambda (s. k. q.)
+		 (declare (ignore k. q.))
+		 (funcall b (copy-state s. :target (target s))
+			  k q))
+	       q))))
+
+(def-matcher-macro :plist (&rest items)
+  (case (length items)
+    (1 (error ":PLIST has been given an odd num of args."))
+    (2 `(:PROPERTY ,(first items) ,(second items)))
+    (t
+     `(:AND (:PROPERTY ,(first items) ,(second items))
+	    (:PLIST ,@(nthcdr 2 items))))))
+
+(def-matcher-macro :accessors (type &rest accs-vals)
+  (case (length accs-vals)
+    (1 (error ":ACCESSORS has been given an odd num of args."))
+    (2 `(:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals)))
+    (t
+     `(:AND (:ACCESSOR ,type ,(first accs-vals) ,(second accs-vals))
+	    (:ACCESSORS ,type ,@(nthcdr 2 accs-vals))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/mop.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,126 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Messing with the MOP
+
+;;;; The code pre-dates Pascal Costanza's closer-mop package. If
+;;;; you're looking for a compatability layer you should probably look
+;;;; there instead.
+
+(defmacro with-class-slots ((object class-name &key except) &body body)
+  "Execute BODY as if in a with-slots form containig _all_ the
+  slots of (find-clas CLASS-NAME). This macro, which is something
+  of an ugly hack, inspects the class named by CLASS-NAME at
+  macro expansion time. Should the class CLASS-NAME change form
+  containing WITH-CLASS-SLOTS must be recompiled. Should the
+  class CLASS-NAME not be available at macro expansion time
+  WITH-CLASS-SLOTS will fail."
+  (declare (ignore object class-name except body))
+  (error "Not yet implemented."))
+
+;;;; ** wrapping-standard method combination
+
+(define-method-combination wrapping-standard
+    (&key (around-order :most-specific-first)
+          (before-order :most-specific-first)
+          (primary-order :most-specific-first)
+          (after-order :most-specific-last)
+          (wrapping-order :most-specific-last)
+          (wrap-around-order :most-specific-last))
+  ((wrap-around (:wrap-around))
+   (around (:around))
+   (before (:before))
+   (wrapping (:wrapping))
+   (primary () :required t)
+   (after (:after)))
+  "Same semantics as standard method combination but allows
+\"wrapping\" methods. Ordering of methods:
+
+ (wrap-around
+   (around
+     (before)
+     (wrapping
+       (primary))
+     (after)))
+
+:warp-around, :around, :wrapping and :primary methods call the
+next least/most specific method via call-next-method (as in
+standard method combination).
+
+The various WHATEVER-order keyword arguments set the order in
+which the methods are called and be set to either
+:most-specific-last or :most-specific-first."
+  (labels ((effective-order (methods order)
+             (ecase order
+               (:most-specific-first methods)
+               (:most-specific-last (reverse methods))))
+           (call-methods (methods)
+             (mapcar (lambda (meth) `(call-method ,meth))
+                     methods)))
+    (let* (;; reorder the methods based on the -order arguments
+           (wrap-around (effective-order wrap-around wrap-around-order))
+           (around (effective-order around around-order))
+           (wrapping (effective-order wrapping wrapping-order))
+           (before (effective-order before before-order))
+           (primary (effective-order primary primary-order))
+           (after (effective-order after after-order))
+           ;; inital value of the effective call is a call its primary
+           ;; method(s)
+           (form (case (length primary)
+                   (1 `(call-method ,(first primary)))
+                   (t `(call-method ,(first primary) ,(rest primary))))))
+      (when wrapping
+        ;; wrap form in call to the wrapping methods
+        (setf form `(call-method ,(first wrapping)
+                                 (,@(rest wrapping) (make-method ,form)))))
+      (when before
+        ;; wrap FORM in calls to its before methods
+        (setf form `(progn
+                      ,@(call-methods before)
+                      ,form)))
+      (when after
+        ;; wrap FORM in calls to its after methods
+        (setf form `(multiple-value-prog1
+                        ,form
+                      ,@(call-methods after))))
+      (when around
+        ;; wrap FORM in calls to its around methods
+        (setf form `(call-method ,(first around)
+                                 (,@(rest around)
+                                    (make-method ,form)))))
+      (when wrap-around
+        (setf form `(call-method ,(first wrap-around)
+                                 (,@(rest wrap-around)
+                                    (make-method ,form)))))
+      form)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/mopp.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,340 @@
+;; -*- lisp -*-
+
+;;;; * A MOP compatibility protocol
+
+(defpackage :it.bese.arnesi.mopp
+    (:nicknames :mopp)
+    (:documentation "A MOP compatabilitly layer.
+
+This package wraps the various similar but slightly different MOP
+APIs. All the MOP symbols are exported (even those which are
+normally exported from the common-lisp package) though not all
+maybe be properly defined on all lisps.
+
+The name of the library in an acronym for \"the Meta Object
+Protocol Package\".
+
+This package is nominally part of the arnesi utility library but
+has been written so that this single file can be included in
+other applications without requiring the rest of the arnesi
+library.
+
+Implementation Notes:
+
+1) The mopp package also exports the function
+   SLOT-DEFINITION-DOCUMENTATION which while not strictly part of
+   the MOP specification really should be and is implementened on
+   most systems.
+
+2) On Lispworks (tested only lightly) the MOPP package
+   implementes an eql-specializer class and defines a version of
+   method-specializers built upon clos:method-specializers which
+   returns them.")
+    (:use)
+    (:export
+     ;; classes
+     #:standard-object
+     #:funcallable-standard-object
+     #:metaobject
+     #:generic-function
+     #:standard-generic-function
+     #:method
+     #:standard-method
+     #:standard-accessor-method
+     #:standard-reader-method
+     #:standard-writer-method
+     #:method-combination
+     #:slot-definition
+     #:direct-slot-definition
+     #:effective-slot-definition
+     #:standard-slot-definition
+     #:standard-direct-slot-definition
+     #:standard-effective-slot-definition
+     #:specializer
+     #:eql-specializer
+     #:class
+     #:built-in-class
+     #:forward-referenced-class
+     #:standard-class
+     #:funcallable-standard-class
+     ;; Taken from the MOP dictionary
+     #:accessor-method-slot-definition
+     #:add-dependent 
+     #:add-direct-method 
+     #:add-direct-subclass 
+     #:add-method 
+     #:allocate-instance
+     #:class-default-initargs
+     #:class-direct-default-initargs
+     #:class-direct-slots
+     #:class-direct-subclasses
+     #:class-direct-superclasses
+     #:class-finalized-p
+     #:class-name
+     #:class-precedence-list
+     #:class-prototype
+     #:class-slots
+     #:compute-applicable-methods 
+     #:compute-applicable-methods-using-classes 
+     #:compute-class-precedence-list 
+     #:compute-default-initargs 
+     #:compute-discriminating-function 
+     #:compute-effective-method 
+     #:compute-effective-slot-definition 
+     #:compute-slots 
+     #:direct-slot-definition-class 
+     #:effective-slot-definition-class
+     #:ensure-class-using-class 
+     #:ensure-generic-function 
+     #:ensure-generic-function-using-class 
+     #:eql-specializer-object 
+     #:extract-lambda-list 
+     #:extract-specializer-names 
+     #:finalize-inheritance 
+     #:find-method-combination 
+     #:funcallable-standard-instance-access 
+     #:generic-function-argument-precedence-order
+     #:generic-function-declarations
+     #:generic-function-lambda-list
+     #:generic-function-method-class
+     #:generic-function-method-combination
+     #:generic-function-methods
+     #:generic-function-name
+     #:intern-eql-specializer 
+     #:make-instance 
+     #:make-method-lambda 
+     #:map-dependents
+     #:method-function
+     #:method-generic-function
+     #:method-lambda-list
+     #:method-specializers
+     #:method-qualifiers
+     #:reader-method-class 
+     #:remove-dependent 
+     #:remove-direct-method 
+     #:remove-direct-subclass 
+     #:remove-method 
+     #:set-funcallable-instance-function 
+     #:slot-boundp-using-class
+     #:slot-definition-allocation
+     #:slot-definition-documentation
+     #:slot-definition-initargs
+     #:slot-definition-initform
+     #:slot-definition-initfunction
+     #:slot-definition-location
+     #:slot-definition-name
+     #:slot-definition-readers
+     #:slot-definition-writers
+     #:slot-definition-type
+     #:slot-makunbound-using-class 
+     #:slot-value-using-class 
+     #:specializer-direct-generic-functions 
+     #:specializer-direct-methods 
+     #:standard-instance-access 
+     #:update-dependent 
+     #:validate-superclass 
+     #:writer-method-class))
+
+(defpackage :it.bese.arnesi.mopp%internals
+  (:use :common-lisp))
+
+(in-package :it.bese.arnesi.mopp%internals)
+
+(defgeneric provide-mopp-symbol (symbol implementation)
+  (:documentation "Provide the implementation of the MOP symbol SYMBOL.
+
+SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp
+
+IMPLEMENTATION - A keyword indetifying the implementation, one
+of: :OPENMCL, :SBCL, :CMU, :LISPWORKS, :ALLEGRO.
+
+Do \"something\" such that the external symbol SYMBOL in the mopp
+package provides the sematics for the like named symbol in the
+MOP. Methods defined on this generic function are free to
+destructivly modify SYMBOL (and the mopp package) as long as when
+the method terminates there is a symbol with the same name as
+SYMBOL exported form the package mopp.
+
+Methods must return a true value if they have successfully
+provided SYMBOL and nil otherwise."))
+
+(defun import-to-mopp (symbol)
+  (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp)))
+    (when sym
+      (unexport sym :it.bese.arnesi.mopp)
+      (unintern sym :it.bese.arnesi.mopp)))
+  (import symbol :it.bese.arnesi.mopp)
+  (export symbol :it.bese.arnesi.mopp)
+  t)
+
+;;;; OpenMCL
+
+(defmethod provide-mopp-symbol ((symbol symbol)
+                                (implementation (eql :openmcl)))
+  "Provide MOP symbols for OpenMCL.
+
+All of OpenMCL's MOP is defined in the CCL package."
+  (when (find-symbol (string symbol) :ccl)
+    (import-to-mopp (find-symbol (string symbol) :ccl))))
+
+;;;; SBCL
+
+(defmethod provide-mopp-symbol ((symbol symbol)
+                                (implementation (eql :sbcl)))
+  (when (find-symbol (string symbol) :sb-mop)
+    (import-to-mopp (find-symbol (string symbol) :sb-mop))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+                                (implementation (eql :sbcl)))
+  "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL.
+
+On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to
+sb-pcl:documentation."
+  t)
+
+#+sbcl
+(defun mopp:slot-definition-documentation (slot)
+  (sb-pcl::documentation slot t))
+
+;;;; CMUCL
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu)))
+  (when (find-symbol (string symbol) :pcl)
+    (import-to-mopp (find-symbol (string symbol) :pcl))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+                                (implementation (eql :cmu)))
+  "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL.
+
+Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call
+to documentation."
+  t)
+
+#+cmu
+(defun mopp:slot-definition-documentation (slot)
+  (documentation slot t))
+
+;;;; Lispworks
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks)))
+  (when (find-symbol (string symbol) :clos)
+    (import-to-mopp (find-symbol (string symbol) :clos))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer))
+                                (implementation (eql :lispworks)))
+  t)
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object))
+                                (implementation (eql :lispworks)))
+  t)
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers))
+                                (implementation (eql :lispworks)))
+  "We can not simply export CLOS:METHOD-SPECIALIZERS as we have
+to insert mopp:eql-specializers"
+  t)
+
+#+lispworks
+(defclass mopp:eql-specializer ()
+  ((object :accessor mopp::eql-specializer-object :initarg :object))
+  (:documentation "Wrapper class representing eql-specializers.
+
+Lispworks does not implement an eql-specializer class but simply
+returns lists form method-specializers, this class (along with a
+wrapper for clos:method-specializers) hide this detail."))
+
+#+lispworks
+(defun mopp:method-specializers (method)
+  "More MOP-y implementation of clos:method-specializers.
+
+For every returned value of clos:method-specializers of the
+form `(eql ,OBJECT) this function returns a mopp:eql-specializer
+object wrapping OBJECT."
+  (mapcar (lambda (spec)
+            (typecase spec
+              (cons (make-instance 'mopp:eql-specializer :object (second spec)))
+              (t spec)))
+          (clos:method-specializers method)))
+
+;;;; CLISP
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :clisp)))
+  (when (find-symbol (string symbol) :clos)
+    (import-to-mopp (find-symbol (string symbol) :clos))))
+
+;;;; ALLEGRO
+
+(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :allegro)))
+  (when (find-symbol (string symbol) :mop)
+    (import-to-mopp (find-symbol (string symbol) :mop))))
+
+(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
+				(implementation (eql :allegro)))
+  t)
+
+#+allegro
+(defun mopp:slot-definition-documentation (slot)
+  (documentation slot t))
+
+;;;; ** Building the MOPP package
+
+;;;; we can't just do a do-external-symbols since we mess with the
+;;;; package and that would put us in implementation dependent
+;;;; territory, so we first build up a list of all the external symbols
+;;;; in mopp and then work on that list.
+
+#+(or
+   openmcl
+   sbcl
+   cmu
+   lispworks
+   clisp
+   allegro)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (pushnew 'mopp::have-mop *features*))
+
+#+mopp::have-mop
+(let ((external-symbols '()))
+  (do-external-symbols (sym (find-package :it.bese.arnesi.mopp))
+    (push sym external-symbols))
+  (dolist (sym external-symbols)
+    (unless (provide-mopp-symbol sym #+openmcl :openmcl
+                                     #+sbcl :sbcl
+                                     #+cmu :cmu
+                                     #+lispworks :lispworks
+                                     #+clisp :clisp
+				     #+allegro :allegro)
+      (warn "Unimplemented MOP symbol: ~S" sym))))
+
+#-mopp::have-mop
+(warn "No MOPP implementation available for this lisp implementation.")
+
+;; Copyright (C) 2004-2006 Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/numbers.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,152 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Messing with numbers
+
+(defun parse-ieee-double (u64)
+  "Given an IEEE 64 bit double representeted as an integer (ie a
+  sequence of 64 bytes), return the coressponding double value"
+  (* (expt -1 (ldb (byte 1 63) u64))
+     (expt 2 (- (ldb (byte 11 52) u64) 1023))
+     (1+ (float (loop for i from 51 downto 0
+                      for n = 2 then (* 2 n)
+                      for frac = (* (/ n) (ldb (byte 1 i) u64))
+                      sum frac)))))
+
+(defun radix-values (radix)
+  (assert (<= 2 radix 35)
+          (radix)
+          "RADIX must be between 2 and 35 (inclusive), not ~D." radix)
+  (make-array radix
+              :displaced-to "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+              :displaced-index-offset 0
+              :element-type 
+              #+lispworks 'base-char
+              #-lispworks 'character))
+
+(defun parse-float (float-string
+                    &key (start 0) (end nil) (radix 10)
+                         (junk-allowed t)
+                         (type 'single-float)
+                         (decimal-character #\.))
+  (let ((radix-array (radix-values radix))
+        (integer-part 0)
+        (mantissa 0)
+        (mantissa-size 1)
+        (sign 1))
+    (with-input-from-string (float-stream (string-upcase (string-trim '(#\Space #\Tab) float-string)) :start start :end end)
+      (labels ((peek () (peek-char nil float-stream nil nil nil))
+               (next () (read-char float-stream nil nil nil))
+               (sign () ;; reads the (optional) sign of the number
+                 (cond
+                   ((char= (peek) #\+) (next) (setf sign 1))
+                   ((char= (peek) #\-) (next) (setf sign -1)))
+                 (integer-part))
+               (integer-part ()
+                 (cond
+                   ((position (peek) radix-array)
+                    ;; the next char is a valid char
+                    (setf integer-part (+ (* integer-part radix)
+                                          (position (next) radix-array)))
+                    ;; again
+                    (return-from integer-part (integer-part)))
+                   ((null (peek))
+                    ;; end of string
+                    (done))
+                   ((char= decimal-character (peek))
+                    ;; the decimal seperator
+                    (next)
+                    (return-from integer-part (mantissa)))                   
+                   ;; junk
+                   (junk-allowed (done))
+                   (t (bad-string))))
+               (mantissa ()                 
+                 (cond
+                   ((position (peek) radix-array)
+                    (setf mantissa (+ (* mantissa radix)
+                                      (position (next) radix-array))
+                          mantissa-size (* mantissa-size radix))
+                    (return-from mantissa
+                      (mantissa)))
+                   ((or (null (peek)) junk-allowed)
+                    ;; end of string
+                    (done))
+                   (t (bad-string))))
+               (bad-string ()
+                 (error "Unable to parse ~S." float-string))
+               (done ()
+                 (return-from parse-float
+                   (coerce (* sign (+ integer-part (/ mantissa mantissa-size))) type))))
+        (sign)))))
+    
+(define-modify-macro mulf (B)
+  *
+  "SETF NUM to the result of (* NUM B).")
+
+(define-modify-macro divf (B)
+  /
+  "SETF NUM to the result of (/ NUM B).")
+
+(define-modify-macro minf (other)
+  (lambda (current other)
+    (if (< other current)
+        other
+        current))
+  "Sets the place to new-value if new-value is #'< the current value")
+
+(define-modify-macro maxf (other)
+  (lambda (current other)
+    (if (> other current)
+        other
+        current))
+  "Sets the place to new-value if new-value is #'> the current value")
+
+(defun map-range (lambda min max &optional (step 1))
+  (loop for i from min upto max by step
+     collect (funcall lambda i)))
+
+(defmacro do-range ((index &optional min max step return-value)
+                    &body body)
+  (assert (or min max)
+          (min max)
+          "Must specify at least MIN or MAX")
+  `(loop
+      for ,index ,@(when min `(from ,min))
+                 ,@(when max `(upto ,max))
+                 ,@(when step `(by ,step))
+      do (progn , at body)
+      finally (return ,return-value)))
+
+(defun 10^ (x)
+  (expt 10 x))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/one-liners.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,228 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Miscalaneous stuff
+
+(defun intern-concat (string-designators &optional (package *package*))
+  (intern (with-output-to-string (symbol-name)
+            (dolist (designator string-designators)
+              (write-string (etypecase designator
+                              (symbol (symbol-name designator))
+                              (string designator))
+                            symbol-name)))
+          package))
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+  "Evaluate BODY with BINDINGS bound to fresh unique symbols.
+
+Syntax: WITH-UNIQUE-NAMES ( [ var | (var x) ]* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;; <cy3bshuf30f.fsf at ljosa.com> by Vebjorn Ljosa - see also
+  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+  `(let ,(mapcar (lambda (binding)
+                   (check-type binding (or cons symbol))
+                   (destructuring-bind (var &optional (prefix (symbol-name var)))
+                       (if (consp binding) binding (list binding))
+                     (check-type var symbol)
+                     `(,var (gensym ,(concatenate 'string prefix "-")))))
+                 bindings)
+     , at body))
+
+(defmacro rebinding (bindings &body body)
+  "Bind each var in BINDINGS to a gensym, bind the gensym to
+var's value via a let, return BODY's value wrapped in this let.
+
+Evaluates a series of forms in the lexical environment that is
+formed by adding the binding of each VAR to a fresh, uninterned
+symbol, and the binding of that fresh, uninterned symbol to VAR's
+original value, i.e., its value in the current lexical
+environment.
+
+The uninterned symbol is created as if by a call to GENSYM with the
+string denoted by PREFIX - or, if PREFIX is not supplied, the string
+denoted by VAR - as argument.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;; <cy3wv0fya0p.fsf at ljosa.com> by Vebjorn Ljosa - see also
+  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+  (loop for binding in bindings
+        for var = (car (if (consp binding) binding (list binding)))
+        for name = (gensym)
+        collect `(,name ,var) into renames
+        collect ``(,,var ,,name) into temps
+        finally (return `(let* ,renames
+                          (with-unique-names ,bindings
+                            `(let (,, at temps)
+                               ,, at body))))))
+
+(defmacro rebind (bindings &body body)
+  `(let ,(loop
+            for symbol-name in bindings
+            collect (list symbol-name symbol-name))
+     , at body))
+
+(defmacro with-accessors* (accessor-names object &body body)
+  "Just like WITH-ACCESSORS, but if the slot-entry is a symbol
+  assume the variable and accessor name are the same."
+  `(with-accessors ,(mapcar (lambda (name)
+			      (if (consp name) 
+				  name 
+				  `(,name ,name)))
+			    accessor-names)
+       ,object
+     , at body))
+
+(defmacro define-constant (name value doc-string &optional export-p)
+  "DEFCONSTANT with extra EXPORT-P argument."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     ,(when export-p
+        `(export ',name ,(package-name (symbol-package name))))
+     (defconstant ,name ,value ,doc-string)))
+
+
+(defun register (environment type name datum &rest other-datum)
+  (cons (if other-datum
+            (list* type name datum other-datum)
+            (list* type name datum))
+        environment))
+
+(defmacro extend (environment type name datum &rest other-datum)
+  `(setf ,environment (register ,environment ,type ,name ,datum , at other-datum)))
+
+(defun lookup (environment type name &key (error-p nil) (default-value nil))
+  (loop
+     for (.type .name . data) in environment
+     when (and (eql .type type) (eql .name name))
+       return (values data t)
+     finally
+       (if error-p
+           (error "Sorry, No value for ~S of type ~S in environment ~S found."
+                  name type environment)
+           (values default-value nil))))
+
+(defun (setf lookup) (value environment type name &key (error-p nil))
+  (loop
+     for env-piece in environment
+     when (and (eql (first env-piece)  type)
+               (eql (second env-piece) name))
+       do (setf (cddr env-piece) value) and
+       return value
+     finally
+       (when error-p
+         (error "Sorry, No value for ~S of type ~S in environment ~S found."
+                name type environment))))
+
+(defun remove-keywords (plist &rest keywords)
+  "Creates a copy of PLIST without the listed KEYWORDS."
+  (declare (optimize (speed 3)))
+  (loop for cell = plist :then (cddr cell)
+        for el = (car cell)
+        while cell
+        unless (member el keywords :test #'eq)
+        collect el
+        and collect (cadr cell)
+        and do (assert (cdr cell) () "Not a proper plist")))
+
+(define-modify-macro remf-keywords (&rest keywords) remove-keywords
+  "Creates a copy of PLIST without the properties identified by KEYWORDS.")
+
+(defmacro eval-always (&body body)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     , at body))
+
+(defmacro defalias (function redefinition)
+  `(eval-always
+    (progn
+      (setf (fdefinition ',redefinition) (function ,function))
+      ',redefinition)))
+
+(defmacro defvaralias (variable redefinition)
+  `(eval-always
+    (defvar ,redefinition ,variable)))
+
+(defmacro defmacalias (macro redefinition)
+  #-allegro
+  (with-unique-names (args)
+    `(eval-always
+      (defmacro ,redefinition (&rest ,args)
+        `(,',macro ,@,args))))
+  #+allegro ;; with-unique-names is undefined in allegro, why? This is a quick fix.
+  (let ((args (gensym)))
+    `(eval-always
+      (defmacro ,redefinition (&rest ,args)
+        `(,',macro ,@,args)))))
+
+
+(defmacalias lambda fun)
+
+(defalias make-instance new)
+
+(defun append1 (list x)
+  (append list (list x)))
+
+(defun last1 (l)
+  (car (last l)))
+
+(defun flatten1 (l)
+  (reduce #'append l))
+
+(defun singlep (list)
+  (and (consp list) (not (cdr list))))
+
+(defun class-name-of (obj)
+  (class-name (class-of obj)))
+
+(defun circularize (&rest items)
+  (let ((items (copy-list items)))
+    (nconc items items)))
+
+(defmacro let1 (var val &body body)
+  `(let ((,var ,val))
+     , at body))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; Copyright (c) 2006,      Hoan Ton-That
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, Hoan Ton-That, nor
+;;    BESE, nor the names of its contributors may be used to endorse
+;;    or promote products derived from this software without specific
+;;    prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,496 @@
+;; -*- lisp -*-
+
+(in-package :common-lisp-user)
+
+;;;; * Introduction
+
+;;;; It is a collection of lots of small bits and pieces which have
+;;;; proven themselves usefull in various applications. They are all
+;;;; tested, some even have a test suite and a few are even
+;;;; documentated.
+
+(defpackage :it.bese.arnesi
+  (:documentation "The arnesi utility suite.")
+  (:nicknames :arnesi)
+  (:use :common-lisp)
+  (:export
+
+   #:clean-op
+   #:collect-timing
+
+   #:make-reducer
+   #:make-pusher
+   #:make-collector
+   #:with-reducer
+   #:with-collector
+   #:with-collectors
+
+   #:form
+   #:walk-form
+   #:make-walk-env
+   #:*walk-handlers*
+   #:*warn-undefined*
+   #:undefined-reference
+   #:undefined-variable-reference
+   #:undefined-function-reference
+   #:return-from-unknown-block
+   #:defwalker-handler
+   #:implicit-progn-mixin
+   #:implicit-progn-with-declare-mixin
+   #:binding-form-mixin
+   #:declaration-form
+   #:constant-form
+   #:variable-reference
+   #:local-variable-reference
+   #:local-lexical-variable-reference
+   #:free-variable-reference
+   #:application-form
+   #:local-application-form
+   #:lexical-application-form
+   #:free-application-form
+   #:lambda-application-form
+   #:function-form
+   #:lambda-function-form
+   #:function-object-form
+   #:local-function-object-form
+   #:free-function-object-form
+   #:lexical-function-object-form
+   #:function-argument-form
+   #:required-function-argument-form
+   #:specialized-function-argument-form
+   #:optional-function-argument-form
+   #:keyword-function-argument-form
+   #:allow-other-keys-function-argument-form
+   #:rest-function-argument-form
+   #:block-form
+   #:return-from-form
+   #:catch-form
+   #:throw-form
+   #:eval-when-form
+   #:if-form
+   #:function-binding-form
+   #:flet-form
+   #:labels-form
+   #:variable-binding-form
+   #:let-form
+   #:let*-form
+   #:locally-form
+   #:macrolet-form
+   #:multiple-value-call-form
+   #:multiple-value-prog1-form
+   #:progn-form
+   #:progv-form
+   #:setq-form
+   #:symbol-macrolet-form
+   #:tagbody-form
+   #:go-tag-form
+   #:go-form
+   #:the-form
+   #:unwind-protect-form
+   #:extract-argument-names
+   #:walk-lambda-list
+   #:walk-implict-progn
+   #:arguments
+   #:binds
+   #:body
+   #:cleanup-form
+   #:code
+   #:consequent
+   #:declares
+   #:default-value
+;; #:else ; iterate
+   #:enclosing-tagbody
+   #:eval-when-times
+   #:first-form
+   #:func
+   #:keyword-name
+   #:name
+   #:operator
+   #:optimize-spec
+   #:other-forms
+   #:parent
+   #:protected-form
+   #:read-only-p
+   #:result
+   #:source
+;; #:specializer ; closer-mop
+   #:supplied-p-parameter
+   #:tag
+   #:target-block
+   #:target-progn
+   #:then
+   #:type-form
+   #:value
+   #:values-form
+   #:var
+   #:vars-form
+
+   #:defunwalker-handler
+   #:unwalk-form
+   #:unwalk-forms
+   #:unwalk-lambda-list
+
+   #:to-cps
+   #:with-call/cc
+   #:kall
+   #:call/cc
+   #:let/cc
+   #:*call/cc-returns*
+   #:invalid-return-from
+   #:unreachable-code
+   #:defun/cc
+   #:defgeneric/cc
+   #:defmethod/cc
+   #:fmakun-cc
+   #:*debug-evaluate/cc*
+   #:*trace-cc*
+   
+   #:ppm
+   #:ppm1
+   #:apropos-list*
+   #:apropos*
+
+   #:with-input-from-file
+   #:with-output-to-file
+   #:read-string-from-file
+   #:write-string-to-file
+   #:copy-file
+   #:copy-stream
+   #:string-to-octets
+   #:octets-to-string
+   #:encoding-keyword-to-native
+   #:defprint-object
+   
+   #:if-bind
+   #:aif
+   #:when-bind
+   #:awhen
+   #:cond-bind
+   #:acond
+   #:aand
+   #:and-bind
+   #:if2-bind
+   #:aif2
+;; #:while ; iterate
+   #:awhile
+;; #:until ; iterate
+   #:it
+   #:whichever
+   #:xor
+   #:switch
+   #:eswitch
+   #:cswitch
+
+   #:build-hash-table
+   #:deflookup-table
+   #:hash-to-alist
+   #:hash-table-keys
+   #:hash-table-values
+   
+   #:write-as-uri
+   #:escape-as-uri
+   #:unescape-as-uri
+   #:nunescape-as-uri
+   #:unescape-as-uri-non-strict
+   #:uri-parse-error
+   #:expected-digit-uri-parse-error
+   #:continue-as-is
+   
+   #:write-as-html
+   #:escape-as-html
+   #:unescape-as-html
+   #:html-entity->char
+   
+   #:compose
+   #:conjoin
+   #:curry
+   #:rcurry
+   #:noop
+   #:y
+   #:lambda-rec
+
+   #:dolist*
+   #:dotree
+   #:ensure-list
+   #:ensure-cons
+   #:partition
+   #:partitionx
+   #:proper-list-p
+   #:push*
+
+   #:get-logger
+   #:log-category
+   #:stream-log-appender
+   #:brief-stream-log-appender
+   #:verbose-stream-log-appender
+   #:make-stream-log-appender
+   #:make-slime-repl-log-appender
+   #:file-log-appender
+   #:make-file-log-appender
+   #:deflogger
+   #:with-logger-level
+   #:log.level
+   #:log.compile-time-level
+   #:+dribble+
+   #:+debug+
+   #:+info+
+   #:+warn+
+   #:+error+
+   #:+fatal+
+   #:handle
+   #:append-message
+   #:ancestors
+   #:appenders
+   #:children
+   
+   #:with-unique-names
+   #:rebinding
+   #:rebind
+   #:define-constant
+   #:remove-keywords
+   #:remf-keywords
+
+   #:make-matcher
+   #:match
+   #:match-case
+   #:list-match-case
+   
+   #:parse-ieee-double
+   #:parse-float
+   #:mulf
+   #:divf
+   #:minf
+   #:maxf
+   #:map-range
+   #:do-range
+   #:10^
+   
+   #:tail
+   #:but-tail
+   #:head
+   #:but-head
+   #:starts-with
+   #:ends-with
+   #:read-sequence*
+   #:deletef
+   #:copy-array
+   #:make-displaced-array
+   
+   #:+lower-case-ascii-alphabet+
+   #:+upper-case-ascii-alphabet+
+   #:+ascii-alphabet+
+   #:+alphanumeric-ascii-alphabet+
+   #:+base64-alphabet+
+   #:random-string
+   #:strcat
+   #:strcat*
+   #:princ-csv
+   #:parse-csv-string
+   #:join-strings
+   #:fold-strings
+   #:~%
+   #:~T
+   #:+CR-LF+
+   #:~D
+   #:~A
+   #:~S
+   #:~W
+
+   #:def-special-environment
+   
+   #:intern-concat
+
+   #:vector-push-extend*
+   #:string-from-array
+
+   #:queue
+   #:enqueue
+   #:dequeue
+   #:peek-queue
+   #:queue-empty-p
+   #:queue-count
+   #:random-queue-element
+   #:queue->list
+   #:lru-queue
+   
+   ;; decimal arith
+   #:*precision*
+   #:with-precision
+   #:decimal-from-float
+   #:float-from-decimal
+   #:round-down
+   #:round-half-up
+   #:round-half-even
+   #:round-ceiling
+   #:round-floor
+   #:round-half-down
+   #:round-up
+
+   #:enable-sharp-l-syntax
+   #:enable-bracket-syntax
+   #:enable-pf-syntax
+   #:with-sharp-l-syntax
+   #:with-package
+
+   #:defclass-struct
+
+   #:with*
+
+   #:quit
+
+   #:wrapping-standard
+
+   #:levenshtein-distance
+
+   #:getenv
+
+
+   #:lisp1
+   #:with-lisp1
+   #:defun1
+   #:defmethod1
+
+   #:_
+
+   #:eval-always
+   #:defalias
+   #:defvaralias
+   #:defmacalias
+   #:fun
+   #:set
+   #:new
+   #:append1
+   #:last1
+   #:singlep
+   #:class-name-of
+   #:circularize
+   #:let1
+
+   ;; Obsolete stuff for backward compatibility. To be removed eventually.
+   #:enable-sharp-l
+   #:enable-bracket-reader
+   #:enable-pf-reader
+   ))
+
+;;;; * Colophon
+
+;;;; This documentation was produced by qbook.
+
+;;;; arnesi, and the associated documentation, is written by Edward
+;;;; Marco Baringer <mb at bese.it>.
+
+;;;; ** COPYRIGHT
+
+;;;; Copyright (c) 2002-2006, Edward Marco Baringer
+;;;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;;;; All rights reserved. 
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;  - Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+
+;;;;  - Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer in the
+;;;;    documentation and/or other materials provided with the distribution.
+
+;;;;  - Neither the name of Edward Marco Baringer, Luca Capello, nor
+;;;;    BESE, nor the names of its contributors may be used to endorse
+;;;;    or promote products derived from this software without specific
+;;;;    prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;;@include "accumulation.lisp"
+
+;;;;@include "asdf.lisp"
+
+;;;;@include "compat.lisp"
+
+;;;; / @include "cps.lisp"
+
+;;;;@include "csv.lisp"
+
+;;;;@include "debug.lisp"
+
+;;;;@include "decimal-arithmetic.lisp"
+
+;;;;@include "defclass-struct.lisp"
+
+;;;;@include "flow-control.lisp"
+
+;;;;@include "hash.lisp"
+
+;;;;@include "http.lisp"
+
+;;;;@include "io.lisp"
+
+;;;;@include "lambda.lisp"
+
+;;;;@include "list.lisp"
+
+;;;;@include "log.lisp"
+
+;;;;@include "matcher.lisp"
+
+;;;;@include "mop.lisp"
+
+;;;;@include "mopp.lisp"
+
+;;;;@include "numbers.lisp"
+
+;;;;@include "one-liners.lisp"
+
+;;;;@include "sequence.lisp"
+
+;;;;@include "sharpl-reader.lisp"
+
+;;;;@include "specials.lisp"
+
+;;;;@include "string.lisp"
+
+;;;;@include "walk.lisp"
+
+;;;;@include "vector.lisp"
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/pf-reader.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,74 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A partial application syntax
+
+;;;; Reader
+(defmacro enable-pf-syntax (&optional (open-character #\[) (close-character #\]))
+  "Enable bracket reader for the rest of the file (being loaded or compiled).
+Be careful when using in different situations, because it modifies *readtable*."
+  ;; The standard sais that *readtable* is restored after loading/compiling a file,
+  ;; so we make a copy and alter that. The effect is that it will be enabled
+  ;; for the rest of the file being processed.
+  `(eval-when (:compile-toplevel :execute)
+    (setf *readtable* (copy-readtable *readtable*))
+    (%enable-pf-reader ,open-character ,close-character)))
+
+(defun %enable-pf-reader (&optional (open-character #\[) (close-character #\]))
+  (set-macro-character  open-character #'|[-reader| t *readtable*)
+  (set-syntax-from-char close-character #\) *readtable*))
+
+(defun enable-pf-reader ()
+  "TODO Obsolete, to be removed. Use the enable-pf-syntax macro."
+  ;; (warn "Use the enable-pf-syntax macro instead of enable-pf-reader")
+  (%enable-pf-reader))
+
+(defun |[-reader| (stream char)
+  (declare (ignore char))
+  (destructuring-bind (fname &rest args)
+      (read-delimited-list #\] stream t)
+    (let* ((rest  (gensym "REST"))
+	   (count (count '_ args))
+	   (end   (if (zerop count) rest `(nthcdr ,count ,rest)))
+	   (args  (reduce (lambda (x y)
+			    (cons (if (eq x '_)
+				      `(nth ,(decf count) ,rest)
+				      x)
+				  y))
+			  args
+			  :from-end t
+			  :initial-value '())))
+      `(lambda (&rest ,rest) (apply #',fname , at args ,end)))))
+
+;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/1a86740db77b2f3a
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Hoan Ton-That, nor the names of the
+;;    contributors may be used to endorse or promote products derived
+;;    from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/posixenv.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,50 @@
+;;; -*- lisp -*-
+
+
+(in-package :it.bese.arnesi)
+
+;;;; * POSIX environment functions
+
+(defun getenv (var)
+  #+allegro (sys:getenv var)
+  #+clisp (ext:getenv var)
+  #+cmu
+  (cdr (assoc var ext:*environment-list* :test #'string=))
+  #+lispworks (lw:environment-variable var)
+  #+openmcl (ccl::getenv var)
+  #+sbcl (sb-ext:posix-getenv var)
+
+  #-(or allegro clisp cmu lispworks openmcl openmcl sbcl)
+  (error "Could not define `getenv'."))
+
+
+;; Copyright (c) 2006 Luca Capello http://luca.pca.it <luca at pca.it>
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Luca Capello, Edward Marco Baringer, nor
+;;    BESE, nor the names of its contributors may be used to endorse
+;;    or promote products derived from this software without specific
+;;    prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/queue.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,164 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Queues (FIFO)
+
+;;;; The class QUEUE represents a simple, circular buffer based, FIFO
+;;;; implementation. The two core operations are enqueue and dequeue,
+;;;; the utility method queue-count is also provided.
+
+(defclass queue ()
+  ((head-index :accessor head-index)
+   (tail-index :accessor tail-index)
+   (buffer :accessor buffer)))
+
+(defmethod initialize-instance :after
+    ((queue queue)
+     &key
+     (size 20)
+     (element-type t)
+     &allow-other-keys)
+  (assert (< 1 size)
+          (size)
+          "Initial size of a queue must be greater than 1.")
+  (setf (head-index queue) 0
+        (tail-index queue) 0
+        (buffer queue) (make-array (1+ size) :element-type element-type)))
+
+(defmethod enqueue ((queue queue) value)
+  (when (queue-full-p queue)
+    (grow-queue queue))
+  (setf (aref (buffer queue) (head-index queue)) value)
+  (move-head queue)
+  queue)
+
+(defmethod dequeue ((queue queue) &optional (default-value nil))
+  (if (queue-empty-p queue)
+      default-value
+      (prog1
+          (aref (buffer queue) (tail-index queue))
+        (move-tail queue))))
+
+(defmethod peek-queue ((queue queue))
+  (aref (buffer queue) (tail-index queue)))
+
+(defmethod queue-empty-p ((queue queue))
+  (= (head-index queue) (tail-index queue)))
+
+(defmethod queue-full-p ((queue queue))
+  (= (mod (tail-index queue) (length (buffer queue)))
+     (mod (1+ (head-index queue)) (length (buffer queue)))))
+
+(defmethod queue-count ((queue queue))
+  (let ((head-index (head-index queue))
+        (tail-index (tail-index queue)))
+    (cond
+      ((= head-index tail-index)
+       0)
+      ((< tail-index head-index)
+       (- head-index tail-index))
+      ((> tail-index head-index)
+       (- (+ (length (buffer queue)) head-index)
+          tail-index)))))
+
+(defmethod random-queue-element ((queue queue))
+  (let ((tail-index (tail-index queue))
+        (buffer (buffer queue))
+        (count (queue-count queue)))
+    (when (zerop count)
+      (error "Queue ~A is empty" queue))
+    (aref buffer (mod (+ tail-index (random count))
+                      (length buffer)))))
+
+(defmethod call-for-all-elements-with-index ((queue queue) callback)
+  "Calls CALLBACK passing it each element in QUEUE. The elements
+will be called in the same order thah DEQUEUE would return them."
+  (flet ((callback (index)
+           (funcall callback (aref (buffer queue) index) index)))
+    (if (< (head-index queue) (tail-index queue))
+        ;; growing from the bottom. conceptualy the new elements need
+        ;; to go between tail and head. it's simpler to just move them
+        ;; all
+        (progn
+          (loop
+             for index upfrom (tail-index queue) below (length (buffer queue))
+             do (callback index))
+          (loop
+             for index upfrom 0 below (head-index queue)
+             do (callback index)))
+        ;; growing from the top
+        (loop
+           for index from (tail-index queue) below (head-index queue)
+           do (callback index)))))
+
+(defmacro do-all-elements ((element queue &optional index) &body body)
+  (if index
+      `(call-for-all-elements-with-index ,queue
+                                         (lambda (,element ,index)
+                                           , at body))
+      (let ((index (gensym "do-all-elements-index-")))
+        `(call-for-all-elements-with-index ,queue
+                                           (lambda (,element ,index)
+                                             (declare (ignore ,index))
+                                             , at body)))))
+
+(defmethod grow-queue ((queue queue))
+  (let ((new-buffer (make-array (* (length (buffer queue)) 2)
+                                :element-type (array-element-type (buffer queue)))))
+    (let ((index 0))
+      (do-all-elements (element queue)
+        (setf (aref new-buffer index) element)
+        (incf index))
+      (setf (head-index queue) index
+            (tail-index queue) 0
+            (buffer queue) new-buffer))
+    queue))
+
+(defmacro incf-mod (place divisor)
+  `(setf ,place (mod (1+ ,place) ,divisor)))
+
+(defmethod move-tail ((queue queue))
+  (incf-mod (tail-index queue) (length (buffer queue))))
+
+(defmethod move-head ((queue queue))
+  (incf-mod (head-index queue) (length (buffer queue))))
+
+(defmethod print-object ((queue queue) stream)
+  (print-unreadable-object (queue stream :type t :identity t)
+    (format stream "~D" (queue-count queue))))
+
+(defmethod queue->list ((queue queue))
+  (let ((res nil))
+    (do-all-elements (element queue)
+      (push element res))
+    (nreverse res)))
+
+;;;; ** LRU Queue
+
+(defclass lru-queue (queue)
+  ()
+  (:documentation "A queue which never grows. When an element is
+  enqueued and the buffer is full we simply drop the last
+  element."))
+
+(defmethod enqueue ((queue lru-queue) value)
+  (when (queue-full-p queue)
+    (dequeue queue))
+  (call-next-method queue value))
+
+(defmethod enqueue-or-move-to-front ((queue lru-queue) element &key (test #'eql) (key #'identity))
+  "Enqueues ELEMENT, if ELEMENT is already in the queue it is
+  moved to the head.
+
+NB: this method needs a better name."
+  (do-all-elements (e queue index)
+    (when (funcall test element (funcall key e))
+      ;; found the element
+      (rotatef (aref (buffer queue) index)
+               (aref (buffer queue) (1- (if (zerop (head-index queue))
+                                            (length (buffer queue))
+                                            (head-index queue)))))
+      (return-from enqueue-or-move-to-front queue)))
+  ;; if we get here the element wasn't found
+  (enqueue queue element))

Added: branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/sequence.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,221 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Manipulating sequences
+
+(defun tail (seq &optional (how-many 1))
+  "Returns the last HOW-MANY elements of the sequence SEQ. HOW-MANY is
+  greater than (length SEQ) then all of SEQ is returned."
+  (let ((seq-length (length seq)))
+    (cond
+      ((<= 0 how-many seq-length)
+       (subseq seq (- seq-length how-many)))
+      ((< seq-length how-many)
+       (copy-seq seq))
+      (t ; (< how-many 0)
+       (head seq (- how-many))))))
+
+(defun but-tail (seq &optional (how-many 1))
+  "Returns SEQ with the last HOW-MANY elements removed."
+  (let ((seq-length (length seq)))
+    (cond
+      ((<= 0 how-many seq-length)
+       (subseq seq 0 (- seq-length how-many)))
+      ((< seq-length how-many)
+       (copy-seq seq))
+      (t
+       (but-head seq (- how-many))))))
+
+(defun head (seq &optional (how-many 1))
+  "Returns the first HOW-MANY elements of SEQ."
+  (let ((seq-length (length seq)))
+    (cond
+      ((<= 0 how-many seq-length)
+       (subseq seq 0 how-many))
+      ((< seq-length how-many)
+       (copy-seq seq))
+      (t
+       (tail seq (- how-many))))))
+
+(defun but-head (seq &optional (how-many 1))
+  "Returns SEQ with the first HOW-MANY elements removed."
+  (let ((seq-length (length seq)))
+    (cond ((<= 0 how-many (length seq))
+           (subseq seq how-many))
+          ((< seq-length how-many)
+           (copy-seq seq))
+          (t
+           (but-tail seq (- how-many))))))
+
+(defun starts-with (sequence prefix &key (test #'eql) (return-suffix nil))
+  "Test whether the first elements of SEQUENCE are the same (as
+  per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the functions returns, as a second value, a
+displaced array pointing to the sequence after PREFIX."
+  (let ((length1 (length sequence))
+        (length2 (length prefix)))
+    (when (< length1 length2)
+      (return-from starts-with (values nil nil)))
+    (dotimes (index length2)
+      (when (not (funcall test (elt sequence index) (elt prefix index)))
+        (return-from starts-with (values nil nil))))
+    ;; if we get here then we match
+    (values t
+            (if return-suffix
+                (make-array (- (length sequence) (length prefix))
+                            :element-type (array-element-type sequence)
+                            :displaced-to sequence
+                            :displaced-index-offset (length prefix)
+                            :adjustable nil)
+                nil))))
+
+(defun ends-with (seq1 seq2 &key (test #'eql))
+  "Test whether SEQ1 ends with SEQ2. In other words: return true if
+  the last (length seq2) elements of seq1 are equal to seq2."
+  (let ((length1 (length seq1))
+        (length2 (length seq2)))
+    (when (< length1 length2)
+      ;; if seq1 is shorter than seq2 than seq1 can't end with seq2.
+      (return-from ends-with nil))
+    (loop
+       for seq1-index from (- length1 length2) below length1
+       for seq2-index from 0 below length2
+       when (not (funcall test (elt seq1 seq1-index) (elt seq2 seq2-index)))
+         do (return-from ends-with nil)
+       finally (return t))))
+
+(defun read-sequence* (sequence stream &key (start 0) end)
+  "Like READ-SEQUENCE except the sequence is returned as well.
+
+The second value returned is READ-SEQUENCE's primary value, the
+primary value returned by READ-SEQUENCE* is the medified
+sequence."
+  (let ((pos (read-sequence sequence stream :start start :end end)))
+    (values sequence pos)))
+
+(defmacro deletef
+    (item sequence &rest delete-args
+     &environment e)
+  "Delete ITEM from SEQUENCE, using cl:delete, and update SEQUENCE.
+
+DELETE-ARGS are passed directly to cl:delete."
+  (multiple-value-bind (vars vals store-vars writer-form reader-form)
+      (get-setf-expansion sequence e)
+    `(let* (,@(mapcar #'list vars vals)
+            (,(car store-vars) ,reader-form))
+       (setq ,(car store-vars) (delete ,item ,(car store-vars)
+                                       , at delete-args))
+       ,writer-form)))
+
+
+(defun copy-array (array)
+  "Returns a fresh copy of ARRAY. The returned array will have
+  the same dimensions and element-type, will not be displaced and
+  will have the same fill-pointer as ARRAY.
+  
+See http://thread.gmane.org/gmane.lisp.allegro/13 for the
+original implementation and discussion."
+  (let ((dims (array-dimensions array))
+        (fill-pointer (and (array-has-fill-pointer-p array)
+                           (fill-pointer array))))
+    (adjust-array
+     (make-array dims :displaced-to array)
+     dims
+     :fill-pointer fill-pointer)))
+
+(defun make-displaced-array (array &optional (start 0) (end (length array)))
+  (make-array (- end start)
+              :element-type (array-element-type array)
+              :displaced-to array
+              :displaced-index-offset start))
+
+;;;; ** Levenshtein Distance
+
+;;;; 1) Set n to be the length of s. Set m to be the length of t. If n
+;;;;    = 0, return m and exit. If m = 0, return n and exit. Construct
+;;;;    a matrix containing 0..m rows and 0..n columns.
+
+;;;; 2) Initialize the first row to 0..n. Initialize the first column
+;;;;    to 0..m.
+
+;;;; 3) Examine each character of s (i from 1 to n).
+
+;;;; 4) Examine each character of t (j from 1 to m).
+
+;;;; 5) If s[i] equals t[j], the cost is 0. If s[i] doesn't equal
+;;;;    t[j], the cost is 1.
+
+;;;; 6) Set cell d[i,j] of the matrix equal to the minimum of: a. The
+;;;;    cell immediately above plus 1: d[i-1,j] + 1. b. The cell
+;;;;    immediately to the left plus 1: d[i,j-1] + 1. c. The cell
+;;;;    diagonally above and to the left plus the cost: d[i-1,j-1] +
+;;;;    cost.
+
+;;;; 7) After the iteration steps (3, 4, 5, 6) are complete, the
+;;;;    distance is found in cell d[n,m].
+
+(defun levenshtein-distance (source target &key (test #'eql))
+  (block nil
+    (let ((source-length (length source))
+	  (target-length (length target)))
+      (when (zerop source-length)
+	(return target-length))
+      (when (zerop target-length)
+	(return source-length))
+      (let ((buffer (make-array (1+ target-length))))
+	(dotimes (i (1+ target-length))
+	  (setf (aref buffer i) i))
+	;; we make a slight modification to the alogrithm described
+	;; above. we don't create the entire array, just enough to
+	;; keep the info we need, which is an array of size
+	;; target-length + the "above" value and the "over". (this is
+	;; similar to the optimizaiont for determining lcs).
+	(loop
+	   for i from 1 upto source-length
+	   do (setf (aref buffer 0) i)
+	   do (loop
+		 with above-value = i
+		 with over-value = (1- i)
+		 for j from 1 upto target-length
+		 for cost = (if (funcall test (elt source (1- i))
+					      (elt target (1- j)))
+				0 1)
+		 do (let ((over-value* (aref buffer j)))
+		      (setf (aref buffer j) (min (1+ above-value)
+						 (1+ (aref buffer j))
+						 (+ cost over-value))
+			    above-value (aref buffer j)
+			    over-value over-value*))))
+	(return (aref buffer target-length))))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/sharpl-reader.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,173 @@
+;; -*- lisp -*-
+
+(in-package :arnesi)
+
+;;;; * A reader macro for simple lambdas
+
+;;;; Often we have to create small (in the sense of textually short)
+;;;; lambdas. This read macro, bound to #L by default, allows us to
+;;;; eliminate the 'boilerplate' LAMBDA and concentrate on the body of
+;;;; the lambda.
+
+(defmacro sharpl-expander (package body min-args &environment env)
+  (let* ((form body)
+         (lambda-args (loop
+                         for i upfrom 1 upto (max (or min-args 0)
+                                                  (highest-bang-var form env))
+                         collect (make-sharpl-arg package i))))
+    `(lambda ,lambda-args
+       , (when lambda-args
+           `(declare (ignorable , at lambda-args)))
+       ,form)))
+
+(defun sharpL-reader (stream subchar min-args)
+  "Reader macro for simple lambdas.
+
+This read macro reads exactly one form and serves to eliminate
+the 'boiler' plate text from such lambdas and write only the body
+of the lambda itself. If the form contains any references to
+variables named !1, !2, !3, !n etc. these are bound to the Nth
+parameter of the lambda.
+
+Examples:
+
+#L(foo) ==> (lambda () (foo)).
+
+#L(foo !1) ==> (lambda (!1) (foo !1))
+
+#L(foo (bar !2) !1) ==> (lambda (!1 !2) (foo (bar !2) !1))
+
+All arguments are declared ignorable. So if there is a reference
+to an argument !X but not !(x-1) we still take X arguments, but x
+- 1 is ignored. Examples:
+
+#L(foo !2) ==> (lambda (!1 !2) (declare (ignore !1)) (foo !2))
+
+We can specify exactly how many arguments to take by using the
+read macro's prefix parameter. NB: this is only neccessary if the
+lambda needs to accept N arguments but only uses N - 1. Example:
+
+#2L(foo !1) ==> (lambda (!1 !2) (declare (ignore !2)) (foo !1))
+
+When #l forms are nested, !X variables are bound to the innermost 
+form. Example:
+
+#l#l(+ !1 !2)
+
+returns a function that takes no arguments and returns a function
+that adds its two arguments."
+  (declare (ignore subchar))
+  (let ((body (read stream t nil t)))
+    `(sharpl-expander ,*package* ,body ,min-args)))
+
+(defun with-sharp-l-syntax ()
+  "To be used with the curly reader from arnesi: {with-sharp-l-syntax #L(typep !1 'foo)}"
+  (lambda (handler)
+    (%enable-sharp-l-reader)
+    `(progn ,@(funcall handler))))
+
+(defmacro enable-sharp-l-syntax ()
+  ;; The standard sais that *readtable* is restored after loading/compiling a file,
+  ;; so we make a copy and alter that. The effect is that it will be enabled
+  ;; for the rest of the file being processed.
+  `(eval-when (:compile-toplevel :execute)
+    (setf *readtable* (copy-readtable *readtable*))
+    (%enable-sharp-l-reader)))
+
+(defun %enable-sharp-l-reader ()
+  "Bind SHARPL-READER to the macro character #L.
+
+This function overrides (and forgets) and previous value of #L."
+  (set-dispatch-macro-character #\# #\L 'sharpL-reader))
+
+(defun enable-sharp-l ()
+  "TODO: Obsolete, to be removed. Use the enable-sharp-l-syntax macro."
+  ;; (warn "Use the enable-sharp-l-syntax macro instead of enable-sharp-l")
+  (%enable-sharp-l-reader))
+
+(defun find-var-references (input-form)
+  (typecase input-form
+    (cons 
+      (append (find-var-references (car input-form))
+	      (find-var-references (cdr input-form))))
+
+    (free-variable-reference (list (slot-value input-form 'name)))
+    (local-lexical-variable-reference (list (slot-value input-form 'name)))
+      
+    (form
+     (loop for slot-name in (mapcar #'mopp:slot-definition-name 
+				    (mopp::class-slots (class-of input-form)))
+	   if (not (member slot-name '(parent target-progn enclosing-tagbody target-block)))
+	   append (find-var-references (slot-value input-form slot-name))))
+
+    (t nil)))
+
+(defun highest-bang-var (form env)
+  (let ((*warn-undefined* nil))
+    (or
+     (loop for var in (find-var-references (walk-form form nil (make-walk-env env)))
+	   if (bang-var-p var)
+	   maximize (bang-var-p var))
+     0)))
+
+(defun bang-var-p (form)
+  (and (char= #\! (aref (symbol-name form) 0))
+       (parse-integer (subseq (symbol-name form) 1) :junk-allowed t)))
+
+(defun make-sharpl-arg (package number)
+  (intern (format nil "!~D" number) package))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;; This code was heavily inspired by iterate, which has the following
+;; copyright:
+
+;;                     ITERATE, An Iteration Macro
+;;
+;;                 Copyright 1989 by Jonathan Amsterdam
+;;         Adapted to ANSI Common Lisp in 2003 by Andreas Fuchs
+;;
+;; Permission to use, copy, modify, and distribute this software and its
+;; documentation for any purpose and without fee is hereby granted,
+;; provided that this copyright and permission notice appear in all
+;; copies and supporting documentation, and that the name of M.I.T. not
+;; be used in advertising or publicity pertaining to distribution of the
+;; software without specific, written prior permission. M.I.T. makes no
+;; representations about the suitability of this software for any
+;; purpose.  It is provided "as is" without express or implied warranty.
+
+;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;; SOFTWARE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/specials.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,81 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * def-special-environment
+
+(defun check-required (name vars required)
+  (dolist (var required)
+    (assert (member var vars)
+            (var)
+            "Unrecognized symbol ~S in ~S." var name)))
+
+(defmacro def-special-environment (name (&key accessor binder binder*)
+                                  &rest vars)
+  "Define two macros for dealing with groups or related special variables.
+
+ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest
+BODY)).  Each element of VARS will be bound to the
+current (dynamic) value of the special variable.
+
+BINDER is defined as a macro for introducing (and binding new)
+special variables. It is basically a readable LET form with the
+prorpe declarations appended to the body. The first argument to
+BINDER must be a form suitable as the first argument to LET.
+
+ACCESSOR defaults to a new symbol in the same package as NAME
+which is the concatenation of \"WITH-\" NAME. BINDER is built as
+\"BIND-\" and BINDER* is BINDER \"*\"."
+  (unless accessor
+    (setf accessor (intern-concat (list '#:with- name) (symbol-package name))))
+  (unless binder
+    (setf binder   (intern-concat (list '#:bind- name) (symbol-package name))))
+  (unless binder*
+    (setf binder*  (intern-concat (list binder '#:*) (symbol-package binder))))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (flet ()
+       (defmacro ,binder (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            , at body))
+       (defmacro ,binder* (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let* ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            , at body))
+       (defmacro ,accessor (requested-vars &body body)
+         (check-required ',name ',vars requested-vars)
+         `(locally (declare (special , at requested-vars))
+            , at body))
+       ',name)))
+  
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/string.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/string.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,297 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Manipulating strings
+
+(defvar +lower-case-ascii-alphabet+
+  "abcdefghijklmnopqrstuvwxyz"
+  "All the lower case letters in 7 bit ASCII.")
+(defvar +upper-case-ascii-alphabet+
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+  "All the upper case letters in 7 bit ASCII.")
+(defvar +ascii-alphabet+
+  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+  "All letters in 7 bit ASCII.")
+(defvar +alphanumeric-ascii-alphabet+
+  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+  "All the letters and numbers in 7 bit ASCII.")
+(defvar +base64-alphabet+
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+  "All the characters allowed in base64 encoding.")
+
+(defun random-string (&optional (length 32) (alphabet +ascii-alphabet+))
+  "Returns a random alphabetic string.
+
+The returned string will contain LENGTH characters chosen from
+the vector ALPHABET.
+"
+  (loop with id = (make-string length)
+        with alphabet-length = (length alphabet)
+        for i below length
+        do (setf (cl:aref id i)
+                 (cl:aref alphabet (random alphabet-length)))
+        finally (return id)))
+
+(declaim (inline strcat))
+(defun strcat (&rest items)
+  "Returns a fresh string consisting of ITEMS concat'd together."
+  (declare (optimize speed))
+  (strcat* items))
+
+(defun strcat* (string-designators)
+  "Concatenate all the strings in STRING-DESIGNATORS."
+  (let ((*print-pretty* nil)
+        (*print-circle* nil))
+    (with-output-to-string (stream)
+      (dotree (str string-designators)
+        (when str
+          (princ str stream))))))
+
+;;; A "faster" version for string concatenating.
+;;; Could use just (apply #'concatenate 'string list), but that's quite slow
+(defun join-strings (list)
+  (let* ((length (reduce #'+ list :key #'length))
+         (result (make-string length)))
+    (loop
+       for string in list
+       for start = 0 then end
+       for end = (+ start (length string))
+       while string
+       do (replace result string :start1 start :end1 end)
+       finally (return result))))
+
+(defun fold-strings (list)
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (let ((strings '())
+        (result '()))
+    (dolist (object list)
+      (typecase object
+        (string (push object strings))
+        (t (when strings
+             (push (join-strings (nreverse strings)) result)
+             (setf strings '()))
+           (push object result))))
+    (when strings
+      (push (join-strings (nreverse strings)) result))
+    (nreverse result)))
+
+(defvar ~%
+  (format nil "~%")
+  "A string containing a single newline")
+(defvar ~T
+  (string #\Tab)
+  "A string containing a single tab character.")
+(defvar +CR-LF+
+  (make-array 2 :element-type 'character
+                :initial-contents (list (code-char #x0D)
+                                        (code-char #x0A)))
+  "A string containing the two characters CR and LF.")
+  
+(defun ~D (number &optional stream &key mincol pad-char)
+  (format stream "~v,vD" mincol pad-char number))
+
+(defun ~A (object &optional stream)
+  (format stream "~A" object))
+
+(defun ~S (object &optional stream)
+  (format stream "~S" object))
+
+(defun ~W (object &optional stream)
+  (format stream "~W" object))
+
+;;;; ** Converting strings to/from foreign encodings
+
+;;;; *** CLISP
+
+#+(and clisp unicode)
+(progn
+  (defun %encoding-keyword-to-native (encoding)
+    (ext:make-encoding
+     :charset (case encoding
+                (:utf-8    charset:utf-8)
+                (:utf-16   charset:utf-16)
+                (:us-ascii charset:ascii)
+                (t (multiple-value-bind (symbol status)
+                       (find-symbol (string encoding) (find-package :charset))
+                     (if (eq status :external)
+                         (symbol-value symbol)
+                         ;; otherwise, if SYSTEM::*HTTP-ENCODING*
+                         ;; is available, then use it
+                         #+#.(cl:if (cl:and (cl:find-package "SYSTEM")
+                                            (cl:find-symbol "*HTTP-ENCODING*" 
+                                                            (cl:find-package "SYSTEM")))
+                                    '(and) '(or))
+                         SYSTEM::*HTTP-ENCODING*
+                         ;; otherwise, use EXT:*MISC-ENCODING*
+                         #+#.(cl:if (cl:and (cl:find-package "SYSTEM")
+                                            (cl:find-symbol "*HTTP-ENCODING*" 
+                                                            (cl:find-package "SYSTEM")))
+                                    '(or) '(and))
+                         EXT:*MISC-ENCODING*))))
+     ;; These native encodings will be used for the HTTP protocol, 
+     ;; therefore we set the line-terminator to MS-DOS.
+     ;; Of course, it would be better if this was explicitely requested...
+     :line-terminator :dos
+     :input-error-action #\uFFFD
+     :output-error-action #+debug :error #-debug :ignore))
+  (defun %string-to-octets (string encoding)
+    (ext:convert-string-to-bytes string (encoding-keyword-to-native encoding)))
+  (defun %octets-to-string (octets encoding)
+    (ext:convert-string-from-bytes octets (encoding-keyword-to-native encoding))))
+
+;;;; *** SBCL
+
+#+(and sbcl sb-unicode)
+(progn
+  (defun %encoding-keyword-to-native (encoding)
+    (case encoding
+      (:utf-8 :utf8)
+      (:utf-16 :utf16)
+      (:us-ascii :us-ascii)
+      (t encoding)))
+  (defun %string-to-octets (string encoding)
+    (sb-ext:string-to-octets string :external-format (encoding-keyword-to-native encoding)))
+  (defun %octets-to-string (octets encoding)
+    (sb-ext:octets-to-string octets :external-format (encoding-keyword-to-native encoding))))
+
+;;;; *** Allegro
+
+#+allegro
+(progn
+  (defun %encoding-keyword-to-native (encoding)
+    (case encoding
+      (:utf-8 :utf8)
+      (:iso-8859-1 :iso8859-1)
+      (:utf-16 :unicode)
+      (:us-ascii :ascii)
+      (t encoding)))
+
+  (defun %string-to-octets (string encoding)
+     (excl:string-to-octets string :external-format (encoding-keyword-to-native encoding) :null-terminate nil))
+
+  (defun %octets-to-string (octets encoding)
+    (multiple-value-bind (displaced-array index) (array-displacement octets)
+      (if displaced-array
+          (excl:octets-to-string displaced-array :start index :end (+ index (length octets)) :external-format (encoding-keyword-to-native encoding))
+          (excl:octets-to-string octets :external-format (encoding-keyword-to-native encoding))))))
+
+
+;;;; *** LispWorks
+
+;; TODO this is partial. someone with a lispworks at hand should finish it.
+;; see this as an example:
+;;     (defun encode-lisp-string (string)
+;;       (translate-string-via-fli string :utf-8 :latin-1))
+;; 
+;;     (defun decode-external-string (string)
+;;       (translate-string-via-fli string :latin-1 :utf-8))
+;; 
+;;     ;; Note that a :utf-8 encoding of a null in a latin-1 string is
+;;     ;; also null, and vice versa.  So don't have to worry about
+;;     ;; null-termination or length. (If we were translating to/from
+;;     ;; :unicode, this would become an issue.)
+;; 
+;;     (defun translate-string-via-fli (string from to)
+;;       (fli:with-foreign-string (ptr elements bytes :external-format from)
+;; 	  string
+;; 	(declare (ignore elements bytes))
+;; 	(fli:convert-from-foreign-string ptr :external-format to)))
+
+#+lispworks
+(progn
+  (defun %encoding-keyword-to-native (encoding)
+    (case encoding
+      (:utf-8 :utf-8)
+      (:iso-8859-1 :latin-1)
+      (:utf-16 :unicode)
+      (:us-ascii :us-ascii)
+      (t encoding)))
+  
+  (defun %string-to-octets (string encoding)
+    (declare (ignore encoding))
+    ;; TODO
+    (map-into (make-array (length string) :element-type 'unsigned-byte)
+              #'char-code string))
+  
+  (defun %octets-to-string (octets encoding)
+    (declare (ignore encoding))
+    ;; TODO
+    (map-into (make-array (length octets) :element-type 'character)
+              #'code-char octets)))
+
+
+;;;; *** Default Implementation
+
+#-(or (and sbcl sb-unicode) (and clisp unicode) allegro lispworks)
+(progn
+  (defun %encoding-keyword-to-native (encoding)
+    encoding)
+  
+  (defun %string-to-octets (string encoding)
+    (declare (ignore encoding))
+    (map-into (make-array (length string) :element-type 'unsigned-byte)
+              #'char-code string))
+  
+  (defun %octets-to-string (octets encoding)
+    (declare (ignore encoding))
+    (map-into (make-array (length octets) :element-type 'character)
+              #'code-char octets)))
+
+(declaim (inline string-to-octets %string-to-octets))
+(defun string-to-octets (string encoding)
+  "Convert STRING, a list string, a vector of bytes according to ENCODING.
+
+ENCODING is a keyword representing the desired character
+encoding. We gurantee that :UTF-8, :UTF-16 and :ISO-8859-1 will
+work as expected. Any other values are simply passed to the
+underlying lisp's function and the results are implementation
+dependant.
+
+On CLISP we intern the ENCODING symbol in the CHARSET package and
+pass that. On SBCL we simply pass the keyword."
+  (%string-to-octets string encoding))
+
+(declaim (inline octets-to-string %octets-to-string))
+(defun octets-to-string (octets encoding)
+  (%octets-to-string octets encoding))
+
+(declaim (inline encoding-keyword-to-native))
+(defun encoding-keyword-to-native (encoding)
+  "Convert ENCODING, a keyword, to an object the native list
+accepts as an encoding.
+
+ENCODING can be: :UTF-8, :UTF-16, or :US-ASCII and specify the
+corresponding encodings. Any other keyword is passed, as is, to
+the underlying lisp."
+  (%encoding-keyword-to-native encoding))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/time.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/time.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,185 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * Programmatic interface to CL:TIME
+
+(defclass timing-info ()
+  ((real-time :accessor real-time :initarg :real-time
+              :initform :not-available
+              :documentation "Real time (also known as wall time)
+              consumed. Expressed in milliseconds.")
+   (user-time :accessor user-time :initarg :user-time
+              :initform :not-available
+              :documentation "User time. Expressed in milliseconds.")
+   (system-time :accessor system-time :initarg :system-time
+                :initform :not-available
+                :documentation "System time. Expressed in milliseconds.")
+   (gc-time :accessor gc-time :initarg :gc-time
+            :initform :not-available
+            :documentation "GC time. Expressed in milliseconds.")
+   (page-faults :accessor page-faults :initarg :page-faults
+                :initform :not-available
+                :documentation "Number of page faults.")
+   (bytes-consed :accessor bytes-consed :initarg :bytes-consed
+                 :initform :not-available
+                 :documentation "Number of bytes allocated."))
+  (:documentation "Specificer for collect-timing info.
+
+Every slot is either a number (with the exact meanining depending
+on the slot) or the keyword :not-available in the case the lisp
+doesn't provide this information."))
+
+(defun pprint-milliseconds (milliseconds &optional stream)
+  (cond
+    ((< milliseconds 1000)
+     (format stream "~D ms" milliseconds))
+    ((= milliseconds 1000)
+     (format stream "1.00 second"))
+    ((< milliseconds (* 60 1000))
+     (format stream "~,2F seconds" (/ milliseconds 1000)))
+    ((= milliseconds (* 60 1000))
+     (format stream "1.00 minute"))
+    (t
+     (format stream "~,2F minutes" (/ milliseconds (* 60 1000))))))
+
+(defun pprint-bytes (num-bytes &optional stream)
+  "Writes NUM-BYTES to stream, rounds num-bytes and appends a
+suffix depending on the size of num-bytes."
+  (cond
+    ((< num-bytes (expt 2 10))
+     (format stream "~D B" num-bytes))
+    ((< num-bytes (expt 2 20))
+     (format stream "~,2F KiB" (/ num-bytes (expt 2 10))))
+    ((< num-bytes (expt 2 30))
+     (format stream "~,2F MiB" (/ num-bytes (expt 2 20))))
+    ((< num-bytes (expt 2 40))
+     (format stream "~,2F GiB" (/ num-bytes (expt 2 30))))
+    (t
+     (format stream "~,2F TiB" (/ num-bytes (expt 2 40))))))
+
+(defmethod print-object ((info timing-info) stream)
+  (print-unreadable-object (info stream :type t :identity t)
+    (format stream "~A/~A"
+            (pprint-milliseconds (real-time info))
+            (pprint-bytes (bytes-consed info)))))
+
+(defun collect-timing (lambda)
+  "Executes LAMBDA and returns a timing-info object specifying
+  how long execution took and how much memory was used.
+
+NB: Not all implementations provide all information. See the
+various %collect-timing definitions for details."
+  (%collect-timing lambda))
+
+#+sbcl
+(defun %collect-timing (fun)
+  (declare (type function fun))
+  "Implementation of collect-timing for SBCL.
+
+This code is a cut 'n paste from sbcl/src/code/time.lisp. It uses
+internal functions, all bets off."
+  (let (old-run-utime
+        new-run-utime
+        old-run-stime
+        new-run-stime
+        old-real-time
+        new-real-time
+        old-page-faults
+        new-page-faults
+        real-time-overhead
+        run-utime-overhead
+        run-stime-overhead
+        page-faults-overhead
+        old-bytes-consed
+        new-bytes-consed
+        cons-overhead)
+    ;; Calculate the overhead...
+    (multiple-value-setq
+        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+      (sb-impl::time-get-sys-info))
+    ;; Do it a second time to make sure everything is faulted in.
+    (multiple-value-setq
+        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+      (sb-impl::time-get-sys-info))
+    (multiple-value-setq
+        (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+      (sb-impl::time-get-sys-info))
+    (setq run-utime-overhead (- new-run-utime old-run-utime))
+    (setq run-stime-overhead (- new-run-stime old-run-stime))
+    (setq page-faults-overhead (- new-page-faults old-page-faults))
+    (setq old-real-time (get-internal-real-time))
+    (setq old-real-time (get-internal-real-time))
+    (setq new-real-time (get-internal-real-time))
+    (setq real-time-overhead (- new-real-time old-real-time))
+    (setq cons-overhead (- new-bytes-consed old-bytes-consed))
+    ;; Now get the initial times.
+    (multiple-value-setq
+        (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+      (sb-impl::time-get-sys-info))
+    (setq old-real-time (get-internal-real-time))
+    (let ((start-gc-run-time sb-impl::*gc-run-time*))
+      (progn
+        ;; Execute the form and return its values.
+        (funcall fun)
+        (multiple-value-setq
+            (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+          (sb-impl::time-get-sys-info))
+        (setq new-real-time (- (get-internal-real-time) real-time-overhead))
+        (let ((gc-run-time (max (- sb-impl::*gc-run-time* start-gc-run-time) 0)))
+          (make-instance 'timing-info
+                         :real-time (max (- new-real-time old-real-time) 0.0)
+                         :user-time (max (/ (- new-run-utime old-run-utime) 1000.0) 0.0)
+                         :system-time (max (/ (- new-run-stime old-run-stime) 1000.0) 0.0)
+                         :gc-time (float gc-run-time)
+                         :page-faults (max (- new-page-faults old-page-faults) 0)
+                         :bytes-consed (max (- new-bytes-consed old-bytes-consed) 0)))))))
+
+#+openmcl
+(defun %collect-timing (lambda)
+  "Implementation of collect-timing for OpenMCL.
+
+We only report the MAJOR-PAGE-FAULTS, the number of
+MINOR-PAGE-FAULTS is ignored."
+  (let ((ccl:*report-time-function* #'list))
+    (destructuring-bind (&key elapsed-time user-time system-time
+                              gc-time bytes-allocated major-page-faults
+                              &allow-other-keys)
+        (time (funcall lambda))
+      (make-instance 'timing-info
+                     :real-time elapsed-time
+                     :user-time user-time
+                     :system-time system-time
+                     :gc-time gc-time
+                     :bytes-consed bytes-allocated
+                     :page-faults major-page-faults))))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/unwalk.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,311 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Code UnWalker
+
+;;; ** Public Entry Point
+
+(defgeneric unwalk-form (form)
+  (:documentation "Unwalk FORM and return a list representation."))
+
+(defmacro defunwalker-handler (class (&rest slots) &body body)
+  (with-unique-names (form)
+    `(progn
+       (defmethod unwalk-form ((,form ,class))
+	 (with-slots ,slots ,form
+	   , at body))
+       ',class)))
+
+(declaim (inline unwalk-forms))
+(defun unwalk-forms (forms)
+  (mapcar #'unwalk-form forms))
+
+;;;; Atoms
+
+(defunwalker-handler constant-form (value)
+  (typecase value
+    (symbol `(quote ,value))
+    (cons   `(quote ,value))
+    (t value)))
+
+(defunwalker-handler variable-reference (name)
+  name)
+
+;;;; Function Application
+
+(defunwalker-handler application-form (operator arguments)
+  (cons operator (unwalk-forms arguments)))
+
+(defunwalker-handler lambda-application-form (operator arguments)
+  ;; The cadr is for getting rid of (function ...) which we can't have
+  ;; at the beginning of a form.
+  (cons (cadr (unwalk-form operator)) (unwalk-forms arguments)))
+
+;;;; Functions
+
+(defunwalker-handler lambda-function-form (arguments body declares)
+  `(function
+    (lambda ,(unwalk-lambda-list arguments)
+     ,@(unwalk-declarations declares)
+     ,@(unwalk-forms body))))
+
+(defunwalker-handler function-object-form (name)
+  `(function ,name))
+
+;;;; Arguments
+
+(defun unwalk-lambda-list (arguments)
+  (let (optional-p rest-p keyword-p)
+    (mapcan #'(lambda (form)
+		(append
+		 (typecase form
+		   (optional-function-argument-form
+		    (unless optional-p (setq optional-p t) '(&optional)))
+		   (rest-function-argument-form
+		    (unless rest-p (setq rest-p t) '(&rest)))
+		   (keyword-function-argument-form
+		    (unless keyword-p (setq keyword-p t) '(&key))))
+		 (list (unwalk-form form))))
+	    arguments)))
+
+(defunwalker-handler required-function-argument-form (name)
+  name)
+
+(defunwalker-handler specialized-function-argument-form (name specializer)
+  (if (eq specializer t)
+      name
+      `(,name ,specializer)))
+
+(defunwalker-handler optional-function-argument-form (name default-value supplied-p-parameter)
+  (let ((default-value (unwalk-form default-value)))
+    (cond ((and name default-value supplied-p-parameter)
+	   `(,name ,default-value ,supplied-p-parameter))
+	  ((and name default-value)
+	   `(,name ,default-value))
+	  (name name)
+	  (t (error "Invalid optional argument")))))
+
+(defunwalker-handler keyword-function-argument-form (keyword-name name default-value supplied-p-parameter)
+  (let ((default-value (unwalk-form default-value)))
+    (cond ((and keyword-name name default-value supplied-p-parameter)
+	   `((,keyword-name ,name) ,default-value ,supplied-p-parameter))
+	  ((and name default-value supplied-p-parameter)
+	   `(,name ,default-value ,supplied-p-parameter))
+	  ((and name default-value)
+	   `(,name ,default-value))
+	  (name name)
+	  (t (error "Invalid keyword argument")))))
+
+(defunwalker-handler allow-other-keys-function-argument-form ()
+  '&allow-other-keys)
+
+(defunwalker-handler rest-function-argument-form (name)
+  name)
+
+;;;; Declarations
+
+(defun unwalk-declarations (decls)
+  ;; Return a list so declarations can be easily spliced.
+  (if (null decls)
+      nil
+      (list `(declare ,@(unwalk-forms decls)))))
+
+(defunwalker-handler optimize-declaration-form (optimize-spec)
+  `(optimize ,optimize-spec))
+
+(defunwalker-handler dynamic-extent-declaration-form (name)
+  `(dynamic-extent ,name))
+
+(defunwalker-handler variable-ignorable-declaration-form (name)
+  `(ignorable ,name))
+
+(defunwalker-handler function-ignorable-declaration-form (name)
+  `(ignorable (function ,name)))
+
+(defunwalker-handler special-declaration-form (name)
+  `(special ,name))
+
+(defunwalker-handler type-declaration-form (type-form name)
+  `(type ,type-form ,name))
+
+(defunwalker-handler ftype-declaration-form (type-form name)
+  `(ftype ,type-form ,name))
+
+(defunwalker-handler notinline-declaration-form (name)
+  `(notinline ,name))
+
+;;;; BLOCK/RETURN-FROM
+
+(defunwalker-handler block-form (name body)
+  `(block ,name ,@(unwalk-forms body)))
+
+(defunwalker-handler return-from-form (target-block result)
+  `(return-from ,(name target-block) ,(unwalk-form result)))
+
+;;;; CATCH/THROW
+
+(defunwalker-handler catch-form (tag body)
+  `(catch ,(unwalk-form tag) ,@(unwalk-forms body)))
+
+(defunwalker-handler throw-form (tag value)
+  `(throw ,(unwalk-form tag) ,(unwalk-form value)))
+
+;;;; EVAL-WHEN
+
+(defunwalker-handler eval-when-form (body eval-when-times)
+  `(eval-when ,eval-when-times
+     ,@(unwalk-forms body)))
+
+;;;; IF
+
+(defunwalker-handler if-form (consequent then else)
+  `(if ,(unwalk-form consequent) ,(unwalk-form then) ,(unwalk-form else)))
+
+;;;; FLET/LABELS
+
+;; The cdadr is here to remove (function (lambda ...)) of the function
+;; bindings.
+
+(defunwalker-handler flet-form (binds body declares)
+  (flet ((unwalk-flet (binds)
+	   (mapcar #'(lambda (bind)
+		       (cons (car bind)
+			     (cdadr (unwalk-form (cdr bind)))))
+		   binds)))
+    `(flet ,(unwalk-flet binds)
+       ,@(unwalk-declarations declares)
+       ,@(unwalk-forms body))))
+
+(defunwalker-handler labels-form (binds body declares)
+  (flet ((unwalk-labels (binds)
+	   (mapcar #'(lambda (bind)
+		       (cons (car bind)
+			     (cdadr (unwalk-form (cdr bind)))))
+		   binds)))
+    `(labels ,(unwalk-labels binds)
+       ,@(unwalk-declarations declares)
+       ,@(unwalk-forms body))))
+
+;;;; LET/LET*
+
+(defunwalker-handler let-form (binds body declares)
+  (flet ((unwalk-let (binds)
+	   (mapcar #'(lambda (bind)
+		       (list (car bind) (unwalk-form (cdr bind))))
+		   binds)))
+    `(let ,(unwalk-let binds)
+       ,@(unwalk-declarations declares)
+       ,@(unwalk-forms body))))
+
+(defunwalker-handler let*-form (binds body declares)
+  (flet ((unwalk-let* (binds)
+	   (mapcar #'(lambda (bind)
+		       (list (car bind) (unwalk-form (cdr bind))))
+		   binds)))
+    `(let* ,(unwalk-let* binds)
+       ,@(unwalk-declarations declares)
+       ,@(unwalk-forms body))))
+
+;;;; LOAD-TIME-VALUE
+
+(defunwalker-handler load-time-value-form (value read-only-p)
+  `(load-time-value ,(unwalk-form value) ,read-only-p))
+
+;;;; LOCALLY
+
+(defunwalker-handler locally-form (body declares)
+  `(locally ,@(unwalk-declarations declares)
+     ,@(unwalk-forms body)))
+
+;;;; MACROLET
+
+(defunwalker-handler macrolet-form (body binds declares)
+  ;; We ignore the binds, because the expansion has already taken
+  ;; place at walk-time.
+  (declare (ignore binds))
+  `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body)))
+
+;;;; MULTIPLE-VALUE-CALL
+
+(defunwalker-handler multiple-value-call-form (func arguments)
+  `(multiple-value-call ,(unwalk-form func) ,@(unwalk-forms arguments)))
+
+;;;; MULTIPLE-VALUE-PROG1
+
+(defunwalker-handler multiple-value-prog1-form (first-form other-forms)
+  `(multiple-value-prog1 ,(unwalk-form first-form) ,@(unwalk-forms other-forms)))
+
+;;;; PROGN
+
+(defunwalker-handler progn-form (body)
+  `(progn ,@(unwalk-forms body)))
+
+;;;; PROGV
+
+(defunwalker-handler progv-form (body vars-form values-form)
+  `(progv ,(unwalk-form vars-form) ,(unwalk-form values-form) ,@(unwalk-forms body)))
+
+;;;; SETQ
+
+(defunwalker-handler setq-form (var value)
+  `(setq ,var ,(unwalk-form value)))
+
+;;;; SYMBOL-MACROLET
+
+(defunwalker-handler symbol-macrolet-form (body binds declares)
+  ;; We ignore the binds, because the expansion has already taken
+  ;; place at walk-time.
+  (declare (ignore binds))
+  `(locally ,@(unwalk-declarations declares) ,@(unwalk-forms body)))
+
+;;;; TAGBODY/GO
+
+(defunwalker-handler tagbody-form (body)
+  `(tagbody ,@(unwalk-forms body)))
+
+(defunwalker-handler go-tag-form (name)
+  name)
+
+(defunwalker-handler go-form (name)
+  `(go ,name))
+
+;;;; THE
+
+(defunwalker-handler the-form (type-form value)
+  `(the ,type-form ,(unwalk-form value)))
+
+;;;; UNWIND-PROTECT
+
+(defunwalker-handler unwind-protect-form (protected-form cleanup-form)
+  `(unwind-protect ,(unwalk-form protected-form) ,@(unwalk-forms cleanup-form)))
+
+;; Copyright (c) 2006, Hoan Ton-That
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Hoan Ton-That, nor the names of the
+;;    contributors may be used to endorse or promote products derived
+;;    from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/vector.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,78 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * vector/array utilities
+
+(defun vector-push-extend* (vector &rest items)
+  (let ((element-type (array-element-type vector)))
+    (dolist (item items)
+      (cond
+        ((typep item element-type) ;; item can be put directly into the 
+         (vector-push-extend item vector))
+        ((typep item `(vector ,element-type)) ;; item should be a vector
+         (loop
+            for i across item
+            do (vector-push-extend i vector)))
+        (t
+         (error "Bad type for item ~S." item))))
+    vector))
+
+(defun string-from-array (array &key (start 0) (end (1- (length array))))
+  "Assuming ARRAY is an array of ASCII chars encoded as bytes return
+the corresponding string. Respect the C convention of null terminating
+strings. START and END specify the zero indexed offsets of a sub range
+of ARRAY."
+  ;; This is almost always the case
+  (assert (<= 0 start (1- (length array)))
+          (start)
+          "START must be a valid offset of ARRAY.")
+  (assert (<= 0 end (1- (length array)))
+          (end)
+          "END must be a valid offset of ARRAY.")
+  (assert (<= start end)
+          (start end)
+          "START must be less than or equal to END.")
+  (assert (every (lambda (element) (<= 0 element 255)) array)
+	  (array)
+	  "Some element of ~S was not > 0 and < 255" array)
+  (let* ((working-array (make-array (1+ (- end start))
+                                    :element-type (array-element-type array)
+                                    :displaced-to array
+                                    :displaced-index-offset start))
+	  (length (if-bind pos (position 0 working-array)
+		      pos
+		      (length working-array))))
+    (map-into (make-array length :element-type 'character)
+	      #'code-char
+	      working-array)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/walk.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,1002 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+;;;; * A Code Walker
+
+;;;; ** Public Entry Point
+
+(defvar *warn-undefined* nil
+  "When non-NIL any references to undefined functions or
+  variables will signal a warning.")
+
+(defun walk-form (form &optional (parent nil) (env (make-walk-env)))
+  "Walk FORM and return a FORM object."
+  (funcall (find-walker-handler form) form parent env))
+
+(defun make-walk-env (&optional lexical-env)
+  (let ((walk-env '()))
+    (when lexical-env
+      (dolist (var (lexical-variables lexical-env))
+        (extend walk-env :lexical-let var t))
+      (dolist (fun (lexical-functions lexical-env))
+	(extend walk-env :lexical-flet fun t))
+      (dolist (mac (lexical-macros lexical-env))
+	(extend walk-env :macrolet (car mac) (cdr mac)))
+      (dolist (symmac (lexical-symbol-macros lexical-env))
+	(extend walk-env :symbol-macrolet (car symmac) (cdr symmac))))
+    (cons walk-env lexical-env)))
+
+(defun register-walk-env (env type name datum &rest other-datum)
+  (let ((walk-env (register (car env) type name datum))
+	(lexenv (case type
+		  (:let (augment-with-variable (cdr env) name))
+		  (:macrolet (augment-with-macro (cdr env) name datum))
+		  (:flet (augment-with-function (cdr env) name))
+		  (:symbol-macrolet (augment-with-symbol-macro (cdr env) name datum))
+		  ;;TODO: :declare
+		  (t (cdr env)))))
+    (cons walk-env lexenv)))
+
+(defmacro extend-walk-env (env type name datum &rest other-datum)
+  `(setf ,env (register-walk-env ,env ,type ,name ,datum , at other-datum)))
+
+(defun lookup-walk-env (env type name &key (error-p nil) (default-value nil))
+  (lookup (car env) type name :error-p error-p :default-value default-value))
+
+;;;; This takes a Common Lisp form and transforms it into a tree of
+;;;; FORM objects.
+
+(defvar *walker-handlers* (make-hash-table :test 'eq))
+
+(define-condition undefined-reference (warning)
+  ((enclosing-code :accessor enclosing-code :initform nil)
+   (name :accessor name :initarg :name)))
+
+(define-condition undefined-variable-reference (undefined-reference)
+  ()
+  (:report
+   (lambda (c s)
+     (if (enclosing-code c)
+         (format s "Reference to unknown variable ~S in ~S." (name c) (enclosing-code c))
+         (format s "Reference to unknown variable ~S." (name c))))))
+
+(define-condition undefined-function-reference (undefined-reference)
+  ()
+  (:report
+   (lambda (c s)
+     (if (enclosing-code c)
+         (format s "Reference to unknown function ~S in ~S." (name c) (enclosing-code c))
+         (format s "Reference to unknown function ~S." (name c))))))
+
+(defvar +atom-marker+ '+atom-marker+)
+
+(defun find-walker-handler (form)
+  "Simple function which tells us what handler should deal
+  with FORM. Signals an error if we don't have a handler for
+  FORM."
+  (if (atom form)
+      (gethash '+atom-marker+ *walker-handlers*)
+      (aif (gethash (car form) *walker-handlers*)
+	   it
+	   (case (car form)
+	     ((block declare flet function go if labels let let*
+		     macrolet progn quote return-from setq symbol-macrolet
+		     tagbody unwind-protect catch multiple-value-call
+		     multiple-value-prog1 throw load-time-value the
+		     eval-when locally progv)
+	      (error "Sorry, No walker for the special operater ~S defined." (car form)))
+	     (t (gethash 'application *walker-handlers*))))))
+
+(defmacro defwalker-handler (name (form parent lexical-env)
+                             &body body)
+  `(progn
+     (setf (gethash ',name *walker-handlers*)
+           (lambda (,form ,parent ,lexical-env)
+             (declare (ignorable ,parent ,lexical-env))
+             , at body))
+     ',name))
+
+(defclass form ()
+  ((parent :accessor parent :initarg :parent)
+   (source :accessor source :initarg :source)))
+
+(defmethod make-load-form ((object form) &optional env)
+  (make-load-form-saving-slots object
+                               :slot-names (mapcar #'mopp:slot-definition-name
+                                                   (mopp:class-slots (class-of object)))
+                               :environment env))
+
+(defmethod print-object ((form form) stream)
+  (print-unreadable-object (form stream :type t :identity t)
+    (when (slot-boundp form 'source)
+      (let ((*print-readably* nil)
+            (*print-level* 0)
+            (*print-length* 4))
+        (format stream "~S" (source form))))))
+
+(defmacro with-form-object ((variable type &rest initargs)
+                            &body body)
+  `(let ((,variable (make-instance ',type , at initargs)))
+     , at body
+     ,variable))
+
+(defclass implicit-progn-mixin ()
+  ((body :accessor body :initarg :body)))
+
+(defclass implicit-progn-with-declare-mixin (implicit-progn-mixin)
+  ((declares :accessor declares :initarg :declares)))
+
+(defclass binding-form-mixin ()
+  ((binds :accessor binds :initarg :binds)))
+
+(defmacro multiple-value-setf (places form)
+  (loop
+       for place in places
+       for name = (gensym)
+       collect name into bindings
+       if (eql 'nil place)
+         collect `(declare (ignore ,name)) into ignores
+       else
+         collect `(setf ,place ,name) into body
+       finally (return
+                 `(multiple-value-bind ,bindings ,form
+                    , at ignores
+                    , at body))))
+
+(defun split-body (body env &key parent (docstring t) (declare t))
+  (let ((documentation nil) 
+	(newdecls nil)
+	(decls nil))
+    (flet ((done ()
+             (return-from split-body (values body env documentation (nreverse decls)))))
+      (loop
+         for form = (car body)
+         while body
+         do (typecase form
+              (cons (if (and declare (eql 'cl:declare (first form)))
+                        ;; declare form
+                        (let ((declarations (rest form)))
+                          (dolist* (dec declarations)
+                            (multiple-value-setf (env newdecls) (parse-declaration dec env parent))
+			    (setf decls (append newdecls decls))))
+                        ;; source code, all done
+                        (done)))
+              (string (if docstring
+                          (if documentation
+                              ;; already found the docstring, this is source
+                              (done)
+                              (if (cdr body)
+                                  ;; found the doc string
+                                  (setf documentation form)
+                                  ;; this looks like a doc string, but
+                                  ;; it's the only form in body, so
+                                  ;; it's actually code.
+                                  (done)))
+                          ;; no docstring allowed, this is source
+                          (done)))
+              (t ;; more code, all done
+               (done)))
+         do (pop body)
+         finally (done)))))
+
+(defclass declaration-form (form)
+  ())
+
+(defclass optimize-declaration-form (declaration-form)
+  ((optimize-spec :accessor optimize-spec :initarg :optimize-spec)))
+
+(defclass variable-declaration-form (declaration-form)
+  ((name :accessor name :initarg :name)))
+
+(defclass function-declaration-form (declaration-form)
+  ((name :accessor name :initarg :name)))
+
+(defclass dynamic-extent-declaration-form (variable-declaration-form)
+  ())
+
+(defclass ignorable-declaration-form-mixin (declaration-form)
+  ())
+
+(defclass variable-ignorable-declaration-form (variable-declaration-form ignorable-declaration-form-mixin)
+  ())
+
+(defclass function-ignorable-declaration-form (function-declaration-form ignorable-declaration-form-mixin)
+  ())
+
+(defclass special-declaration-form (variable-declaration-form)
+  ())
+
+(defclass type-declaration-form (variable-declaration-form)
+  ((type-form :accessor type-form :initarg :type-form)))
+
+(defclass ftype-declaration-form (function-declaration-form)
+  ((type-form :accessor type-form :initarg :type-form)))
+
+(defclass notinline-declaration-form (function-declaration-form)
+  ())
+
+(defun parse-declaration (declaration environment parent)
+  (let ((declares nil))
+    (flet ((funname (form)
+	     (if (and (consp form) (eql (car form) 'function))
+		 (cadr form)
+		 nil)))
+      (macrolet ((mkdecl (varname formclass &rest rest)
+		   `(make-instance ,formclass :parent parent :source (list type ,varname) , at rest))		 
+		 (extend-env ((var list) newdeclare &rest datum)
+		   `(dolist (,var ,list)
+		      (when ,newdeclare (push ,newdeclare declares))
+                      (extend-walk-env environment :declare , at datum))))
+	(destructuring-bind (type &rest arguments)
+	    declaration
+	  (case type
+	    (dynamic-extent
+	     (extend-env (var arguments)
+			 (mkdecl var 'dynamic-extent-declaration-form :name var) 
+			 var `(dynamic-extent)))        
+	    (ftype
+	     (extend-env (function-name (cdr arguments))
+			 (make-instance 'ftype-declaration-form 
+					:parent parent
+					:source `(ftype ,(first arguments) function-name)
+					:name function-name
+					:type-form (first arguments))
+			 function-name `(ftype ,(first arguments))))
+	    ((ignore ignorable)
+	     (extend-env (var arguments)
+			 (aif (funname var)
+			      (mkdecl var 'function-ignorable-declaration-form :name it)
+			      (mkdecl var 'variable-ignorable-declaration-form :name var))
+			 var `(ignorable)))
+	    (inline
+	      (extend-env (function arguments) 
+			  (mkdecl function 'function-ignorable-declaration-form :name function)
+			  function `(ignorable)))
+	    (notinline
+	     (extend-env (function arguments)
+			 (mkdecl function 'notinline-declaration-form :name function)
+			 function `(notinline)))
+	    (optimize
+	     (extend-env (optimize-spec arguments) 
+			 (mkdecl optimize-spec 'optimize-declaration-form :optimize-spec optimize-spec)
+			 'optimize optimize-spec))
+	    (special
+	     (extend-env (var arguments) 
+			 (mkdecl var 'special-declaration-form :name var)
+			 var `(special)))
+	    (type
+	     (extend-env (var (rest arguments))
+			 (make-instance 'type-declaration-form 
+					:parent parent
+					:source `(type ,(first arguments) ,var)
+					:name var
+					:type-form (first arguments))
+			 var `(type ,(first arguments))))
+	    (t
+	     (extend-env (var arguments)
+			 (make-instance 'type-declaration-form 
+					:parent parent
+					:source `(,type ,var)
+					:name var
+					:type-form type)
+			 var `(type ,type)))))))
+    (when (null declares)
+      (setq declares (list (make-instance 'declaration-form :parent parent :source declaration))))
+    (values environment declares)))
+
+(defun walk-implict-progn (parent forms env &key docstring declare)
+  (handler-bind ((undefined-reference (lambda (condition)
+                                        (unless (enclosing-code condition)
+                                          (setf (enclosing-code condition) `(progn , at forms))))))
+    (multiple-value-bind (body env docstring declarations)
+        (split-body forms env :parent parent :docstring docstring :declare declare)
+      (values (mapcar (lambda (form)
+                        (walk-form form parent env))
+                      body)
+              docstring
+              declarations))))
+
+;;;; Atoms
+
+(defclass constant-form (form)
+  ((value :accessor value :initarg :value)))
+
+(defclass variable-reference (form)
+  ((name :accessor name :initarg :name)))
+
+(defmethod print-object ((v variable-reference) stream)
+  (print-unreadable-object (v stream :type t :identity t)
+    (format stream "~S" (name v))))
+
+(defclass local-variable-reference (variable-reference)
+  ())
+
+(defclass local-lexical-variable-reference (local-variable-reference)
+  ()
+  (:documentation "A reference to a local variable defined in the
+  lexical environment outside of the form passed to walk-form."))
+
+(defclass free-variable-reference (variable-reference)
+  ())
+
+(defwalker-handler +atom-marker+ (form parent env)
+  (declare (special *macroexpand*))
+  (cond
+    ((not (or (symbolp form) (consp form)))
+     (make-instance 'constant-form :value form
+                    :parent parent :source form))
+    ((lookup-walk-env env :let form)
+     (make-instance 'local-variable-reference :name form
+                    :parent parent :source form))
+    ((lookup-walk-env env :lexical-let form)
+     (make-instance 'local-lexical-variable-reference :name form
+                    :parent parent :source form))
+    ((lookup-walk-env env :symbol-macrolet form)
+     (walk-form (lookup-walk-env env :symbol-macrolet form) parent env))
+    ((nth-value 1 (macroexpand-1 form))
+     ;; a globaly defined symbol-macro
+     (walk-form (macroexpand-1 form) parent env))
+    (t
+     (when (and *warn-undefined*
+                (not (boundp form)))
+       (warn 'undefined-variable-reference :name form))
+     (make-instance 'free-variable-reference :name form
+                    :parent parent :source form))))
+
+;;;; Function Applictation
+
+(defclass application-form (form)
+  ((operator :accessor operator :initarg :operator)
+   (arguments :accessor arguments :initarg :arguments)))
+
+(defclass local-application-form (application-form)
+  ((code :accessor code :initarg :code)))
+
+(defclass lexical-application-form (application-form)
+  ())
+
+(defclass free-application-form (application-form)
+  ())
+
+(defclass lambda-application-form (application-form)
+  ())
+
+(defwalker-handler application (form parent env)
+  (block nil
+    (destructuring-bind (op &rest args)
+        form
+      (when (and (consp op)
+                 (eq 'cl:lambda (car op)))
+        (return
+          (with-form-object (application lambda-application-form :parent parent :source form)
+            (setf (operator application) (walk-form op application env)
+                  (arguments application) (mapcar (lambda (form)
+                                                    (walk-form form application env))
+                                                  args)))))
+      (when (lookup-walk-env env :macrolet op)
+        (return (walk-form (funcall (lookup-walk-env env :macrolet op) form (cdr env)) parent env)))
+      (when (and (symbolp op) (macro-function op))
+	(multiple-value-bind (expansion expanded)
+	    (macroexpand-1 form (cdr env))
+	  (when expanded
+	    (return (walk-form expansion parent env)))))
+      (let ((app (if (lookup-walk-env env :flet op)
+                     (make-instance 'local-application-form :code (lookup-walk-env env :flet op))
+                     (if (lookup-walk-env env :lexical-flet op)
+			 (make-instance 'lexical-application-form)
+                         (progn
+                           (when (and *warn-undefined*
+                                      (symbolp op)
+                                      (not (fboundp op)))
+                             (warn 'undefined-function-reference :name op))
+                           (make-instance 'free-application-form))))))
+        (setf (operator app) op
+              (parent app) parent
+              (source app) form
+              (arguments app) (mapcar (lambda (form)
+                                        (walk-form form app env))
+                                      args))
+        app))))
+
+;;;; Functions
+
+(defclass function-form (form)
+  ())
+
+(defclass lambda-function-form (function-form implicit-progn-with-declare-mixin)
+  ((arguments :accessor arguments :initarg :arguments)))
+
+(defclass function-object-form (form)
+  ((name :accessor name :initarg :name)))
+
+(defclass local-function-object-form (function-object-form)
+  ())
+
+(defclass free-function-object-form (function-object-form)
+  ())
+
+(defclass lexical-function-object-form (function-object-form)
+  ())
+
+(defwalker-handler function (form parent env)
+  (if (and (listp (second form))
+           (eql 'cl:lambda (first (second form))))
+      ;; (function (lambda ...))
+      (walk-lambda (second form) parent env)
+      ;; (function foo)
+      (make-instance (if (lookup-walk-env env :flet (second form))
+                         'local-function-object-form
+                         (if (lookup-walk-env env :lexical-flet (second form))
+			     'lexical-function-object-form
+			     'free-function-object-form))
+                     :name (second form)
+                     :parent parent :source form)))
+
+(defun walk-lambda (form parent env)
+  (with-form-object (func lambda-function-form
+                          :parent parent
+                          :source form)
+    ;; 1) parse the argument list creating a list of FUNCTION-ARGUMENT-FORM objects
+    (multiple-value-setf ((arguments func) env)
+      (walk-lambda-list (second form) func env))
+    ;; 2) parse the body
+    (multiple-value-setf ((body func) nil (declares func))
+      (walk-implict-progn func (cddr form) env :declare t))
+    ;; all done
+    func))
+
+(defun walk-lambda-list (lambda-list parent env &key allow-specializers macro-p)
+  (flet ((extend-env (argument)
+           (unless (typep argument 'allow-other-keys-function-argument-form)
+             (extend-walk-env env :let (name argument) argument))))
+    (let ((state :required)
+          (arguments '()))
+      (dolist (argument lambda-list)
+        (if (member argument '(&optional &key &rest))
+            (setf state argument)
+            (progn
+              (push (case state
+                      (:required
+                       (if allow-specializers
+                           (walk-specialized-argument-form argument parent env)
+                           (walk-required-argument argument parent env)))
+                      (&optional (walk-optional-argument argument parent env))
+                      (&key
+                       (if (eql '&allow-other-keys argument)
+                           (make-instance 'allow-other-keys-function-argument-form
+                                          :parent parent :source argument)
+                           (walk-keyword-argument argument parent env)))
+                      (&rest (walk-rest-argument argument parent env)))
+                    arguments)
+              (extend-env (car arguments)))))
+      (values (nreverse arguments) env))))
+
+(defclass function-argument-form (form)
+  ((name :accessor name :initarg :name)))
+
+(defmethod print-object ((argument function-argument-form) stream)
+  (print-unreadable-object (argument stream :type t :identity t)
+    (if (slot-boundp argument 'name)
+        (format stream "~S" (name argument))
+        (write-string "#<unbound name>" stream))))
+
+(defclass required-function-argument-form (function-argument-form)
+  ())
+
+(defgeneric required-function-argument-form-p (object)
+  (:method ((object t)) nil)
+  (:method ((object required-function-argument-form)) t))
+
+(defun walk-required-argument (form parent env)
+  (declare (ignore env))
+  (make-instance 'required-function-argument-form
+                 :name form
+                 :parent parent :source form))
+
+(defclass specialized-function-argument-form (required-function-argument-form)
+  ((specializer :accessor specializer :initarg :specializer)))
+
+(defun walk-specialized-argument-form (form parent env)
+  (declare (ignore env))
+  (make-instance 'specialized-function-argument-form
+                 :name (if (listp form)
+                           (first form)
+                           form) 
+                 :specializer (if (listp form)
+                                  (second form)
+                                  'T)
+                 :parent parent
+                 :source form))
+
+(defclass optional-function-argument-form (function-argument-form)
+  ((default-value :accessor default-value :initarg :default-value)
+   (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter)))
+
+(defun walk-optional-argument (form parent env)
+  (destructuring-bind (name &optional default-value supplied-p-parameter)
+      (ensure-list form)
+    (with-form-object (arg optional-function-argument-form
+                           :parent parent
+                           :source form
+                           :name name
+                           :supplied-p-parameter supplied-p-parameter)
+      (setf (default-value arg) (walk-form default-value arg env)))))
+
+(defclass keyword-function-argument-form (function-argument-form)
+  ((keyword-name :accessor keyword-name :initarg :keyword-name)
+   (default-value :accessor default-value :initarg :default-value)
+   (supplied-p-parameter :accessor supplied-p-parameter :initarg :supplied-p-parameter)))
+
+(defmethod effective-keyword-name ((k keyword-function-argument-form))
+  (or (keyword-name k)
+      (intern (symbol-name (name k)) :keyword)))
+
+(defun walk-keyword-argument (form parent env)
+  (destructuring-bind (name &optional default-value supplied-p-parameter)
+      (ensure-list form)
+    (let ((name (if (consp name)
+                    (second name)
+                    name))
+          (keyword (if (consp name)
+                       (first name)
+                       nil)))
+      (with-form-object (arg keyword-function-argument-form
+                             :parent parent
+                             :source form
+                             :name name
+                             :keyword-name keyword
+                             :supplied-p-parameter supplied-p-parameter)
+        (setf (default-value arg) (walk-form default-value arg env))))))
+
+(defclass allow-other-keys-function-argument-form (function-argument-form)
+  ())
+
+(defclass rest-function-argument-form (function-argument-form)
+  ())
+
+(defun walk-rest-argument (form parent env)
+  (declare (ignore env))
+  (make-instance 'rest-function-argument-form :name form
+                 :parent parent :source form))
+
+;;;; BLOCK/RETURN-FROM
+
+(defclass block-form (form implicit-progn-mixin)
+  ((name :accessor name :initarg :name)))
+
+(defclass return-from-form (form)
+  ((target-block :accessor target-block :initarg :target-block)
+   (result :accessor result :initarg :result)))
+
+(defwalker-handler block (form parent env)
+  (destructuring-bind (block-name &rest body)
+      (cdr form)
+    (with-form-object (block block-form
+                       :parent parent :source form
+                       :name block-name)
+      (setf (body block) (walk-implict-progn block
+                                             body
+                                             (register-walk-env env :block block-name block))))))
+
+(define-condition return-from-unknown-block (error)
+  ((block-name :accessor block-name :initarg :block-name))
+  (:report (lambda (condition stream)
+             (format stream "Unable to return from block named ~S." (block-name condition)))))
+
+(defwalker-handler return-from (form parent env)
+  (destructuring-bind (block-name &optional (value '(values)))
+      (cdr form)
+    (if (lookup-walk-env env :block block-name)
+        (with-form-object (return-from return-from-form :parent parent :source form
+                           :target-block (lookup-walk-env env :block block-name))
+          (setf (result return-from) (walk-form value return-from env)))
+        (restart-case
+            (error 'return-from-unknown-block :block-name block-name)
+          (add-block ()
+            :report "Add this block and continue."
+            (walk-form form parent (register-walk-env env :block block-name :unknown-block)))))))
+
+;;;; CATCH/THROW
+
+(defclass catch-form (form implicit-progn-mixin)
+  ((tag :accessor tag :initarg :tag)))
+
+(defclass throw-form (form)
+  ((tag :accessor tag :initarg :tag)
+   (value :accessor value :initarg :value)))
+
+(defwalker-handler catch (form parent env)
+  (destructuring-bind (tag &body body)
+      (cdr form)
+    (with-form-object (catch catch-form :parent parent :source form)
+      (setf (tag catch) (walk-form tag catch env)
+            (body catch) (walk-implict-progn catch body env)))))
+
+(defwalker-handler throw (form parent env)
+  (destructuring-bind (tag &optional (result '(values)))
+      (cdr form)
+    (with-form-object (throw throw-form :parent parent :source form)
+      (setf (tag throw) (walk-form tag throw env)
+            (value throw) (walk-form result throw env)))))
+
+;;;; EVAL-WHEN
+
+(defclass eval-when-form (form implicit-progn-mixin)
+  ((eval-when-times :accessor eval-when-times :initarg :eval-when-times)))
+
+(defwalker-handler eval-when (form parent env)
+  (destructuring-bind (times &body body)
+      (cdr form)
+    (with-form-object (eval-when eval-when-form :parent parent :source form)
+      (setf (eval-when-times eval-when) times
+            (body eval-when) (walk-implict-progn eval-when body env)))))
+
+;;;; IF
+
+(defclass if-form (form)
+  ((consequent :accessor consequent :initarg :consequent)
+   (then :accessor then :initarg :then)
+   (else :accessor else :initarg :else)))
+
+(defwalker-handler if (form parent env)
+  (with-form-object (if if-form :parent parent :source form)
+    (setf (consequent if) (walk-form (second form) if env)
+          (then if) (walk-form (third form) if env)
+          (else if) (walk-form (fourth form) if env))))
+
+;;;; FLET/LABELS
+
+(defclass function-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+  ())
+
+(defclass flet-form (function-binding-form)
+  ())
+
+(defclass labels-form (function-binding-form)
+  ())
+
+(defwalker-handler flet (form parent env)
+  (destructuring-bind (binds &body body)
+      (cdr form)
+    (with-form-object (flet flet-form :parent parent :source form)
+      ;;;; build up the objects for the bindings in the original env
+      (loop
+         for (name args . body) in binds
+         collect (cons name (walk-form `(lambda ,args , at body) flet env)) into bindings
+         finally (setf (binds flet) bindings))
+      ;;;; walk the body in the new env
+      (multiple-value-setf ((body flet) nil (declares flet))
+			   (walk-implict-progn flet
+					       body
+					       (loop
+						  with env = env
+						  for (name . lambda) in (binds flet)
+						  do (extend-walk-env env :flet name lambda)
+						  finally (return env))
+					       :declare t)))))
+
+(defwalker-handler labels (form parent env)
+  (destructuring-bind (binds &body body)
+      (cdr form)
+    (with-form-object (labels labels-form :parent parent :source form :binds '())
+      ;; we need to walk over the bindings twice. the first pass
+      ;; creates some 'empty' lambda objects in the environment so
+      ;; that local-application-form and local-function-object-form
+      ;; have something to point to. the second pass then walks the
+      ;; actual bodies of the form filling in the previously created
+      ;; objects.
+      (loop
+         for (name arguments . body) in binds
+         for lambda = (make-instance 'lambda-function-form
+                                     :parent labels
+                                     :source (list* name arguments body))
+         do (push (cons name lambda) (binds labels))
+         do (extend-walk-env env :flet name lambda))
+      (setf (binds labels) (nreverse (binds labels)))
+      (loop
+         for form in binds
+         for (arguments . body) = (cdr form)
+         for binding in (binds labels)
+         for lambda = (cdr binding)
+         for tmp-lambda = (walk-lambda `(lambda ,arguments , at body) labels env)
+         do (setf (body lambda) (body tmp-lambda)
+                  (arguments lambda) (arguments tmp-lambda)
+		  (declares lambda) (declares tmp-lambda)))
+      (multiple-value-setf ((body labels) nil (declares labels)) (walk-implict-progn labels body env :declare t)))))
+
+;;;; LET/LET*
+
+(defclass variable-binding-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+  ())
+
+(defclass let-form (variable-binding-form)
+  ())
+
+(defwalker-handler let (form parent env)
+  (with-form-object (let let-form :parent parent :source form)
+    (setf (binds let) (mapcar (lambda (binding)
+                                   (destructuring-bind (var &optional initial-value)
+                                       (ensure-list binding)
+                                     (cons var (walk-form initial-value let env))))
+                                 (second form)))
+    (multiple-value-bind (b e d declarations)
+        (split-body (cddr form) env :parent let :declare t)
+      (declare (ignore b e d))
+      (dolist* ((var . value) (binds let))
+        (declare (ignore value))
+        (if (not (find-if (lambda (declaration)
+                            (and (typep declaration 'special-declaration-form)
+                                 (eq var (name declaration)))) declarations))
+            (extend-walk-env env :let var :dummy)))
+      (multiple-value-setf ((body let) nil (declares let))
+                           (walk-implict-progn let (cddr form) env :declare t)))))
+
+(defclass let*-form (variable-binding-form)
+  ())
+
+(defwalker-handler let* (form parent env)
+  (with-form-object (let* let*-form :parent parent :source form :binds '())
+    (dolist* ((var &optional initial-value) (mapcar #'ensure-list (second form)))
+      (push (cons var (walk-form initial-value let* env)) (binds let*))
+      (extend-walk-env env :let var :dummy))
+    (setf (binds let*) (nreverse (binds let*)))
+    (multiple-value-setf ((body let*) nil (declares let*)) (walk-implict-progn let* (cddr form) env :declare t))))
+
+;;;; LOAD-TIME-VALUE
+
+(defclass load-time-value-form (form)
+  ((value :accessor value)
+   (read-only-p :accessor read-only-p)))
+
+(defwalker-handler load-time-value (form parent env)
+  (with-form-object (load-time-value load-time-value-form
+                                     :parent parent :source form)
+    (setf (value load-time-value) (walk-form (second form) load-time-value env)
+          (read-only-p load-time-value) (third form))))
+
+;;;; LOCALLY
+
+(defclass locally-form (form implicit-progn-with-declare-mixin)
+  ())
+
+(defwalker-handler locally (form parent env)
+  (with-form-object (locally locally-form :parent parent :source form)
+    (multiple-value-setf ((body locally) nil (declares locally)) (walk-implict-progn locally (cdr form) env :declare t))))
+
+;;;; MACROLET
+
+(defclass macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+  ())
+
+(defwalker-handler macrolet (form parent env)
+  (with-form-object (macrolet macrolet-form :parent parent :source form
+                              :binds '())
+    (dolist* ((name args &body body) (second form))
+      (let ((handler (parse-macro-definition name args body (cdr env))))
+        (extend-walk-env env :macrolet name handler)
+        (push (cons name handler) (binds macrolet))))
+    (setf (binds macrolet) (nreverse (binds macrolet)))
+    (multiple-value-setf ((body macrolet) nil (declares macrolet))
+      (walk-implict-progn macrolet (cddr form) env :declare t))))
+
+;;;; MULTIPLE-VALUE-CALL
+
+(defclass multiple-value-call-form (form)
+  ((func :accessor func :initarg :func)
+   (arguments :accessor arguments :initarg :arguments)))
+
+(defwalker-handler multiple-value-call (form parent env)
+  (with-form-object (m-v-c multiple-value-call-form :parent parent :source form)
+    (setf (func m-v-c) (walk-form (second form) m-v-c env)
+          (arguments m-v-c) (mapcar (lambda (f) (walk-form f m-v-c env))
+                                    (cddr form)))))
+
+;;;; MULTIPLE-VALUE-PROG1
+
+(defclass multiple-value-prog1-form (form)
+  ((first-form :accessor first-form :initarg :first-form)
+   (other-forms :accessor other-forms :initarg :other-forms)))
+
+(defwalker-handler multiple-value-prog1 (form parent env)
+  (with-form-object (m-v-p1 multiple-value-prog1-form :parent parent :source form)
+    (setf (first-form m-v-p1) (walk-form (second form) m-v-p1 env)
+          (other-forms m-v-p1) (mapcar (lambda (f) (walk-form f m-v-p1 env))
+                                       (cddr form)))))
+
+;;;; PROGN
+
+(defclass progn-form (form implicit-progn-mixin)
+  ())
+
+(defwalker-handler progn (form parent env)
+  (with-form-object (progn progn-form :parent parent :source form)
+    (setf (body progn) (walk-implict-progn progn (cdr form) env))))
+
+;;;; PROGV 
+
+(defclass progv-form (form implicit-progn-mixin)
+  ((vars-form :accessor vars-form :initarg :vars-form)
+   (values-form :accessor values-form :initarg :values-form)))
+
+(defwalker-handler progv (form parent env)
+  (with-form-object (progv progv-form :parent parent :source form)
+    (setf (vars-form progv) (walk-form (cadr form) progv env))    
+    (setf (values-form progv) (walk-form (caddr form) progv env))
+    (setf (body progv) (walk-implict-progn progv (cdddr form) env))
+    progv))
+
+;;;; QUOTE
+
+(defwalker-handler quote (form parent env)
+  (make-instance 'constant-form :parent parent :source form :value (second form)))
+
+;;;; SETQ
+
+(defclass setq-form (form)
+  ((var   :accessor var   :initarg :var)
+   (value :accessor value :initarg :value)))
+
+(defwalker-handler setq (form parent env)
+  ;; the SETQ handler needs to be able to deal with symbol-macrolets
+  ;; which haven't yet been expanded and may expand into something
+  ;; requiring setf and not setq.
+  (let ((effective-code '()))
+    (loop
+       for (name value) on (cdr form) by #'cddr
+       if (lookup-walk-env env :symbol-macrolet name)
+         do (push `(setf ,(lookup-walk-env env :symbol-macrolet name) ,value) effective-code)
+       else
+         do (push `(setq ,name ,value) effective-code))
+    (if (= 1 (length effective-code))
+        ;; only one form, the "simple case"
+        (destructuring-bind (type var value)
+            (first effective-code)
+          (ecase type
+            (setq (with-form-object (setq setq-form :parent parent :source form
+                                          :var var)
+                    (setf (value setq) (walk-form value setq env))))
+            (setf (walk-form (first effective-code) parent env))))
+        ;; multiple forms
+        (with-form-object (progn progn-form :parent parent :source form)
+          (setf (body progn) (walk-implict-progn progn effective-code env))))))
+
+;;;; SYMBOL-MACROLET
+
+(defclass symbol-macrolet-form (form binding-form-mixin implicit-progn-with-declare-mixin)
+  ())
+
+(defwalker-handler symbol-macrolet (form parent env)
+  (with-form-object (symbol-macrolet symbol-macrolet-form :parent parent :source form
+                                     :binds '())
+    (dolist* ((symbol expansion) (second form))
+      (extend-walk-env env :symbol-macrolet symbol expansion)
+      (push (cons symbol expansion) (binds symbol-macrolet)))
+    (setf (binds symbol-macrolet) (nreverse (binds symbol-macrolet)))
+    (multiple-value-setf ((body symbol-macrolet) nil (declares symbol-macrolet))
+      (walk-implict-progn symbol-macrolet (cddr form) env :declare t))))
+
+;;;; TAGBODY/GO
+
+(defclass tagbody-form (form implicit-progn-mixin)
+  ())
+
+(defclass go-tag-form (form)
+  ((name :accessor name :initarg :name)))
+
+(defgeneric go-tag-form-p (object)
+  (:method ((object go-tag-form)) t)
+  (:method ((object t))           nil))
+
+(defwalker-handler tagbody (form parent env)
+  (with-form-object (tagbody tagbody-form :parent parent :source form :body (cdr form))
+    (extend-walk-env env :tagbody 'enclosing-tagbody tagbody)
+    (flet ((go-tag-p (form)
+             (or (symbolp form) (integerp form))))
+      ;; the loop below destructuivly modifies the body of tagbody,
+      ;; since it's the same object as the source we need to copy it.
+      (setf (body tagbody) (copy-list (body tagbody)))
+      (loop
+         for part on (body tagbody)
+         if (go-tag-p (car part))
+           do (extend-walk-env env :tag (car part) (cdr part)))
+      (loop
+         for part on (body tagbody)
+         if (go-tag-p (car part))
+           do (setf (car part) (make-instance 'go-tag-form :parent tagbody
+                                              :source (car part)
+                                              :name (car part)))
+         else
+           do (setf (car part) (walk-form (car part) tagbody env))))))
+
+(defclass go-form (form)
+  ((target-progn :accessor target-progn :initarg :target-progn)
+   (name :accessor name :initarg :name)
+   (enclosing-tagbody :accessor enclosing-tagbody :initarg :enclosing-tagbody)))
+
+(defwalker-handler go (form parent env)
+  (make-instance 'go-form
+                 :parent parent
+                 :source form
+                 :name (second form)
+                 :target-progn (lookup-walk-env env :tag (second form))
+                 :enclosing-tagbody (lookup-walk-env env :tagbody 'enclosing-tagbody)))
+
+;;;; THE
+
+(defclass the-form (form)
+  ((type-form :accessor type-form :initarg :type-form)
+   (value :accessor value :initarg :value)))
+
+(defwalker-handler the (form parent env)
+  (with-form-object (the the-form :parent parent :source form
+                                  :type-form (second form))
+    (setf (value the) (walk-form (third form) the env))))
+
+;;;; UNWIND-PROTECT
+
+(defclass unwind-protect-form (form)
+  ((protected-form :accessor protected-form :initarg :protected-form)
+   (cleanup-form :accessor cleanup-form :initarg :cleanup-form)))
+
+(defwalker-handler unwind-protect (form parent env)
+  (with-form-object (unwind-protect unwind-protect-form :parent parent
+                                    :source form)
+    (setf (protected-form unwind-protect) (walk-form (second form) unwind-protect env)
+          (cleanup-form unwind-protect) (walk-implict-progn unwind-protect (cddr form) env))))
+
+;;;; LOAD-TIME-VALUE
+
+(defclass load-time-value-form (form)
+  ((body :accessor body :initarg :body)
+   (read-only :initform nil :accessor read-only-p :initarg :read-only)
+   (value :accessor value)))
+
+(defmethod initialize-instance :after ((self load-time-value-form) &key)
+  (setf (value self) (eval (body self))))
+
+(defwalker-handler load-time-value (form parent env)
+  (assert (<= (length form) 3))
+  (with-form-object (load-time-value load-time-value-form :parent parent
+                                     :body form
+                                     :read-only (third form))
+    (setf (body load-time-value) (second form))))
+
+;;;; ** Implementation specific walkers
+
+;;;; These are for forms which certain compilers treat specially but
+;;;; aren't macros or special-operators.
+
+#+lispworks
+(defwalker-handler compiler::internal-the (form parent env)
+  (walk-form (third form) parent env))
+
+;; Copyright (c) 2005-2006, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/accumulation.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,17 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.accumulation :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.accumulation)
+
+(test make-reducer
+
+  (let ((r (make-reducer #'+ 0)))
+    (funcall r 0)
+    (funcall r 1 2)
+    (funcall r 1 2 3)
+    (is (= 9 (funcall r)))))
+

Added: branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/call-cc.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,530 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.call/cc :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.call/cc)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setf *call/cc-returns* nil))
+
+(test call/cc-constant
+  (is (= 4 (with-call/cc 4)))
+  (is (eql :a (with-call/cc :a)))
+  (is (eql 'a (with-call/cc 'a)))
+  (is (eql #'+ (with-call/cc #'+))))
+
+(test call/cc-progn
+  (is (null (with-call/cc)))
+  (is (= 1 (with-call/cc 1)))
+  (is (= 2 (with-call/cc 1 2)))
+  (is (= 3 (with-call/cc 1 2 3)))
+  (is (= 4 (with-call/cc 1 2 3 4))))
+
+(test call/cc-progn/cc
+  (is (= 1 (kall (with-call/cc (let/cc k k) 1))))
+  (is (= 1 (kall (with-call/cc (let/cc k k) 0 1)))))
+
+(test call/cc-let
+  (is (= 1 (with-call/cc
+	    (let () 1))))
+  (is (= 1 (with-call/cc
+	    (let ((a 1)) a))))
+  (is (= 1 (with-call/cc
+             (let ((a 1))
+               (let ((a nil)
+                     (b a))
+                 (declare (ignore a))
+                 b)))))
+  (with-call/cc
+    (let ((a 1))
+      (let ((a 2))
+        (is (= 2 a)))
+      (is (= 1 a))))
+
+  (let ((cont nil))
+    (setf cont
+          (with-call/cc
+            (let ((a (let/cc k k)))
+              (+ a 4))))
+    (is (= 9 (kall cont 5)))
+    (is (= 12 (kall cont 8)))))
+
+(test call/cc-let/cc
+  (let ((k (with-call/cc
+             (let ((a (arnesi::retk)))
+               (+ a 1)))))
+  (is (= 1 (arnesi::kall k 0)))
+  (is (= 2 (arnesi::kall k 1)))))
+
+(test call/cc-setq
+  (is (= 1 (with-call/cc
+             (let ((a nil)) (setq a 1)))))
+  (is (= 2 (with-call/cc
+             (let ((a 1)) (setq a (1+ a)))))))
+
+(test call/cc-let*
+  (with-call/cc
+    (let* ((a 1)
+	   (b a))
+      (is (= 1 a))
+      (is (= 1 b))))
+  (with-call/cc
+   (let ((a 0)
+	 (b 1))
+     (declare (ignore a))
+     (let* ((a b)
+	    (b a))
+       (is (= a 1))
+       (is (= b 1))
+       (setq a 47)
+       (is (= a 47))))))
+
+(test call/cc-apply
+  (is (= 0 (with-call/cc (+))))
+  (is (= 1 (with-call/cc (+ 1))))
+  (is (= 2 (with-call/cc (+ 1 1))))
+  (is (= 3 (with-call/cc (+ 1 (+ 1 (+ 1 (+))))))))
+
+(test call/cc-if
+  (is (= 1 (with-call/cc (if t 1))))
+  (is (= 1 (with-call/cc (if nil 0 1))))
+  (is (null (with-call/cc (if nil 1)))))
+
+(test call/cc-block/return-from
+  (is (= 1
+         (with-call/cc
+           (block foo
+               nil
+               (return-from foo 1)
+               nil))))
+  (is (eql t 
+           (with-call/cc
+               (block foo
+                 (return-from foo t)
+                 nil)))))
+
+(defun reached-unreachable-code ()
+  (fail "Somehow we reached unreachable code in a tagbody."))
+
+(test call/cc-tagbody
+  (with-call/cc
+    (tagbody
+       (go a)
+       (reached-unreachable-code)
+       a
+       (pass)))
+  (with-call/cc
+    (tagbody
+       (go a) (reached-unreachable-code)
+     b
+       (pass)
+       (go c) (reached-unreachable-code)
+     a
+       (pass)
+       (go b) (reached-unreachable-code)
+     c
+       (pass)))
+  (with-call/cc
+    (let ((counter 0))
+      (dotimes (i 5)
+        (incf counter))
+      (is (= 5 counter))))
+  (with-call/cc
+    (let ((i 0))
+      (tagbody
+       a (incf i) (is (= 1 i))
+       b (incf i) (is (= 2 i))
+       c (is (= 2 i))))))
+
+(test call/cc-flet
+  (with-call/cc
+    (flet ((foo () 'x))
+      (is (eql 'x (foo))))
+    (is (= 4 (funcall (let ((a 4))
+                        (flet ((foo () a))
+                          #'foo)))))
+    (flet ((foo ()
+             'outer-foo))
+      (flet ((foo ()
+               'inner-foo)
+             (bar ()
+               (foo)))
+        (is (eql 'outer-foo (bar)))))))
+
+(test call/cc-labels
+  (with-call/cc
+    (labels ((foo () 'x))
+      (is (eql 'x (foo))))
+    (labels ((foo () 'outer-foo))
+      (labels ((bar () (foo))
+               (foo () 'inner-foo))
+        (is (eql 'inner-foo (bar))))))
+  (finishes 
+    (with-call/cc
+      (labels ((rec (x) x))
+        #'rec
+        (is (= 1 (funcall #'rec 1)))
+        (is (= 1 (apply #'rec (list 1)))))
+      (flet ((f () 1))
+        (is (= 1 (f)))
+        (is (= 1 (funcall #'f)))
+        (is (= 1 (apply #'f '()))))))
+  (let ((cont (with-call/cc
+                (labels ((rec (n)
+                           (if (zerop n)
+                               0
+                               (+ (rec (1- n))
+                                  (let/cc k k)))))
+                  (rec 2)))))
+    (is (= 5 (kall (kall cont 2) 3)))))
+
+(let ((value 0))
+  (defun test-funcall.0 ()
+    value)
+  (defun (setf test-funcall.0) (new-value)
+    (setf value new-value)))
+
+(test call/cc-setf-funcall
+  (setf (test-funcall.0) 0)
+  (is (= 0 (with-call/cc (test-funcall.0))))
+  (is (= 1 (with-call/cc (setf (test-funcall.0) 1))))
+  (is (= 2 (with-call/cc (funcall #'(setf test-funcall.0) 2)))))
+
+(test call/cc-lambda-requried-arguments
+  (with-call/cc
+    (is (eql t (funcall (lambda () t))))
+    (is (eql t (funcall (lambda (x) x) t))))
+  (signals error
+    (with-call/cc
+      (funcall (lambda (x) x)))))
+
+(test call/cc-lambda-optional-arguments
+  (with-call/cc
+    (is (eql t (funcall (lambda (&optional a) a) t)))
+    (is (eql t (funcall (lambda (&optional (a t)) a)))))
+
+  (let ((cont (with-call/cc
+                (funcall (lambda (&optional (a (let/cc k k)))
+                           (+ a 1))))))
+    (is (= 1 (kall cont 0)))))
+
+(test call/cc-lambda-keyword-arguments
+  (with-call/cc
+    (is (eql 'a   (funcall (lambda (&key a) a) :a 'a)))
+    (is (eql 'b   (funcall (lambda (&key (a 'b)) a))))
+    (is (eql t    (funcall (lambda (&optional a &key (b (not a))) b))))
+    (is (eql nil  (funcall (lambda (&optional a &key (b (not a)))
+                             b)
+                           t)))
+    (is (eql 42 (funcall (lambda (&optional a &key (b (not a)))
+                           b)
+                         t :b 42)))))
+
+(defun/cc test-defun/cc1 ()
+  (let/cc k k))
+
+(defun/cc test-defun/cc2 (arg1)
+  (let/cc k k)
+  arg1)
+
+(defun/cc test-defun/cc3 (a &key (b 1))
+  (+ a b))
+
+(test call/cc-defun/cc
+  (let ((cont nil))
+    (setf cont (with-call/cc (test-defun/cc1)))
+    (is (eql nil (kall cont nil)))
+
+    (setf cont (with-call/cc (test-defun/cc2 'foo)))
+    (is (eql 'foo (kall cont)))
+    (is (eql 'foo (kall cont nil)))
+
+    (with-call/cc
+      (is (= 1 (test-defun/cc3 0)))
+      (is (= 2 (test-defun/cc3 1))))))
+
+(defgeneric/cc test-generic/cc (a &key v))
+
+(defmethod/cc test-generic/cc ((a symbol) &key (v 3))
+  v)
+
+(defmethod/cc test-generic/cc ((a string) &key (v 5))
+  v)
+
+(test call/cc-defgeneric/cc
+  (with-call/cc
+    (is (= 3 (test-generic/cc 'a)))
+    (is (= 0 (test-generic/cc 'a :v 0)))
+    (is (= 5 (test-generic/cc "a")))
+    (is (= 0 (test-generic/cc "a" :v 0)))))
+
+(defmethod/cc test-generic/cc2 :before (a)
+  (let/cc k 'before))
+
+(defmethod/cc test-generic/cc2 (a)
+  'primary)
+
+(test test-generic/cc2
+  (with-call/cc
+   (is (eql 'before (test-generic/cc2 t)))))
+
+(defmethod/cc test-generic/cc3 :before (a)
+  (let/cc k (cons 'before k)))
+
+(defmethod/cc test-generic/cc3 :around (a)
+  (let/cc k (cons 'around k))
+  (call-next-method a))
+
+(defmethod/cc test-generic/cc3 (a)
+  (let/cc k (cons 'primary k))
+  a)
+
+(defmethod/cc test-generic/cc3 :after (a)
+  (let/cc k (cons 'after k)))
+
+(test call/cc-defgeneric/cc3
+  (destructuring-bind (value . cont)
+      (with-call/cc (test-generic/cc3 32))
+    (is (eql 'around value))
+    (destructuring-bind (value . cont)
+        (with-call/cc (kall cont))
+      (is (eql 'before value))
+      (destructuring-bind (value . cont)
+          (with-call/cc (kall cont))
+        (is (eql 'primary value))
+        (destructuring-bind (value . cont)
+            (with-call/cc (kall cont))
+          (is (eql 'after value))
+          (is (eql 32 (kall cont))))))))
+
+(test call/cc-loop
+  (let ((cont (with-call/cc
+                (loop
+                   repeat 2
+                   sum (let/cc k k) into total
+                   finally (return (values total total))))))
+    (multiple-value-bind (a b)
+        (kall (kall cont 1) 2)
+      (is (= 3 a))
+      (is (= 3 b))))
+
+  (let ((cont (with-call/cc
+                (block done
+                  (loop
+                     for how-many = (let/cc k k)
+                     do (loop
+                           repeat how-many
+                           sum (let/cc k k) into total
+                           finally (return-from done total)))))))
+    (is (= 26 (kall (kall (kall cont 2) 13) 13)))))
+
+(test common-lisp/cc
+  (let (cont value)
+    (setf cont (with-call/cc (mapcar (lambda (x)
+                                       (+ x (let/cc k k)))
+                                     (list 1 2 3))))
+    (setf cont (with-call/cc (kall cont -1))
+          cont (with-call/cc (kall cont -2))
+          value (with-call/cc (kall cont -3)))
+    (is (equal (list 0 0 0) value))))
+
+(defun/cc throw-something (something)
+  (throw 'done something))
+
+(test catch/cc
+  (with-call/cc
+    (is (eql t
+             (catch 'whatever
+               (throw 'whatever t)
+               (throw 'whatever nil)
+               'something-else)))
+    (is (eql t
+             (catch 'whatever
+               t)))
+    (is (eql t
+             (flet ((throw-it (it)
+                      (throw 'done it)))
+               (catch 'done
+                 (throw-it t)
+                 (throw 'done 'bad-bad-bad)))))
+    (is (eql t
+             (catch 'done
+               (throw-something t)
+               nil)))))
+
+(test multiple-value-call
+  (with-call/cc
+      (is (= 1 (multiple-value-call
+                   #'identity
+                 (values 1)))))
+  (with-call/cc
+      (is (= 3 (length (multiple-value-call
+                           #'list
+                         (values 1)
+                         (values 1)
+                         (values 1))))))
+
+  (with-call/cc
+      (is (= 3 (multiple-value-call
+                   (lambda (a b)
+                     (+ a b))
+                 (values 1 2)))))
+
+  (with-call/cc
+      (is (= 3 (multiple-value-call
+                   (lambda (&rest numbers)
+                     (reduce #'+ numbers))
+                 (values -1 1)
+                 (values 1)
+                 (values -1)
+                 (values 1 2))))))
+
+;;; speical variable handling
+(defun/cc lookup-special-in-defun/cc (stop)
+  (declare (special var))
+  (when stop (let/cc k k))
+  var)
+
+(defun/cc lookup-special-in-let/cc (stop)
+  (let ((normal 0))
+    (declare (special var))
+    (when stop (let/cc k k))
+    var))
+
+(defun/cc lookup-special-in-let*/cc (stop)
+  (let* ((normal 0))
+    (declare (special var))
+    (when stop (let/cc k k))
+    var))
+
+(defun lookup-special-in-lisp ()
+  (declare (special var))
+  var)
+
+(defun/cc define-and-lookup-special-in-defun/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (when stop (let/cc k k))
+    var))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-defun/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (lookup-special-in-defun/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-let/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (lookup-special-in-let/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-let*/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (lookup-special-in-let*/cc stop)))
+
+(defun/cc export-special-from-let/cc-and-lookup-in-lisp (stop)
+  (let ((var 1))
+    (declare (special var))
+    (when stop (let/cc k k))
+    (lookup-special-in-lisp)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-defun/cc (stop)
+  (let* ((var 1))
+    (declare (special var))
+    (lookup-special-in-defun/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-let/cc (stop)
+  (let* ((var 1))
+    (declare (special var))
+    (lookup-special-in-let/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-let*/cc (stop)
+  (let* ((var 1))
+    (declare (special var))
+    (lookup-special-in-let*/cc stop)))
+
+(defun/cc export-special-from-let*/cc-and-lookup-in-lisp (stop)
+  (let* ((var 1))
+    (declare (special var))
+    (when stop (let/cc k k))
+    (lookup-special-in-lisp)))
+
+(defun export-special-from-lisp-and-lookup-in-defun/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (with-call/cc
+      (lookup-special-in-defun/cc stop))))
+
+(defun export-special-from-lisp-and-lookup-in-let/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (with-call/cc
+      (lookup-special-in-let/cc stop))))
+
+(defun export-special-from-lisp-and-lookup-in-let*/cc (stop)
+  (let ((var 1))
+    (declare (special var))
+    (with-call/cc
+      (lookup-special-in-let*/cc stop))))
+
+(defmacro test-special (name)
+  (let ((body-without-stop `(,name nil))
+        (body-with-stop `(,name t)))
+    `(test ,name
+      (is (= 1 (with-call/cc ,body-without-stop)))
+      (signals unbound-variable
+        (with-call/cc ,body-without-stop (lookup-special-in-lisp)))
+      (signals unbound-variable
+        (with-call/cc ,body-without-stop (lookup-special-in-defun/cc nil)))
+      ;; now stop once
+      (is (= 1 (kall (with-call/cc ,body-with-stop))))
+      (signals unbound-variable
+        (kall (with-call/cc ,body-with-stop (lookup-special-in-lisp))))
+      (signals unbound-variable
+        (kall (with-call/cc ,body-with-stop (lookup-special-in-defun/cc nil)))))))
+
+;; export and lookup in the same lexical environment
+(test-special define-and-lookup-special-in-defun/cc)
+
+;; export and lookup in cc code
+(test-special export-special-from-let/cc-and-lookup-in-defun/cc)
+(test-special export-special-from-let/cc-and-lookup-in-let/cc)
+(test-special export-special-from-let/cc-and-lookup-in-let*/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-defun/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-let/cc)
+(test-special export-special-from-let*/cc-and-lookup-in-let*/cc)
+
+;; export from cc code and lookup in lisp code
+(test-special export-special-from-let/cc-and-lookup-in-lisp)
+(test-special export-special-from-let*/cc-and-lookup-in-lisp)
+
+;; export from lisp code and lookup in cc code
+(test-special export-special-from-lisp-and-lookup-in-defun/cc)
+(test-special export-special-from-lisp-and-lookup-in-let/cc)
+(test-special export-special-from-lisp-and-lookup-in-let*/cc)
+
+;; export in lisp code let it go through some cc code and lookup in lisp code after continuing
+(test export-special-from-lisp-and-lookup-in-lisp
+  (is (= 1
+         (kall (let ((var 1))
+                 (declare (special var))
+                 (with-call/cc
+                   (let () ;; TODO: shouldn't we allow declares within with-call/cc?
+                     (declare (special var))
+                     (let/cc k k)
+                     (lookup-special-in-lisp))))))))
+
+(defvar *special-variable-in-lisp* 42)
+
+(test special-lisp-var-rebound-in/cc
+  (is (= 42
+         (with-call/cc
+           *special-variable-in-lisp*)))
+  (is (= 43
+         (with-call/cc
+           (let ((*special-variable-in-lisp* 43))
+             ;;(declare (special *special-variable-in-lisp*)) ; TODO shouldn't be needed
+             *special-variable-in-lisp*)))))

Added: branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/csv.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,24 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.csv :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.csv)
+
+(test csv.1
+  (is (equal '("1" "2" "3")
+	     (arnesi:parse-csv-string "1,2,3")))
+  (is (equal '("1" "2" "3")
+	     (arnesi:parse-csv-string "1;2;3" :separator #\;)))
+  (is (equal '("1" "2;" "3")
+	     (arnesi:parse-csv-string "1;'2;';3" :separator #\; :quote #\'))))
+
+(test csv.2
+  ;; this corresponds to the quoting used in princ-csv
+  (is (equal '("1" "2'" "3")
+	     (arnesi:parse-csv-string "1;'2''';3" :separator #\; :quote #\')))
+  (is (equal '("1" "2'" "3")
+	     (arnesi:parse-csv-string "1;'2''';'3'" :separator #\; :quote #\'))))
+

Added: branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/flow-control.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,89 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.flow-control :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.flow-control)
+
+(test flow-control
+  (let ((ht (make-hash-table)))
+    (setf (gethash 'a ht) 1)
+    (setf (gethash 'b ht) 'a)
+
+    ;; if-bind and aif
+    (is (= 3 (if-bind var (gethash 'z ht) (1+ var) 3)))
+    (is (= 2 (if-bind var (gethash 'a ht) (1+ var) 3)))
+    (is (= 3 (aif (gethash 'z ht) (1+ it) 3)))
+    (is (= 2 (aif (gethash 'a ht) (1+ it) 3)))
+    ;; when-bind and awhen
+    (let ((result nil))
+      (when-bind var (gethash 'z ht)
+        (setf result (1+ var)))
+      (is (null result))
+      (when-bind var (gethash 'a ht)
+        (setf result (1+ var)))
+      (is (= 2 result))
+      (setf result nil)
+      (awhen (gethash 'z ht)
+        (setf result (1+ it)))
+      (is (null result))
+      (awhen (gethash 'a ht)
+        (setf result (1+ it)))
+      (is (= 2 result)))
+    ;; cond-bind and acond
+    (is (= 99 (cond-bind var
+                ((gethash 'z ht) (1+ var))
+                ((gethash 'y ht) (1+ var))
+                (t 99))))
+    (is (= 2 (cond-bind var
+               ((gethash 'z ht) (1+ var))
+               ((gethash 'a ht) (1+ var))
+                (t 99))))
+    (is (= 1 (cond-bind var
+              ((gethash 'z ht))
+              ((gethash 'y ht))
+              ((gethash 'a ht))
+              (t 99))))
+    (is (= 99 (acond
+               ((gethash 'z ht) (1+ it))
+               ((gethash 'y ht) (1+ it))
+                (t 99))))
+    (is (= 2 (acond
+              ((gethash 'z ht) (1+ it))
+              ((gethash 'a ht) (1+ it))
+              (t 99))))
+    (is (= 2 (acond
+              ((gethash 'z ht))
+              ((gethash 'a ht) (1+ it))
+              (t 99))))
+    ;; and-bind and aand
+    (is-false (and-bind var (gethash 'z ht) (gethash var ht) (1+ var)))
+    (is (= 2 (and-bind var (gethash 'b ht) (gethash var ht) (1+ var))))
+    (is-false (aand (gethash 'z ht) (gethash it ht) (1+ it)))
+    (is (= 2 (aand (gethash 'b ht) (gethash it ht) (1+ it))))
+    ;; whichever
+    (let ((result 0))
+      (is (member (whichever (progn (incf result) 'a)
+                             (progn (incf result) 'b)
+                             (progn (incf result) 'c))
+                  '(a b c)))
+      (is (= 1 result)))
+    ;; xor
+    (let ((result 0))
+      (is (eq 'a (xor (progn (incf result) 'a)
+                      (progn (incf result) nil)
+                      (progn (incf result) nil))))
+      (is (= 3 result))
+      (setf result 0)
+      (is (eq 'a (xor (progn (incf result) nil)
+                      (progn (incf result) 'a)
+                      (progn (incf result) nil))))
+      (is (= 3 result))
+      (setf result 0)
+      (is-false (xor (progn (incf result) 'a)
+                     (progn (incf result) 'b)
+                     (progn (incf result) 'c)))
+      (is (= 2 result)))))
+    

Added: branches/trunk-reorg/thirdparty/arnesi/t/http.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/http.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,38 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.http :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.http)
+
+(test escape-uri
+  (for-all ((uri (gen-string :elements (gen-character :code-limit #16rffff))))
+    (is (string= uri (unescape-as-uri (escape-as-uri uri)))))
+
+  (is (string= (unescape-as-uri "a+b+c")
+               "a b c")))
+
+(defmacro help-test-bad-uri (uri expected-error)
+  `(progn
+     (signals ,expected-error
+       (unescape-as-uri ,uri))
+     (finishes
+       (unescape-as-uri-non-strict ,uri))
+     (let ((returned (unescape-as-uri-non-strict ,uri)))
+       (is (> (length returned) (* 0.5 (length ,uri)))) ; a big chunk should be returned
+       (is (string= (subseq returned 0 8) ; that is looking like a proper url
+                    (subseq ,uri 0 8))))))
+
+(test unescape-uri/iso8859-1-instead-of-utf8
+  (help-test-bad-uri "http://router.advertising.se/?&CHANNEL_ID=1&SITE_KEY=Webbhotell%20f%F6r%20att%20placera%20en%20Tower%20server?&SITE_ALT_KEY=&SITE_URL=http%3A%2F%2Fwww.webmasternetwork.se%2Ff13t11622.html&REF=http%3A%2F%2Fwww.webmasternetwork.se%2Ff13.html"
+                     error))
+
+(test unescape-uri/wrong-percentage-quoting
+  (help-test-bad-uri "http://ad.doubleclick.net/adi/N763.business_week_online/B1803870.12;sz=468x60;ord=%%REALREAND%%?"
+                     expected-digit-uri-parse-error))
+
+(test unescape-uri/percentage-at-end
+  (help-test-bad-uri "http://groups.google.com/groups/adfetch?adid=zMKqMREAAAAwVvp0Nmmxmm2KqccSr5KzFSRgCP-avRN4YT0eROC0jw&hl=en&sabc=%23eeeeee&sabcg=239&siphc=%23999999&siphfc=%23ffffff&w=100%"
+                     uri-parse-error))

Added: branches/trunk-reorg/thirdparty/arnesi/t/list.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/list.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,34 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.list :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.list)
+
+(test proper-list-p
+  (is-true (proper-list-p '()))
+  (is-true (proper-list-p '(nil)))
+  (is-true (proper-list-p '(nil nil)))
+  (is-true (proper-list-p '(nil nil nil)))
+  (is-true (proper-list-p '(nil . nil)))
+  (is-true (proper-list-p '(nil nil . nil)))
+  (is-true (proper-list-p '(nil nil nil . nil)))
+  (is-false (proper-list-p 1))
+  (is-false (proper-list-p '(a . b)))
+  (let ((a (cons nil nil)))
+    (setf (cdr a) a)
+    (is-false (proper-list-p a)))
+  (let ((a (list nil nil)))
+    (setf (cdr (last a)) a)
+    (is-false (proper-list-p a)))
+  (let ((a (list nil nil nil nil nil)))
+    (setf (cdr (last a)) a)
+    (is-false (proper-list-p a)))
+  (let ((a (list nil nil nil nil nil)))
+    (setf (first a) a
+	  (car (last a)) a
+	  (cdr (last a)) a)
+    (is-false (proper-list-p a))))
+  

Added: branches/trunk-reorg/thirdparty/arnesi/t/log.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/log.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,39 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.log :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.log)
+
+#|
+(defparameter a-handler (make-instance 'collecting-log-handler))
+
+(deflogger log-a ()
+  :appender a-handler
+  :level +dribble+)
+
+(deflogger log-b (log-a))
+
+(deflogger log-c (log-a))
+
+(deflogger log-d (log-c))
+
+(test log1
+  (log-a.dribble "FOO")
+  (is (string= "FOO" (car (slot-value (car (appenders (get-logger 'log-a))) 'messages))))
+
+  (setf (log.level (get-logger 'log-a)) +warn+)
+  (is (= +warn+ (log.level (get-logger 'log-d))))
+
+  (setf (log.level (get-logger 'log-d)) +dribble+)
+  (is (= +dribble+ (log.level (get-logger 'log-d))))
+  (is (= +warn+ (log.level (get-logger 'log-b))))
+  (is (= +warn+ (log.level (get-logger 'log-c))))
+
+  (is (enabled-p (get-logger 'log-d) +warn+))
+  (is (enabled-p (get-logger 'log-a) +warn+))
+  (is (not (enabled-p (get-logger 'log-a) +dribble+))))
+
+|#
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/matcher.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,99 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.matcher :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.matcher)
+
+(test eql
+  (is-true (match '(:EQL 1) 1))
+  (is-false (match `(:EQL ,(gensym)) (gensym)))
+  (let ((sym (gensym)))
+    (is-true (match `(:EQL ,sym) sym))))
+
+(test cons
+  (is-true (match '(:CONS (:EQL NIL) (:EQL NIL)) (cons nil nil)))
+  (is-true (match '(:CONS 'a 'b) (cons 'a'b))))
+
+(test list
+  (is-true (match '(:LIST 'A) '(a)))
+  (is-true (match '(:LIST 'A NIL) '(a nil)))  
+  (is-true (match '(:LIST 'A 'B) '(a b)))
+  (is-true (match '(:LIST 'A 'B :ANYTHING) '(a b c)))
+  (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b)))
+  (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b . 444)))
+  (is-true (match '(:LIST* 'A 'B :ANYTHING) '(a b 444 555 666))))
+
+(test alt
+  (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'a))
+  (is-true (match `(:ALTERNATION (:EQL a) (:EQL b)) 'b))
+  (is-false (match `(:ALTERNATION (:EQL a) (:EQL b)) 'c))
+  (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'a))
+  (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'b))
+  (is-true (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'c))
+  (is-false (match `(:ALT (:EQL a) (:EQL b) (:EQL c)) 'd)))
+
+(test bind/ref
+  (is-true (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 1)))
+  (is-false (match `(:CONS (:BIND :ANYTHING $1) (:REF $1)) (cons 1 2)))
+  (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'a)))
+  (is-true (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'b)))
+  (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'b 'a)))
+  (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 'a 'b)))
+  (is-false (match `(:CONS (:BIND (:ALT (:EQL a) (:EQL b)) $1) (:REF $1)) (cons 1 1)))
+  (is-true (match `(:CONS (:BIND (:EQUALP "AAA") aaa) (:REF aaa :test equalp)) (cons "AAA" "aaa"))))
+
+(test sym-group
+  (is-true (match `(:CONS a (:REF a)) (cons 1 1)))
+  (is-false (match `(:CONS a (:NOT (:REF a))) (cons 1 1)))
+  (is-true (match `(:CONS a (:NOT (:REF a))) (cons 1 2))))
+
+(test match-case
+  (match-case '(1 . 1)
+    ((:CONS (:BIND (:EQL 1) a) (:REF a)) (is (= 1 a)))
+    (:ANYTHING (fail)))
+  (match-case '(1 . 2)
+    ((:CONS a b) (is (= 1 a)) (is (= 2 b)))
+    (:ANYTHING (fail "For some odd reason we didn't match")))
+  (match-case '(1 . 2)
+	      ((:LIST* (:BIND :ANYTHING a) (:BIND :ANYTHING b)) (is (= 1 a)) (is (= 2 b))))) 
+
+(test and
+  (match-case 3
+	      ((:AND (:TEST numberp) (:TEST oddp))
+	       (pass))
+	      (:ANYTHING (fail)))
+  (match-case 2
+	      ((:AND (:TEST numberp) (:TEST oddp))
+	       (fail))
+	      (:ANYTHING (pass))))
+
+(defclass foo ()
+  ((x :initarg :x :accessor x)
+   (z :initarg :z :accessor z)))
+
+(test accessors
+  (match-case (make-instance 'foo :x 1 :z 2)
+	      ((:ACCESSORS foo x x z z)
+	       (is (= 1 x))
+	       (is (= 2 z)))
+	      (:ANYTHING (fail)))
+  (match-case (make-instance 'foo :x 1 :z 2)
+	      ((:ACCESSORS standard-object x a z b)
+	       (is (= 1 a))
+	       (is (= 2 b)))
+	      (:ANYTHING (fail)))
+  (match-case (make-instance 'foo :x 1 :z 2)
+	      ((:ACCESSORS cons x a z b)
+	       a b			; we won't need them...
+	       (fail))
+	      (:ANYTHING (pass))))
+
+(test plist  
+  (match-case '(:b 2 :a 1)
+	      ((:PLIST :a a :b b)
+	       (is (= 1 a))
+	       (is (= 2 b)))
+	      (:ANYTHING (fail))))

Added: branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/numbers.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,43 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.numbers)
+
+(test mulf
+  (let ((a 0))
+    (is (= 0 (mulf a 10)))
+    (is (= 0 a)))
+  (for-all ((a (gen-integer))
+            (b (gen-integer)))
+    (let ((orig-a a))
+      (mulf a b)
+      (is (= a (* orig-a b)))))
+
+  (let ((a 1))
+    (is (= 4 (mulf a 4)))
+    (is (= 1 (mulf a (/ 4))))
+    (is (= 1 a))))
+
+(test minf
+  (let ((a 10))
+    (is (= 5 (minf a 5)))
+    (is (= 5 a)))
+
+  (let ((a 0))
+    (is (= 0 (minf a 10)))
+    (is (= 0 a))))
+
+(test parse-float
+  (is (= 0 (parse-float "0")))
+  (is (= -1 (parse-float "-1")))
+  (is (= 1 (parse-float "1")))
+
+  (dolist (type '(short-float single-float double-float long-float))
+    (for-all ((float (gen-float :type type :bound 1000)))
+      (let* ((*print-base* 10)
+             (*print-radix* nil))
+        (is (= float (parse-float (princ-to-string float) :type type)))))))

Added: branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/queue.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,80 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.queue :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.queue)
+
+(test make-queue
+  (is (queue-empty-p (make-instance 'queue)))
+  (is (eql 'empty (dequeue (make-instance 'queue) 'empty))))
+
+(test queue-not-full-no-wrapping
+  (let ((q (make-instance 'queue)))
+    (enqueue q 1)
+    (is (= 1 (dequeue q)))
+    (enqueue q 1)
+    (enqueue q 2)
+    (is (= 1 (dequeue q)))
+    (is (= 2 (dequeue q)))))
+
+(test queue-full-not-wrapping
+  (let ((q (make-instance 'queue :size 2)))
+    (enqueue q 1)
+    (enqueue q 2) ;; this causes the size to grow to 2
+    (enqueue q 3) ;; this causes the size to grow to 4
+    (enqueue q 4) ;; this doesn't affect the size
+    (enqueue q 5) ;; this couses the size to grow to 8
+    (is (= 1 (dequeue q)))
+    (is (= 2 (dequeue q)))
+    (is (= 3 (dequeue q)))
+    (is (= 4 (dequeue q)))
+    (is (= 5 (dequeue q)))))
+
+(test queue-not-full-wrapping
+  (let ((q (make-instance 'queue :size 2)))
+    (enqueue q 1)
+    (is (= 1 (queue-count q)))
+    (is (= 1 (dequeue q)))
+    (enqueue q 1)
+    (is (= 1 (queue-count q)))
+    (is (= 1 (dequeue q)))))
+
+(test queue-full-wrapping
+  (let ((q (make-instance 'queue :size 2)))
+    (setf (arnesi::head-index q) 2
+          (arnesi::tail-index q) 1
+          (arnesi::buffer q) #(0 1))
+    q
+    (enqueue q 2)
+    (is (= 1 (dequeue q)))
+    (is (= 2 (dequeue q)))))
+
+(test queue
+  (for-all ((item (gen-integer :min -10 :max 10)))
+    (let ((q (make-instance 'queue)))
+      (enqueue q item)
+      (is (= item (dequeue q)))
+      (is (= 0 (queue-count q)))))
+  (for-all ((one (gen-list :length (gen-integer :min 2 :max 3)
+                           :elements (gen-integer :min -10 :max 10)))
+            (two (gen-list :length (gen-integer :min 2 :max 3)
+                           :elements (gen-integer :min -10 :max 10)))
+            (three (gen-list :length (gen-integer :min 2 :max 3)
+                             :elements (gen-integer :min -10 :max 10))))
+    (let ((q (make-instance 'queue :size (1- (+ (length one)
+                                                (length two)
+                                                (length three))))))
+      (flet ((enqueue-all (list)
+               (loop for e in list do (enqueue q e)))
+             (dequeue-all (list)
+               (loop for e in list do (is (= e (dequeue q))))))
+        (enqueue-all one)
+        (enqueue-all two)
+        (dequeue-all one)
+        (enqueue-all three)
+        (dequeue-all two)
+        (dequeue-all three))
+      (is (queue-empty-p q)))))

Added: branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/read-macros.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,18 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(in-suite :it.bese.arnesi)
+
+(test bracket-reader
+  (enable-bracket-syntax)
+  (is (= 7 (read-from-string "{(constantly 7)}")))  
+  (destructuring-bind (progn a b c)
+      (let ((*package* (find-package :common-lisp-user)))
+        (read-from-string "{(arnesi::with-package :arnesi) a b c}"))
+    (is (eql 'cl:progn progn))
+    (is (eql 'arnesi::a a))
+    (is (eql 'arnesi::b b))
+    (is (eql 'arnesi::c c))))
+
+

Added: branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/sequence.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,20 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.sequence :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.sequence)
+
+(test levenshtein-distance 
+  (is (= 4 (levenshtein-distance "aaaa" "")))
+  (is (= 4 (levenshtein-distance "" "aaaa")))
+  (is (= 0 (levenshtein-distance "" "")))
+  (is (= 0 (levenshtein-distance "a" "a")))
+  (is (= 2 (levenshtein-distance "aa" "cc")))
+  (is (= 1 (levenshtein-distance "a" "aa")))
+  (is (= 1 (levenshtein-distance "ab" "aa")))
+  (is (= 1 (levenshtein-distance "test" "tent"))))
+
+

Added: branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/sharpl.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,93 @@
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.sharpl :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.sharpl)
+
+(enable-sharp-l-syntax)
+
+(test sharpl-simple
+  (is (eql 42 (funcall #L42))))
+
+(test sharpl-mb-example
+  (is (eql 6 (funcall #L(block !2 (return-from !2 !1)) 6))))
+
+(test sharpl-finds-variables
+  (is (eql 111 (funcall #L(+ !1 !2) 42 69))))
+
+(test sharpl-no-variable-in-quote
+  (is (eq (funcall #L'!1) '!1)))
+
+(test sharpl-not-captures-outer-bang
+  (let ((!1 42))
+    (declare (ignore !1))
+    (is (eql 69 (funcall #L!1 69)))))
+
+(test sharpl-nested-simple
+  (is (eql 1 (funcall (funcall #L#L1)))))
+
+(test sharpl-nested-arg
+  (is (eql 42 (funcall (funcall #L#L!1) 42))))
+
+(test sharpl-nested-complex
+  (is (eql 3 (funcall 
+	      (funcall #L(let ((a !1)) 
+                           #L(+ !1 a))
+		       1)
+	      2))))
+
+(test sharpl-symbol-macrolet-1
+  (is (eql 3 (symbol-macrolet ((sym !1)) (funcall #Lsym 3)))))
+
+(test sharpl-symbol-macrolet-2
+  (is (eql 3 (funcall (symbol-macrolet ((sym !1))
+                        #Lsym)
+                      3))))
+
+(test sharpl-macrolet-1
+  (is (eql 15 (macrolet ((mac (arg) `(+ !1 ,arg)))
+                (funcall #L(mac 10) 5)))))
+
+(test sharpl-macrolet-2
+  (is (eql 15 (funcall (macrolet ((mac (arg) `(+ !1 ,arg)))
+                         #L(mac 10))
+                       5))))
+
+(test sharpl-inner-macrolet
+  (is (eql 15 (funcall 
+	       #L(macrolet ((!2 () '!1)) (!2))
+	       15))))
+
+(test sharpl-inner-symbol-macrolet
+  (is (eql 15 (funcall 
+	       #L(symbol-macrolet ((!2 !1)) (+ !2 10))
+	       5))))
+
+(test sharpl-bang-binds-to-innermost
+  (is (eql 10 (funcall 
+	       (funcall #L(let ((a !1))
+                            #L(+ a !1))
+			6)
+	       4))))
+
+(test sharpl-interposed-macrolet
+  (is (eql 6 (funcall
+              (funcall #L(macrolet ((mac () '!1))
+                           #L(mac)))
+              6))))
+
+(test sharpl-nested-macrolet
+  (is (eql 21 (funcall
+               (funcall
+                #L(macrolet ((return-bang () ''!1))
+                    (macrolet ((multiply-first-bang (arg) `(* ,arg ,(return-bang))))
+                      #L(+ (multiply-first-bang 2) 1))))
+               10))))
+                          
+(test sharpl-interposed-symbol-macrolet
+  (is (eql 'result (funcall
+                    (funcall #L(symbol-macrolet ((mac !1))
+                                 #Lmac))
+              'result))))
+  

Added: branches/trunk-reorg/thirdparty/arnesi/t/string.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/string.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,9 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.string :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.string)
+

Added: branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/suite.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,13 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi)
+
+(defpackage :it.bese.arnesi.test
+  (:use :common-lisp
+        :it.bese.arnesi
+        :it.bese.FiveAM))
+
+(unless (5am:get-test :it.bese)
+  (5am:def-suite :it.bese))
+
+(5am:def-suite :it.bese.arnesi :in :it.bese)

Added: branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/t/walk.lisp	Mon Feb 11 08:38:43 2008
@@ -0,0 +1,195 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.arnesi.test)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-suite :it.bese.arnesi.walk :in :it.bese.arnesi))
+
+(in-suite :it.bese.arnesi.walk)
+
+(defun test-walk (form)
+  (values (equal (unwalk-form (walk-form form)) form)
+	  (unwalk-form (walk-form form))
+	  form))
+
+(test walk-constant
+  (is (test-walk 1))
+  (is (test-walk ''a))
+  (is (test-walk "a"))
+  (is (test-walk '(1 2 3)))
+  (is (test-walk '#(1 2 3))))
+
+(test walk-variable
+  (is (test-walk 'var)))
+
+(test walk-application
+  (is (test-walk '(* 2 3)))
+  (is (test-walk '(+ (* 3 3) (* 4 4)))))
+
+(test walk-lambda-application
+  (is (test-walk '((lambda (x) (x x)) #'(lambda (x) (x x)))))
+  (is (test-walk '((lambda (x k) (k x)) (if p x y) id))))
+
+(test walk-lambda-function
+  (is (test-walk '#'(lambda (x y) (y x))))
+  (is (test-walk '#'(lambda (x &key y z) (z (y x)))))
+  (is (test-walk '#'(lambda (&optional port) (close port))))
+  (is (test-walk '#'(lambda (x &rest args) (apply x args))))
+  (is (test-walk '#'(lambda (object &key a &allow-other-keys) (values))))
+  ;; Unwalking argument lists is lax.
+  (is (test-walk '#'(lambda (&rest args &key a b &optional x &allow-other-keys) 2))))
+
+(test walk-block
+  (is (test-walk '(block label (get-up) (eat-food) (go-to-sleep))))
+  (is (test-walk '(block label ((lambda (f x) (f (f x))) #'car))))
+  (is (test-walk '(block label (reachable) (return-from label 'done) (unreachable)))))
+
+(test walk-catch
+  (is (test-walk '(catch 'done (with-call/cc* (* 2 3)))))
+  (is (test-walk '(catch 'scheduler
+		   (tagbody start
+		      (funcall thunk)
+		      (if (done-p) (throw 'scheduler 'done) (go start))))))
+  (is (test-walk '(catch 'c
+		   (flet ((c1 () (throw 'c 1)))
+		     (catch 'c (c1) (print 'unreachable))
+		     2)))))
+
+(test walk-if
+  (is (test-walk '(if p x y)))
+  (is (test-walk '(if (pred x) (f x) (f-tail y #(1 2 3))))))
+
+(test walk-flet
+  (is (test-walk '(flet ((sq (x)
+			  (* x x)))
+		   (+ (sq 3) (sq 4)))))
+  (is (test-walk '(flet ((prline (s)
+			  (princ s)
+			  (terpri)))
+		   (prline "hello")
+		   (prline "world")))))
+
+(test walk-labels
+  (is (test-walk '(labels ((fac-acc (n acc)
+			    (if (zerop n)
+				(land acc)
+				(bounce
+				 (fac-acc (1- n) (* n acc))))))
+		   (fac-acc (fac-acc 10 1) 1))))
+  (is (test-walk '(labels ((evenp (n)
+			    (if (zerop n) t (oddp (1- n))))
+			   (oddp (n)
+			    (if (zerop n) nil (evenp (1- n)))))
+		   (oddp 666)))))
+
+(test walk-let
+  (is (test-walk '(let ((a 2) (b 3) (c 4))
+		   (+ (- a b) (- b c) (- c a)))))
+  (is (test-walk '(let ((a b) (b a)) (format t "side-effect~%") (f a b)))))
+
+(test walk-let*
+  (is (test-walk '(let* ((a (random 100)) (b (* a a))) (- b a))))
+  (is (test-walk '(let* ((a b) (b a)) (equal a b)))))
+
+(test walk-load-time-value
+  (is (test-walk '(load-time-value *load-pathname* nil))))
+
+(test walk-locally
+  (is (test-walk '(locally (setq *global* (whoops))))))
+
+(test walk-macrolet
+  (is (unwalk-form
+       (walk-form
+	'(macrolet ((+ (&body body)
+		     (reverse body)))
+	  (+ 1 2 3 -))))
+      '(locally (- 3 2 1)))
+  (is (unwalk-form
+       (walk-form
+	'(macrolet ())))
+      '(locally ()))
+  (is (unwalk-form
+       (walk-form
+	'(macrolet ((+ (&body body)
+		     (reverse body)))
+	  (princ "1111")
+	  (+ 1 2 3 -))))
+      '(locally
+	(princ "1111")
+	(- 3 2 1))))
+
+(test walk-multiple-value-call
+  (is (test-walk '(multiple-value-call #'list 1 '/ (values 2 3) '/ (values) '/ (floor 2.5))))
+  (is (test-walk '(multiple-value-call #'+ (floor 5 3) (floor 19 4)))))
+
+(test walk-multiple-value-prog1
+  (is (test-walk '(multiple-value-prog1
+		   (values-list temp)
+		   (setq temp nil)
+		   (values-list temp)))))
+
+(test walk-progn
+  (is (test-walk '(progn (f a) (f-tail b) c)))
+  (is (test-walk '(progn #'(lambda (x) (x x)) 2 'a))))
+
+(test walk-progv
+  (is (test-walk '(progv '(*x*) '(2) *x*))))
+
+(test walk-setq
+  (is (test-walk '(setq x '(2 #(3 5 7) 11 "13" '17))))
+  (is (test-walk '(setq *global* 'symbol))))
+
+(test walk-symbol-macrolet
+  (is (unwalk-form
+       (walk-form
+	'(symbol-macrolet ((a (slot-value obj 'a))
+			   (b (slot-value obj 'b)))
+	  (+ a b))))
+      '(locally
+	(+ (slot-value obj 'a) (slot-value obj 'b))))
+  (is (unwalk-form
+       (walk-form
+	'(symbol-macrolet ())))
+      '(locally))
+  (is (unwalk-form
+       (walk-form
+	'(symbol-macrolet ((a (slot-value obj 'a)))
+	  (double! a)
+	  (/ a 2))))
+      '(locally
+	(double! (slot-value obj 'a))
+	(/ (slot-value obj 'a) 2))))
+
+(test walk-tagbody
+  (is (test-walk '(tagbody
+		   (setq val 1)
+		   (go point-a)
+		   (setq val (+ val 16))
+		   point-c
+		   (setq val (+ val 4))
+		   (go point-b)
+		   (setq val (+ val 32))
+		   point-a
+		   (setq val (+ val 2))
+		   (go point-c)
+		   (setq val (+ val 64))
+		   point-b
+		   (setq val (+ val 8)))))
+  (is (test-walk '(tagbody 
+		   (setq n (f2 flag #'(lambda () (go out))))
+		   out
+		   (prin1 n)))))
+
+(test walk-the
+  (is (test-walk '(the number (reverse "naoh"))))
+  (is (test-walk '(the string 1))))
+
+(test walk-unwind-protect
+  (is (test-walk '(unwind-protect
+		   (progn (setq count (+ count 1))
+			  (perform-access))
+		   (setq count (- count 1)))))
+  (is (test-walk '(unwind-protect
+		   (progn (with-call/cc* (walk-the-plank))
+			  (pushed-off-the-plank))
+		   (save-life)))))


From ksprotte at common-lisp.net  Mon Feb 11 14:06:37 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 09:06:37 -0500 (EST)
Subject: [bknr-cvs] r2470 - in branches/trunk-reorg/thirdparty/uffi: .
	benchmarks debian doc examples src src/corman tests
Message-ID: <20080211140637.6CA741603B@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 09:06:27 2008
New Revision: 2470

Added:
   branches/trunk-reorg/thirdparty/uffi/
   branches/trunk-reorg/thirdparty/uffi/AUTHORS
   branches/trunk-reorg/thirdparty/uffi/ChangeLog
   branches/trunk-reorg/thirdparty/uffi/INSTALL
   branches/trunk-reorg/thirdparty/uffi/LICENSE
   branches/trunk-reorg/thirdparty/uffi/Makefile
   branches/trunk-reorg/thirdparty/uffi/Makefile.common
   branches/trunk-reorg/thirdparty/uffi/NEWS
   branches/trunk-reorg/thirdparty/uffi/README
   branches/trunk-reorg/thirdparty/uffi/TODO
   branches/trunk-reorg/thirdparty/uffi/benchmarks/
   branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile
   branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp
   branches/trunk-reorg/thirdparty/uffi/debian/
   branches/trunk-reorg/thirdparty/uffi/debian/README.Debian
   branches/trunk-reorg/thirdparty/uffi/debian/changelog
   branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base
   branches/trunk-reorg/thirdparty/uffi/debian/compat
   branches/trunk-reorg/thirdparty/uffi/debian/control
   branches/trunk-reorg/thirdparty/uffi/debian/copyright
   branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/debian/docs
   branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/debian/postinst
   branches/trunk-reorg/thirdparty/uffi/debian/preinst   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/debian/prerm
   branches/trunk-reorg/thirdparty/uffi/debian/rules   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/debian/upload.sh   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/debian/watch
   branches/trunk-reorg/thirdparty/uffi/doc/
   branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL
   branches/trunk-reorg/thirdparty/uffi/doc/Makefile
   branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml
   branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml
   branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml
   branches/trunk-reorg/thirdparty/uffi/doc/entities.inc
   branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl
   branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml
   branches/trunk-reorg/thirdparty/uffi/doc/html.tar.gz   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi/doc/html.xsl
   branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl
   branches/trunk-reorg/thirdparty/uffi/doc/intro.xml
   branches/trunk-reorg/thirdparty/uffi/doc/notes.xml
   branches/trunk-reorg/thirdparty/uffi/doc/preface.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml
   branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml
   branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml
   branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf
   branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml
   branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod
   branches/trunk-reorg/thirdparty/uffi/examples/
   branches/trunk-reorg/thirdparty/uffi/examples/Makefile
   branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc
   branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c
   branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp
   branches/trunk-reorg/thirdparty/uffi/examples/union.lisp
   branches/trunk-reorg/thirdparty/uffi/src/
   branches/trunk-reorg/thirdparty/uffi/src/Makefile
   branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp
   branches/trunk-reorg/thirdparty/uffi/src/corman/
   branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt
   branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp
   branches/trunk-reorg/thirdparty/uffi/src/functions.lisp
   branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp
   branches/trunk-reorg/thirdparty/uffi/src/objects.lisp
   branches/trunk-reorg/thirdparty/uffi/src/os.lisp
   branches/trunk-reorg/thirdparty/uffi/src/package.lisp
   branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp
   branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp
   branches/trunk-reorg/thirdparty/uffi/src/strings.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/
   branches/trunk-reorg/thirdparty/uffi/tests/Makefile
   branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc
   branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/make.sh
   branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/package.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/time.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp
   branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c
   branches/trunk-reorg/thirdparty/uffi/tests/union.lisp
   branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd
   branches/trunk-reorg/thirdparty/uffi/uffi.asd
Log:
added uffi to thirdparty


Added: branches/trunk-reorg/thirdparty/uffi/AUTHORS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/AUTHORS	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,12 @@
+Kevin M. Rosenberg <kevin at rosenberg.net>
+  Primary author
+
+John Desoi <desoi at mac.com>
+  Contributed MCL & OpenMCL support
+
+Reini Urban <rurban at x-ray.at>
+  Contributed initial Corman support
+
+Edi Weitz <edi at weitz.de>
+  Contributed with-cast-pointer and def-foreign-var along with
+  documentation

Added: branches/trunk-reorg/thirdparty/uffi/ChangeLog
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/ChangeLog	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,354 @@
+2007-09-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* doc/Makefile, doc/html.xsl: Change output encoding from 
+	ISO-8859-1 to UTF-8
+
+2007-07-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.6.0 (SPECIFICATION CHANGE)
+	* doc/ref_func_libr.xml: Change the specification of
+	load-foreign-library to better match the actual action of the
+	function. Rather than returning NIL for failure to load library,
+	signal an error.
+	* src/libraries.lisp: Rework load-foreign-library to ensure errors
+	are signaled on failure to load library. This was the case for
+	some implementations, change the other implementations to
+	match. (Inconsistency found due to Mark Wooding's remarks)
+	
+2007-04-12 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.18
+	* src/functions.lisp: Patch from Ian Eslick for Lispworks 5
+
+2006-10-10 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.17
+	* src/functions.lisp: Patch from Edi Weitz for Lispworks 5/Linux
+
+2006-09-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.16
+	* src/libraries.lisp: Add cygwin support
+	
+2006-08-13 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.15
+	* src/{objects,strings}.lisp: Add support for Lispworks 5 
+	thanks to patches from Bill Atkins 
+
+2006-07-04 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.14
+	* src/{objects,strings}.lisp: Apply patch from Edi Weitz
+
+2006-05-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.13 
+	* src/libraries.lisp: Revert buggy patch from Yaroslav Kavenchuk.
+
+2006-05-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.12 
+	* src/libraries.lisp: Patch from Yaroslav Kavenchuk to set
+	default drive letters on MS Windows.
+
+2006-05-11 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.11: Export new macro DEF-POINTER-VAR based on patch from
+	James Bielman to support defining variables on platforms which
+	support saving objects, such as openmcl
+
+2006-04-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.10: Commit patch from Gary King for openmcl's
+	feature list change
+
+2005-11-14 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.7
+	* src/strings.lisp: Add with-foreign-strings by James Biel
+	
+2005-11-14 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.6
+	* src/os.lisp: Remove getenv setter
+
+2005-11-07 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.5
+	* src/os.lisp: Add support for getenv getter and setter
+	
+2005-09-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.4
+	* src/objects.lisp: prepend _ character for entry
+	point on Allegro macosx, patch by Luis Oliveira
+	
+2005-07-05 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.0
+	* Remove vestigial LLGPL license notices as UFFI as been
+	BSD-licensed for several years.
+	
+2005-06-09 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.39
+	* tests/objects.lisp: Rename from pointers.lisp. 
+	Fix test CHPTR.4 as noted by Jorg Hohle
+	* src/objects.lisp: Remove default from ensure-char-integer
+	
+2005-06-09 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.38
+	* src/libraries.lisp: Commit patch from Edi Weitz to
+	allow plain filename library names to allow underlying
+	lisp implementation to find foreign libraries in the
+	locations known to the operating system.
+	* tests/cast.lisp: Add :module keyword as noted by Jorg Hohle.
+	* src/strings.lisp: Avoid multiple evaluation of input
+	parameters for macros as noted by Jorg Hohle.
+	
+2005-04-12 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.37
+	* src/strings.lisp: Fix variable name
+	
+2005-04-04 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.lisp, src/aggregates.lisp: Support change in SBCL copy
+	function [Thanks for Nathan Froyd and Zach Beane]
+	
+2005-04-03 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Commit patch from James Bielman to add
+	def-foreign-var support for OpenMCL
+	
+2005-03-03 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp: Add support for :union types
+	[patch from Cyrus Harmon]
+	* tests/union.lisp, tests/structs.lisp: Tests for
+	union and structure types [from Cyrus Harmon]
+	
+2005-02-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp, src/strings.lisp: Better support 
+	for sb-unicode [from Yoshinori Tahara and R. Mattes]
+
+2005-01-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp: Better support SBCL-AMD64
+	
+2004-11-08 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.lisp: Better support sb-unicode
+	* tests/compress.lisp: Support sb-unicode
+	
+2004-10-07 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Add new function:
+	convert-from-foreign-usb8
+	
+2004-04-15 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Add new functions:
+	MAKE-POINTER and POINTER-ADDRESS
+
+2004-04-13 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/string.lisp: Add new FOREIGN-STRING-LENGTH
+
+2003-08-15 Kevin Rosenberg (kevin at rosenberg.net)
+	* Added with-cast-pointer and def-foreign-var (patches submitted
+	by Edi Weitz). 
+	* Added many new tests
+	
+2002-10-16 Kevin Rosenberg (kevin at rosenberg.net)
+        * Added support for SBCL and SCL
+	
+2002-09-29 Kevin Rosenberg (kevin at rosenberg.net)
+	* Numerous changes in openmcl support (uffi now supports
+	clsql on openmcl)
+	
+2002-09-19 Kevin Rosenberg (kevin at rosenberg.net)
+        - Integrate John Desoi's OpenMCL support into src-mcl
+	* examples/Makefile: add section for building on MacOS X (John Desoi)
+	* examples/test-examples: changed from mk: to asdf: package loading (KMR)
+	* examples/run-examples: changed from mk: to asdf: package loading (KMR), 
+	add conditional loading if UFFI not loaded (John Desoi)
+	* examples/compress.cl: Add dylib to library types for MacOSX (John Desoi),
+	converted compressed output to hexidecimal display (KMR)
+	* examples/union.cl: Rework the tests (KMR)
+	* src-main/libraries.cl: add dylib as default library type on MacOSX (John Desoi)
+	* src-main/aggregates.cl: convert from uffi type in deref-array (John Desoi)
+	
+2002-09-16 Kevin Rosenberg (kevin at rosenberg.net)
+	- Restructure directories to move to a asdf definition file
+	without pathnames.
+	
+2002-08-25 Kevin Rosenberg (kevin at rosenberg.net)
+       - Restructure directories to attempt to properly handle both
+	Common Lisp Controller and non-CLC systems
+	
+2002-08-17 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- add uffi.asd for ASDF users
+
+2002-08-01 Kevin Rosenberg (kevin at rosenberg.net)
+	- Restructure directories to improve Common Lisp Controller v3
+	compatibility
+	
+2002-07-25 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Rework handling of logical pathnames.
+	- Move run-examples.cl to examples directory.
+	
+2002-06-28 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Added size-of-foreign-type function.
+	
+2002-06-26 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Fix bug in Lispworks allocate-foreign-object
+	- Added new :unsigned-byte type. Made :byte signed. 
+	
+2002-04-27 Kevin Rosenberg (kevin at rosenberg.net)
+	- misc files
+	First debian version
+	
+2002-04-23 Kevin Rosenberg (kevin at rosenberg.net)
+	- doc/*
+	Updated to debian docbook catalog
+	
+2002-04-23 John DeSoi (desoi at mac.com)
+	* src/mcl/*
+	Improved MCL support
+
+2002-04-06 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/mcl/libraries.cl:
+	Removed unnecessary function and added find-foreign-library
+	* src/mcl/*.cl:
+	Added authorship for John DeSoi
+	* doc/ref.sgml:
+	Added documentation for find-foreign-library
+	* uffi.system:
+	Simplied logical pathnames and MCL loading
+	
+2002-04-04 John DeSoi (desoi at mac.com)
+	* src/mcl/*.cl
+	Added initial support for MCL
+
+2002-04-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/libraries.cl:
+	Added test for .so libraries on CMUCL and use sys::load-object-file instead
+	of alien:load-library-file
+	* examples/Makefile:
+	Updated defaults so library is created correctly on Linux, FreeBSD, and Solaris
+
+2002-04-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* examples/compress.cl:
+	Fixed missing '/'
+	* examples/union.cl:
+	Added support for SPARC big-endian
+	* test-examples.cl:
+	Automated testing suite
+	
+2002-04-01 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/libraries.cl:
+	* examples/Makefile:
+	Changed default type for FreeBSD and updated Makefile for
+	FreeBSD and Solaris. Enhanced find-foreign-library to
+	take a list of types to search.
+	* examples/compress.cl:
+	Add support to use find-foreign-library
+
+2002-03-31  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.cl:
+	Fixed bug in with-foreign-string (Thanks Harald Hanche-Olsen)
+	* examples/Makefile:
+	Create a .a library file for FreeBSD
+	* src/libraries.cl:
+	Added default type and find-foreign-library functions
+	
+2002-03-29  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.cl: 
+	Fixed bug in deref-pointer (Thanks John Desoi!)
+
+2002-03-22  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/aggregates.cl: 
+	Changed name and implementation of def-array to more appropriate
+	def-array-pointer
+	* src/ref.sgml:
+	Updated def-array-pointer documentation
+	* src/primitives.cl:
+	Made results of def-constant equal those of cl:defconstant
+	* src/objects.cl:
+	Made type be evaluated for with-foreign-object and allocate-foreign-object
+	* VERSION:
+	Increase to 0.3.0 to coincide with the release of CLSQL.
+	
+21 Mar 2002
+	* Fixed problem with NULL foreign-strings with CMUCL
+	* Added c-test-fns to examples for allow more specific testing
+	of UFFI. Builds on UNIX and Win32 platforms.
+	* Added def-union function, added union.cl example
+	* Fixed error with ensure-char-[character|integer]
+	* Added 2-d array example to examples/arrays.cl	
+	* Fixed documentation error on gethostname
+	* Added ensure-char-* and def-union to documentation
+	* Added double-float vector example to c-test-fns
+	* Reworked cstring on Lispworks to have LW handle string conversion
+	* First pass at with-foreign-object -- unoptimized
+	* Added gethostname2 example which uses with-foreign-object
+	* Added char-array-to-pointer function to encapsulate
+	converting a char array	to a char pointer
+	* Converted with-foreign-object to use stack allocation on CMUCL and LW
+	* Added benchmark code, first file is for allocation
+	
+20 Mar 2002
+	* Updated strings.cl so that foreign-strings are always unsigned.
+	Fixes a problem with strtol example.
+	* Added ensure-char-character and ensure-char-integer to handle
+	differences in implementations dereferencing of (* :char).
+	* Added section on design priorities for UFFI
+	* Added section in TODO on splitting implementation-dependent code
+	
+19 Mar 2002
+	* Added size parameter to allocate-foreign-object. Creates an array
+	of dimensions size.
+	* Got array-2d example working with a 1-d array.
+	* Cleaned strtol example
+	* Added TODO file
+	
+18 Mar 2002
+	* Documentation fixes (Erik Winkels)
+	* Fixed missing '.' in CMUCL type declarations (Erik Winkels)
+	
+17 Mar 2002
+	* Changed deref-pointer so it always returns a character when
+	called with a :char or :unsigned-char type
+	* Removed function ensure-char as no longer needed
+	* Added missing :byte specifier to Lispworks
+	* Changed default string type in Lispworks to :unsigned-char
+	which is the native type for Lispworks foreign-strings.
+	* Reworked strtol to handle new character pointing method
+	
+16 Mar 2002
+	* Fixed return value in load-foreign-library (Thanks Erik Winkels),
+	modified routine to accept pathnames as well as strings.
+	* Fix documention with :pointer-void (Again, Erik Winkels)
+	* Added missing type specifiers for CMUCL (Thanks a bunch, Erik!)
+	
+15 Mar 2002
+	* Finished basic skeleton of documentation.
+	
+14 Mar 2002
+	* Changed license to more liberal Lisp Lessor GNU Public License
+	* Fixed problem with uffi.system absent from in distribution 
+	(Thanks John DeSoi)
+	* Fixed compiler warnings
+	
+
+11 Mar 2002
+	* Changed def-type to def-foreign-type
+	* Created new macro def-type to generate cl:deftype forms. Removed
+	uffi-declare and uffi-slot-type as they are no longer necessary.
+	 
+10 Mar 2002
+	* Modified input parameters to load-foreign-library
+	* Added to documention
+	* Changed parameter order in get-slot-value and deref-array 
+	
+9 Mar 2002
+	* Added to documentation
+	* Made Allegro CL array access more efficient
+	* Changed def-routine name to def-function
+	* Fixed bug in def-function for Lispworks]
+	* Fixed error in +null-c-string-pointer+ name
+	* Fixed error in (make-null-pointer) for Lispworks
+	* Reworked Lispwork c-strings to be (* :char) rather than the
+	implementation default of (* (:unsigned :char)) to be consistent
+	with CMUCL. Bumped version to 0.2.0 because of change this change.
+	* Renamed c-string to cstring to emphasize it as a basic type
+	* Modified getenv.cl example to avoid name collison with LW
+	* Modified compress.cl to setup output buffer as :unsigned*char
+	* Added test-all-examples function. All routines tested okay with
+	ACL, LW, and CMUCL
+	
+8 Mar 2002
+	* Added ZIP file output with LF->CRLF translations to distribution
+	* Modified def-enum to use uffi:def-constant rather than
+	cl:defconstant
+	

Added: branches/trunk-reorg/thirdparty/uffi/INSTALL
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/INSTALL	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,3 @@
+Detailed installation instructions are supplied in PDF format
+in the file ./doc/uffi.pdf.
+

Added: branches/trunk-reorg/thirdparty/uffi/LICENSE
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/LICENSE	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,26 @@
+Copyright (c) 2001-2003 Kevin M. Rosenberg and contributors.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of the contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/uffi/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,45 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile
+#  Purpose:      Makefile for the uffi package
+#  Programer:    Kevin M. Rosenberg, M.D.
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id$
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+PKG:=uffi
+DEBPKG=cl-uffi
+SUBDIRS:= examples src benchmarks
+DOCSUBDIRS:=doc
+
+include Makefile.common
+
+
+.PHONY: all
+all: 
+
+
+.PHONY: distclean
+distclean: clean
+	@$(MAKE) -C doc $@
+#	./debian/rules clean
+
+
+SOURCE_FILES=src doc examples Makefile uffi.system uffi.debian.system \
+	benchmarks COPYRIGHT README TODO INSTALL ChangeLog NEWS \
+	test-examples.cl set-logical.cl 
+
+.PHONY: doc
+doc:
+	$(MAKE) -C doc
+
+.PHONY: dist
+dist: clean
+	$(MAKE) -C doc $@
+
+.PHONY: TAGS
+TAGS:
+	if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
+	find . -name \*.lisp -exec /usr/bin/etags -a \{\} \;

Added: branches/trunk-reorg/thirdparty/uffi/Makefile.common
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/Makefile.common	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,17 @@
+all:
+	
+
+.PHONY: clean
+clean:
+	@rm -rf .bin
+	@rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl 
+	@rm -f *.fasla8 *.fasla16 *.faslm8 *.faslm16 *.faslmt
+	@rm -f *~ *.bak *.orig *.err \#*\# .#*
+	@rm -f *.so *.a
+	@rm -rf debian/cl-uffi
+ifneq ($(SUBDIRS)$(DOCSUBDIRS),)
+	@set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \
+		$(MAKE) -C $$i $@; done
+endif
+
+.SUFFIXES:            # No default suffixes

Added: branches/trunk-reorg/thirdparty/uffi/NEWS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/NEWS	Mon Feb 11 09:06:27 2008
@@ -0,0 +1 @@
+UFFI now supports AllegroCL AMD64

Added: branches/trunk-reorg/thirdparty/uffi/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/README	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,20 @@
+Package:  UFFI (Universal Foreign Language Interface)
+Web site: http://uffi.b9.com
+Author:   Kevin M. Rosenberg
+
+
+BRIEF DESCRIPTION
+-----------------
+uffi is a Common Lisp package for interfacing C-language compatible
+libraries. Every Common Lisp implementation has a method for
+interfacing to such libraries. Unfortunately, these method vary widely
+amongst implementations. uffi gathers a common subset of functionality
+between Common Lisp implementations. uffi wraps this common subset of
+functionality into it's own syntax and provides macro translation of
+uffi features into the specific syntax of supported Common Lisp
+implementations.
+
+Currently, AllegroCL (Linux and Microsoft Windows), Lispworks (Linux
+and Microsoft Windows), CMUCL, SBCL, and OpenMCL are supported.
+
+

Added: branches/trunk-reorg/thirdparty/uffi/TODO
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/TODO	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,7 @@
+- Run test-suite on MCL port
+
+- Add OpenMCL support for with-cast-pointer and def-foreign-var
+
+- Add support for direct vector passing to and from foreign functions
+   to avoid copying elements in and out of vector.
+

Added: branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/benchmarks/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,6 @@
+SUBDIRS		:= 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/benchmarks/allocation.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,126 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          allocation.cl
+;;;; Purpose:       Benchmark allocation and slot-access speed
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+
+(defun stk-int ()
+  #+allegro
+  (ff:with-stack-fobject (ptr :int)
+    (setf (ff:fslot-value ptr) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr :int))
+    (setf (fli:dereference ptr) 0))
+  #+cmu
+  (alien:with-alien ((ptr alien:signed))
+    (let ((p (alien:addr ptr)))
+      (setf (alien:deref p) 0)))
+  #+sbcl
+  (sb-alien:with-alien ((ptr sb-alien:signed))
+    (let ((p (sb-alien:addr ptr)))
+      (setf (sb-alien:deref p) 0)))
+  )
+
+(defun stk-vector ()
+  #+allegro
+  (ff:with-stack-fobject (ptr '(:array :int 10) )
+    (setf (ff:fslot-value ptr 5) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
+    (setf (fli:dereference ptr 5) 0))
+  #+cmu
+  (alien:with-alien ((ptr (alien:array alien:signed 10)))
+    (setf (alien:deref ptr 5) 0))
+  #+sbcl
+  (sb-alien:with-alien ((ptr (sb-alien:array sb-alien:signed 10)))
+    (setf (sb-alien:deref ptr 5) 0))
+  )
+
+(defun stat-int ()
+  #+allegro
+  (let ((ptr (ff:allocate-fobject :int :c)))
+    (declare (dynamic-extent ptr))
+    (setf (ff:fslot-value-typed :int :c ptr) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type :int)))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:signed 32))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+             (dynamic-extent ptr))
+    (setf (alien:deref ptr) 0)
+    (alien:free-alien ptr))
+  #+sbcl
+  (let ((ptr (sb-alien:make-alien (sb-alien:signed 32))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+     (dynamic-extent ptr))
+    (setf (sb-alien:deref ptr) 0)
+    (sb-alien:free-alien ptr))
+  )
+
+(defun stat-vector ()
+  #+allegro
+  (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
+    (declare (dynamic-extent ptr))
+    (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr 5) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+             (dynamic-extent ptr))
+    (setf (alien:deref ptr 5) 0)
+    (alien:free-alien ptr))
+  #+sbcl
+  (let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10))))
+    (declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr)
+             (dynamic-extent ptr))
+    (setf (sb-alien:deref ptr 5) 0)
+    (sb-alien:free-alien ptr))
+  )
+
+
+(defun stk-vs-stat ()
+  (format t "~&Stack allocation, Integer")
+  (time (dotimes (i 1000)
+          (dotimes (j 1000)
+            (stk-int))))
+  (format t "~&Static allocation, Integer")
+  (time (dotimes (i 1000)
+          (dotimes (j 1000)
+            (stat-int))))
+  (format t "~&Stack allocation, Vector")
+  (time (dotimes (i 1000)
+          (dotimes (j 1000)
+            (stk-int))))
+  (format t "~&Static allocation, Vector")
+  (time (dotimes (i 1000)
+          (dotimes (j 1000)
+            (stat-int))))
+)
+
+
+(stk-vs-stat)
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/README.Debian
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/README.Debian	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,7 @@
+The Debian Package CL-UFFI
+--------------------------
+
+This is the UFFI Common Lisp system packaged for Debian by
+Kevin M. Rosenberg <kmr at debian.org>, April 2002.
+
+The home page for UFFI is http://uffi.med-info.com/

Added: branches/trunk-reorg/thirdparty/uffi/debian/changelog
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/changelog	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,872 @@
+cl-uffi (1.6.0-1) unstable; urgency=low
+
+  * New upstream (closes: 433814) 
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 22 Jul 2007 12:39:49 -0600
+
+cl-uffi (1.5.18-3) unstable; urgency=low
+
+  * debian/watch: New version
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 18 Jul 2007 20:27:04 -0600
+
+cl-uffi (1.5.18-2) unstable; urgency=low
+
+  * Fix build twice in a row (closes: 424155)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 22 May 2007 11:33:27 -0600
+
+cl-uffi (1.5.18-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 12 Apr 2007 23:48:46 -0600
+
+cl-uffi (1.5.17-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 10 Oct 2006 08:34:43 -0600
+
+cl-uffi (1.5.16-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 02 Sep 2006 20:31:11 -0600
+
+cl-uffi (1.5.15-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 14 Aug 2006 00:21:47 -0600
+
+cl-uffi (1.5.14-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  4 Jul 2006 19:23:10 -0600
+
+cl-uffi (1.5.13-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 17 May 2006 09:08:58 -0600
+
+cl-uffi (1.5.12-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 17 May 2006 08:09:13 -0600
+
+cl-uffi (1.5.11-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  9 May 2006 09:33:59 -0600
+
+cl-uffi (1.5.10-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 17 Apr 2006 18:05:56 -0600
+
+cl-uffi (1.5.9-1) unstable; urgency=low
+
+  * add GNU uname (closes: 355924)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  8 Mar 2006 12:06:17 -0700
+
+cl-uffi (1.5.8-1) unstable; urgency=low
+
+  * Really commit patch for GNU/kFreeBSD (closes: 345220)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 16 Jan 2006 14:47:08 -0700
+
+cl-uffi (1.5.7-2) unstable; urgency=low
+
+  * Commit patch for GNU/kFreeBSD (closes: 345220)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 31 Dec 2005 11:11:36 -0700
+
+cl-uffi (1.5.7-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 14 Nov 2005 19:39:25 -0700
+
+cl-uffi (1.5.6-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 14 Nov 2005 12:02:07 -0700
+
+cl-uffi (1.5.5-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri,  4 Nov 2005 11:59:50 -0700
+
+cl-uffi (1.5.4-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 18 Sep 2005 01:22:50 -0600
+
+cl-uffi (1.5.3-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 17 Sep 2005 23:44:20 -0600
+
+cl-uffi (1.5.2-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 17 Sep 2005 22:48:11 -0600
+
+cl-uffi (1.5.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  6 Jul 2005 21:29:46 -0600
+
+cl-uffi (1.5.0-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  5 Jul 2005 19:03:23 -0600
+
+cl-uffi (1.4.39-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  8 Jun 2005 18:37:06 -0600
+
+cl-uffi (1.4.38-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 08 Jun 2005 10:42:10 -0600
+
+cl-uffi (1.4.37-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 13 Apr 2005 12:42:41 -0600
+
+cl-uffi (1.4.36-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  6 Apr 2005 11:42:09 -0600
+
+cl-uffi (1.4.35-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  4 Apr 2005 14:35:10 -0600
+
+cl-uffi (1.4.34-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun,  3 Apr 2005 17:55:49 -0600
+
+cl-uffi (1.4.33-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  2 Mar 2005 12:25:43 -0700
+
+cl-uffi (1.4.32-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 22 Feb 2005 10:10:03 -0700
+
+cl-uffi (1.4.31-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 22 Jan 2005 17:27:37 -0700
+
+cl-uffi (1.4.30-1) unstable; urgency=low
+
+  * New upstream, handle sb-unicode
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  8 Nov 2004 19:30:11 -0700
+
+cl-uffi (1.4.29-1) unstable; urgency=low
+
+  * New upstream, revert patch that broken clsql on debian
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 30 Oct 2004 11:30:14 -0600
+
+cl-uffi (1.4.28-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 23 Oct 2004 09:05:50 -0600
+
+cl-uffi (1.4.27-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 21 Oct 2004 16:44:11 -0600
+
+cl-uffi (1.4.26-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu,  9 Sep 2004 22:20:47 -0600
+
+cl-uffi (1.4.25-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 27 Aug 2004 06:33:16 -0600
+
+cl-uffi (1.4.24-1) unstable; urgency=low
+
+  * Fix for OpenMCL from James Bielman
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 15 Jul 2004 09:27:22 -0600
+
+cl-uffi (1.4.23-1) unstable; urgency=low
+
+  * Add support for new SBCL load-shared-object [supplied by Andreas Fuchs]
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 13 Jul 2004 09:19:32 -0600
+
+cl-uffi (1.4.22-1) unstable; urgency=low
+
+  * OpenMCL fix
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 23 Jun 2004 12:36:24 -0600
+
+cl-uffi (1.4.21-1) unstable; urgency=low
+
+  * Fix for WITH-FOREIGN-OBJECT macro on CMUCL
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 10 Jun 2004 00:17:31 -0600
+
+cl-uffi (1.4.20-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 20 May 2004 09:59:07 -0600
+
+cl-uffi (1.4.19-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 19 May 2004 12:16:03 -0600
+
+cl-uffi (1.4.18-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 18 May 2004 15:40:58 -0600
+
+cl-uffi (1.4.17-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 15 May 2004 11:02:22 -0600
+
+cl-uffi (1.4.16-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 13 May 2004 04:23:13 -0600
+
+cl-uffi (1.4.15-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 12 May 2004 22:40:39 -0600
+
+cl-uffi (1.4.14-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 12 May 2004 12:48:13 -0600
+
+cl-uffi (1.4.13-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu,  6 May 2004 10:14:10 -0600
+
+cl-uffi (1.4.12-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 17 Apr 2004 12:26:00 -0600
+
+cl-uffi (1.4.11-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 15 Apr 2004 05:48:48 -0600
+
+cl-uffi (1.4.10-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 15 Apr 2004 01:59:37 -0600
+
+cl-uffi (1.4.9-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 13 Apr 2004 16:03:22 -0600
+
+cl-uffi (1.4.8-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 13 Apr 2004 14:13:04 -0600
+
+cl-uffi (1.4.7-1) unstable; urgency=low
+
+  * Fix fast-native-to-string on 16-bit wide char Allegro
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri,  2 Apr 2004 14:20:36 -0700
+
+cl-uffi (1.4.6-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 25 Nov 2003 06:37:14 -0700
+
+cl-uffi (1.4.5-1) unstable; urgency=low
+
+  * Change documentation encoding to ISO-8859-1
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 20 Nov 2003 20:35:15 -0700
+
+cl-uffi (1.4.4-1) unstable; urgency=low
+
+  * Add patch from Vebjorn Ljosa for fast-native-to-string
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 18 Nov 2003 13:09:32 -0700
+
+cl-uffi (1.4.3-1) unstable; urgency=low
+
+  * Improved test/make.sh and uffi-tests.asd
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 11 Nov 2003 15:02:40 -0700
+
+cl-uffi (1.4.2-1) unstable; urgency=low
+
+  * Yet another attempt for asdf-install
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 11 Nov 2003 04:51:24 -0700
+
+cl-uffi (1.4.1-1) unstable; urgency=low
+
+  * Fix for asdf-install
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 11 Nov 2003 04:29:27 -0700
+
+cl-uffi (1.4.0-1) unstable; urgency=low
+
+  * Make UFFI asdf-installable
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 11 Nov 2003 03:28:06 -0700
+
+cl-uffi (1.3.9-1) unstable; urgency=low
+
+  * Use local XSL files, add Debian-specific catalog
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 11 Nov 2003 00:12:34 -0700
+
+cl-uffi (1.3.8-1) unstable; urgency=low
+
+  * Use XInclude for documentation
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 10 Nov 2003 22:39:33 -0700
+
+cl-uffi (1.3.7-1) unstable; urgency=low
+
+  * Convert documentation to Docbook XML with new processing commands
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 10 Nov 2003 20:38:28 -0700
+
+cl-uffi (1.3.6-1) unstable; urgency=low
+
+  * More MacOSX changes
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 31 Aug 2003 20:45:23 -0600
+
+cl-uffi (1.3.5-1) unstable; urgency=low
+
+  * Rework loading of foreign libraries to better support MacOSX, especially
+  sbcl
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 27 Aug 2003 10:01:11 -0600
+
+cl-uffi (1.3.4-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 26 Aug 2003 07:29:19 -0600
+
+cl-uffi (1.3.3-1) unstable; urgency=low
+
+  * Add gettimeofday to tests
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 26 Aug 2003 07:29:07 -0600
+
+cl-uffi (1.3.2-1) unstable; urgency=low
+
+  * Patch from Edi Weitz
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 22 Aug 2003 19:03:06 -0600
+
+cl-uffi (1.3.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 14 Aug 2003 18:27:32 -0600
+
+cl-uffi (1.3.0-1) unstable; urgency=low
+
+  * Add initial support and tests for def-foreign-var
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 14 Aug 2003 15:38:33 -0600
+
+cl-uffi (1.2.23-1) unstable; urgency=low
+
+  * New upstream with fixes suggested and patches submitted by Edi Weitz.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 14 Aug 2003 12:26:07 -0600
+
+cl-uffi (1.2.22-1) unstable; urgency=low
+
+  * New upstream with Lispworks patch from Edi Weitz
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 12 Aug 2003 08:09:04 -0600
+
+cl-uffi (1.2.21-1) unstable; urgency=low
+
+  * New upstream -- fix for Franz's mlisp
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 19 Jul 2003 14:15:52 -0600
+
+cl-uffi (1.2.20-1) unstable; urgency=low
+
+  * New upstream -- really fix bug
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  8 Jul 2003 06:37:58 -0600
+
+cl-uffi (1.2.19-1) unstable; urgency=low
+
+  * Fix bug in sbcl/load-library
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  7 Jul 2003 18:49:37 -0600
+
+cl-uffi (1.2.18-1) unstable; urgency=low
+
+  * New BSD license
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 26 Jun 2003 12:01:24 -0600
+
+cl-uffi (1.2.17-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 12 Jun 2003 06:12:30 -0600
+
+cl-uffi (1.2.16-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 12 Jun 2003 06:04:06 -0600
+
+cl-uffi (1.2.15-1) unstable; urgency=low
+
+  * Documentation improvement by Nikodemus Siivola
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  5 May 2003 15:57:32 -0600
+
+cl-uffi (1.2.14-1) unstable; urgency=low
+
+  * New upstream
+  * Add to debhelper to depends (closes:192001)
+  
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  5 May 2003 08:53:30 -0600
+
+cl-uffi (1.2.13-1) unstable; urgency=low
+
+  * Fix getenv test
+  * Work-around load-object-file bug in CMUCL in testing script
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu,  1 May 2003 17:31:21 -0600
+
+cl-uffi (1.2.12-1) unstable; urgency=low
+
+  * Finish converting examples into test suite
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 30 Apr 2003 08:11:42 -0600
+
+cl-uffi (1.2.11-1) unstable; urgency=low
+
+  * Add test suite, new binary package uffi-tests
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 29 Apr 2003 08:10:26 -0600
+
+cl-uffi (1.2.10-1) unstable; urgency=low
+
+  * Fix allegro free-cstring bug
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 28 Mar 2003 12:58:08 -0700
+
+cl-uffi (1.2.9-1) unstable; urgency=low
+
+  * change ccl:%put-cstring to ccl::%put-cstring for openmcl
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 12 Mar 2003 14:12:03 -0700
+
+cl-uffi (1.2.8-1) unstable; urgency=low
+
+  * Change output on compress.lisp example
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 10 Mar 2003 10:37:00 -0700
+
+cl-uffi (1.2.7-1) unstable; urgency=low
+
+  * Remove reference to obsolete Corman module in uffi.asd
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 19 Feb 2003 14:56:15 -0700
+
+cl-uffi (1.2.6-1) unstable; urgency=low
+
+  * Add :language :ansi-c for Lispworks def-function
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed,  5 Feb 2003 23:54:12 -0700
+
+cl-uffi (1.2.5-1) unstable; urgency=low
+
+  * Rework allocate-foreign-array to evaluate type
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 28 Dec 2002 01:12:30 -0700
+
+cl-uffi (1.2.4-1) unstable; urgency=low
+
+  * Fix syntax error from last version
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 13 Dec 2002 18:54:41 -0700
+
+cl-uffi (1.2.3-1) unstable; urgency=low
+
+  * More external format changes for lispworks (thanks Marc Battyani)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 13 Dec 2002 15:46:23 -0700
+
+cl-uffi (1.2.2-1) unstable; urgency=low
+
+  * Add external format parameters to lispworks to avoid translating stringsl
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 13 Dec 2002 14:26:17 -0700
+
+cl-uffi (1.2.1-1) unstable; urgency=low
+
+  * Add uncompression test
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  9 Dec 2002 09:05:52 -0700
+
+cl-uffi (1.2.0-1) unstable; urgency=low
+
+  * Fixes in allocate-foreign-object and deref-array for allegro
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon,  2 Dec 2002 23:59:43 -0700
+
+cl-uffi (1.1.8-1) unstable; urgency=low
+
+  * Reverse broken bug "fixes" 
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 28 Nov 2002 11:47:26 -0700
+
+cl-uffi (1.1.7.1-1) unstable; urgency=low
+
+  * Another allegro bug (Thanks Matthew Danish)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 23 Nov 2002 12:06:40 -0700
+
+cl-uffi (1.1.7-1) unstable; urgency=low
+
+  * bug fixes on allegro
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 23 Nov 2002 11:03:18 -0700
+
+cl-uffi (1.1.6-1) unstable; urgency=low
+
+  * More documention of cstrings and foreign strings
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 21 Nov 2002 19:51:55 -0700
+
+cl-uffi (1.1.5-1) unstable; urgency=low
+
+  * Documentation changes
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 21 Nov 2002 18:35:26 -0700
+
+cl-uffi (1.1.4-1) unstable; urgency=low
+
+  * OpenMCL/MCL fixes
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 20 Nov 2002 14:03:16 -0700
+
+cl-uffi (1.1.3-1) unstable; urgency=low
+
+  * Fix OpenMCL default library pathname type
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 17 Nov 2002 22:28:59 -0700
+
+cl-uffi (1.1.2-1) unstable; urgency=low
+
+  * src/objects.lisp: Fix bug in allocate-foreign-object for AllegroCL
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 14 Nov 2002 15:10:41 -0700
+
+cl-uffi (1.1.1-1) unstable; urgency=low
+
+  * Remove 'load-compiled-op from .asd file
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri,  8 Nov 2002 09:49:49 -0700
+
+cl-uffi (1.1.0-1) unstable; urgency=low
+
+  * Add SCL support.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 15 Oct 2002 11:22:35 -0600
+
+cl-uffi (1.0.1-1) unstable; urgency=low
+
+  * Add SBCL to documentation
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 14 Oct 2002 01:18:05 -0600
+
+cl-uffi (1.0.0-1) unstable; urgency=low
+
+  * Initial SBCL compatibility
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 13 Oct 2002 19:01:31 -0600
+
+cl-uffi (0.9.2-1) unstable; urgency=high
+
+  * Add AUTHORS file
+  * Integrate Reini Urban's cormanlisp patches into main source
+  * Add Depends: version on Common Lisp Controller
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  1 Oct 2002 08:11:21 -0600
+
+cl-uffi (0.9.1-1) unstable; urgency=low
+
+  * Rename .cl files to .lisp files
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 30 Sep 2002 04:01:58 -0600
+
+cl-uffi (0.9.0-1) unstable; urgency=low
+
+  * Reorganize directories, merge MCL/OpenMCL into main code 
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 30 Sep 2002 01:32:03 -0600
+
+cl-uffi (0.8.6-1) unstable; urgency=low
+
+  * Fix :pointer-self for OpenMCL.
+  * Multiple changes to support OpenMCL with CLSQL
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 30 Sep 2002 01:31:37 -0600
+
+cl-uffi (0.8.5-1) unstable; urgency=low
+
+  * Add with-cstrings macro to mcl's source
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 29 Sep 2002 12:19:20 -0600
+
+cl-uffi (0.8.4-1) unstable; urgency=low
+
+  * Change mcl's load-library definition from macro to function
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 29 Sep 2002 11:49:32 -0600
+
+cl-uffi (0.8.3-1) unstable; urgency=low
+
+  * New upstream release. Passes all tests with OpenMCL in Debian PPC.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 29 Sep 2002 11:32:05 -0600
+
+cl-uffi (0.8.2-2) unstable; urgency=low
+
+  * Add pathname to clc-register-impl invocation
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 25 Sep 2002 06:38:44 -0600
+
+cl-uffi (0.8.2-1) unstable; urgency=low
+
+  * Add conditionals to .asd file to control clc autobuilding
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 22 Sep 2002 21:00:57 -0600
+
+cl-uffi (0.8.1-1) unstable; urgency=low
+
+  * Fix size of openmcl's and mcl's integers
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 20 Sep 2002 07:06:31 -0600
+
+cl-uffi (0.8.0-1) unstable; urgency=low
+
+  * Adds support for openmcl, numerous changes from John Desoi
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 19 Sep 2002 21:09:17 -0600
+
+cl-uffi (0.7.1-1) unstable; urgency=low
+
+  * New upstream version
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 18 Sep 2002 01:57:10 -0600
+
+cl-uffi (0.7.0-1) unstable; urgency=low
+
+  * Remove .system file, restructure directories for .asd file without pathnames
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 16 Sep 2002 12:00:45 -0600
+
+cl-uffi (0.6.3-1) unstable; urgency=low
+
+  * New upstream version, fixes problem with .asd file.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri,  6 Sep 2002 04:59:45 -0600
+
+cl-uffi (0.6.2-1) unstable; urgency=low
+
+  * New upstream version. Restructure directories once again to handle 
+    non-CLC systems.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 23 Aug 2002 09:33:14 -0600
+
+cl-uffi (0.6.1-1) unstable; urgency=low
+
+  * Add uffi.asd file to upstream for ASDF users.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat, 17 Aug 2002 18:50:12 -0600
+
+cl-uffi (0.6.0-2) unstable; urgency=low
+
+  * Update e-mail address
+  * Update Standards version
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Mon, 12 Aug 2002 00:01:27 -0600
+
+cl-uffi (0.6.0-1) unstable; urgency=low
+
+  * New upstream version (Restructure directories to improve Common Lisp
+    Controller compatibility.)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 25 Jul 2002 21:24:53 -0600
+
+cl-uffi (0.5.1-1) unstable; urgency=low
+
+  * Rework upstream documentation.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue,  9 Jul 2002 12:45:56 -0600
+
+cl-uffi (0.5.0-2) unstable; urgency=low
+
+  * Add the LLGPL text to the copyright file.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun,  7 Jul 2002 15:40:05 -0600
+
+cl-uffi (0.5.0-1) unstable; urgency=low
+
+  * New upstream version
+  
+  * Additions to the copyright file to comply with Debian Policy
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri, 28 Jun 2002 11:16:28 -0600
+
+cl-uffi (0.4.8-1) unstable; urgency=low
+
+  * New upstream version
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Wed, 26 Jun 2002 21:35:07 -0600
+
+cl-uffi (0.4.5-2) unstable; urgency=low
+
+  * Fix Build-Depends-Indep
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 25 Jun 2002 06:12:19 -0600
+
+cl-uffi (0.4.5-1) unstable; urgency=low
+
+  * New upstream version.
+
+  * Remove deprecated repository 
+  
+  * Migrate to Debhelper V4
+  
+  * Changed Maintainer: field from sponsor to sponsoree/packager
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 20 Jun 2002 07:43:53 -0600
+
+cl-uffi (0.4.4-8) unstable; urgency=low
+
+  * Improved control file in anticipation of having dpkg-buildpackage
+    generate the documentation rather than putting the documentation in
+    the upstream archive.
+  * Remade package to include upstream sources.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun,  5 May 2002 11:17:52 -0600
+
+cl-uffi (0.4.4-7) unstable; urgency=low
+
+  * Modified make-dist.sh to use cvs-buildpackage, added options
+  * Cleaned debian/rules, debian/copyright	
+  * First version to upload. (closes: #145723)
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sat,  4 May 2002 16:03:11 -0600
+
+cl-uffi (0.4.4-6) unstable; urgency=low
+
+  * Fixed Maintainer and Uploader fields in debian control
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Fri,  3 May 2002 09:11:47 -0600
+
+cl-uffi (0.4.4-5) unstable; urgency=low
+
+  * Commented-out DH_VERBOSE flag. 
+  * Uses debian/dirs with debhelper.
+  * Changed doc-base section to programming. 
+  * Added Uploaders field to debian/control. 
+  * Made .system file be a symbolic link to .system file in repository.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu,  2 May 2002 15:37:50 -0600
+
+cl-uffi (0.4.4-4) unstable; urgency=low
+
+  * Added upstream ChangeLog to debian distribution.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Tue, 30 Apr 2002 13:01:12 -0600
+
+cl-uffi (0.4.4-3) unstable; urgency=low
+
+  * Modified make-dist.sh to create better .diff.gz
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 28 Apr 2002 06:38:48 -0600
+
+cl-uffi (0.4.4-2) unstable; urgency=low
+
+  * Improved source code archive for debian upload.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Sun, 28 Apr 2002 03:04:52 -0600
+
+cl-uffi (0.4.4-1) unstable; urgency=low
+
+  * Initial package.
+
+ -- Kevin M. Rosenberg <kmr at debian.org>  Thu, 25 Apr 2002 19:13:41 -0600
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/cl-uffi.doc-base	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,17 @@
+Document: cl-uffi
+Title: UFFI Manual
+Author: Kevin M. Rosenberg
+Abstract: This manual describes the
+ use the UFFI (Universal Foreign Function Interface)
+ Common Lisp library. This library supports CMUCL, SBCL,
+ AllegroCL, Lispworks, SCL, OpenMCL, and MCL.
+Section: programming
+
+Format: PDF
+Files: /usr/share/doc/cl-uffi/cl-uffi.pdf.gz
+
+Format: HTML
+Index: /usr/share/doc/cl-uffi/html/index.html
+Files: /usr/share/doc/cl-uffi/html/*.html
+
+  

Added: branches/trunk-reorg/thirdparty/uffi/debian/compat
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/compat	Mon Feb 11 09:06:27 2008
@@ -0,0 +1 @@
+4

Added: branches/trunk-reorg/thirdparty/uffi/debian/control
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/control	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,23 @@
+Source: cl-uffi
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr at debian.org>
+Build-Depends: zlib1g-dev,debhelper (>= 4.0.0)
+Standards-Version: 3.7.2.2
+
+Package: cl-uffi
+Architecture: all
+Depends: common-lisp-controller (>= 3.37)
+Recommends: cl-uffi-tests
+Description: Universal Foreign Function Library for Common Lisp
+ UFFI provides a universal foreign function interface (FFI) for 
+ Common Lisp.
+ UFFI supports AllegroCL, CMUCL, Lispworks, MCL, OpenMCL,
+ SBCL, and SCL.
+
+Package: cl-uffi-tests
+Architecture: any
+Depends: common-lisp-controller (>= 3.37), cl-uffi, zlib1g-dev
+Description: Regression tests for UFFI Common Lisp Library
+ This is a test of regression tests for UFFI. Besides providing
+ testing for UFFI, the tests serve as an example of UFFI usage.

Added: branches/trunk-reorg/thirdparty/uffi/debian/copyright
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/copyright	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,34 @@
+Debian Copyright Section
+========================
+
+Upstream Source URL: http://files.b9.com/uffi
+Upstream Author: Kevin Rosenberg <kevin at rosenberg.net>
+Debian Maintainer: Kevin M. Rosenberg <kmr at debian.org>
+
+
+Copyright (c) 2001-2003 Kevin M. Rosenberg and contributors.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of the contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/cvsbp-prepare.sh	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,9 @@
+#!/bin/bash
+
+set -e  # abort on error
+
+# Clean checked out CVS directory
+rm -f debian/upload.sh debian/make-upstream.sh debian/make-debian.sh
+rm -f `find . -type f -name .cvsignore`
+rm -f stamp-h.in build-stamp configure-stamp
+rm -f debian/cvsbp-prepare.sh

Added: branches/trunk-reorg/thirdparty/uffi/debian/docs
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/docs	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,4 @@
+NEWS
+README
+TODO
+AUTHORS

Added: branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/make-upstream.sh	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,6 @@
+#!/bin/bash -e 
+
+bups uffi -d"-name .bin"
+
+exit 0
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/postinst
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/postinst	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,52 @@
+#! /bin/sh
+# postinst script for uffi
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=uffi
+
+# summary of how this script can be called:
+#        * <postinst> `configure' <most-recently-configured-version>
+#        * <old-postinst> `abort-upgrade' <new version>
+#        * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+#          <new-version>
+#        * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+#          <failed-install-package> <version> `removing'
+#          <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+#     Any necessary prompting should almost always be confined to the
+#     post-installation script, and should be protected with a conditional
+#     so that unnecessary prompting doesn't happen if a package's
+#     installation fails and the `postinst' is called with `abort-upgrade',
+#     `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+    configure)
+	#clc-only-compatible $LISP_PKG allegro cmucl lispworks openmcl sbcl scl
+	/usr/sbin/register-common-lisp-source $LISP_PKG
+    ;;
+
+    abort-upgrade|abort-remove|abort-deconfigure)
+
+    ;;
+
+    *)
+        echo "postinst called with unknown argument \`$1'" >&2
+        exit 1
+    ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/preinst
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/preinst	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,23 @@
+#!/bin/bash
+# This is part of uffi program: 
+#    http://uffi.med-info.com
+#
+# Copyright (c) 2002 Kevin M. Rosenberg <kmr at debian.org>
+
+pkg=uffi
+dir=/usr/share/common-lisp/source/$pkg
+
+case "$1" in
+    install|upgrade|abort-upgrade)
+	# Remove any old versions
+	test -h $dir && rm $dir 
+	rm -rf ${dir}-[0-9\.]*
+	;;
+    *)
+        echo "preinst called with unknown argument '$1'" >&2
+	;;
+esac
+
+#DEBHELPER#
+
+exit 0

Added: branches/trunk-reorg/thirdparty/uffi/debian/prerm
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/prerm	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,42 @@
+#! /bin/sh
+# prerm script for uffi
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=uffi
+
+# summary of how this script can be called:
+#        * <prerm> `remove'
+#        * <old-prerm> `upgrade' <new-version>
+#        * <new-prerm> `failed-upgrade' <old-version>
+#        * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+#        * <deconfigured's-prerm> `deconfigure' `in-favour'
+#          <package-being-installed> <version> `removing'
+#          <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+    remove|upgrade|deconfigure)
+	/usr/sbin/unregister-common-lisp-source $LISP_PKG
+        ;;
+    failed-upgrade)
+        ;;
+    *)
+        echo "prerm called with unknown argument \`$1'" >&2
+        exit 1
+    ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/rules
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/rules	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,127 @@
+#!/usr/bin/make -f
+
+pkg		:= uffi
+pkg-tests	:= $(pkg)-tests
+debpkg  	:= cl-$(pkg)
+debpkg-tests  	:= $(debpkg)-tests
+
+
+clc-source	:= usr/share/common-lisp/source
+clc-systems	:= usr/share/common-lisp/systems
+clc-files	:= $(clc-source)/$(pkg)
+clc-tests	:= $(clc-source)/$(pkg-tests)
+doc-dir		:= usr/share/doc/$(debpkg)
+lib-dir		:= usr/lib/uffi
+
+configure: configure-stamp
+configure-stamp:
+	dh_testdir
+	# Add here commands to configure the package.
+	touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp 
+	dh_testdir
+	# Add here commands to compile the package.
+	(cd tests; make)
+	touch build-stamp
+
+clean:
+	dh_testdir
+	dh_testroot
+	rm -f build-stamp configure-stamp
+	# Add here commands to clean up after the build process.
+	$(MAKE) clean
+	(cd tests; make clean)
+	rm -f debian/$(debpkg).postinst.* debian/$(debpkg).prerm.*
+	rm -f doc/cl-uffi.pdf.gz
+	dh_clean
+
+install: build
+	dh_testdir
+	dh_testroot
+	dh_clean -k
+	dh_installdirs --all $(clc-systems) $(clc-source) 
+
+	# Add here commands to install the package into debian/uffi.
+	dh_installdirs -p $(debpkg) $(doc-dir) $(clc-files)/src
+	dh_install $(pkg).asd $(clc-files)
+	dh_install "src/*.lisp" $(clc-files)/src
+	dh_link $(clc-files)/$(pkg).asd $(clc-systems)/$(pkg).asd
+
+	rm -rf doc/html
+	(cd doc; tar xzf html.tar.gz; cd ..)
+	dh_install doc/html $(doc-dir)
+	rm -rf doc/html
+	cp doc/uffi.pdf doc/cl-uffi.pdf
+	rm -f doc/cl-uffi.pdf.gz # ensure file not present before making gz
+	gzip -9 doc/cl-uffi.pdf
+	dh_install doc/cl-uffi.pdf.gz $(doc-dir)
+
+	dh_installdirs -p $(debpkg-tests) $(clc-tests)/tests $(lib-dir)
+	dh_install -p $(debpkg-tests) $(pkg-tests).asd $(clc-tests)
+	dh_install -p $(debpkg-tests) tests/*.lisp tests/*.c $(clc-tests)/tests
+	dh_install -p $(debpkg-tests) tests/*.so $(lib-dir)
+	dh_link -p $(debpkg-tests) $(clc-tests)/$(pkg-tests).asd $(clc-systems)/$(pkg-tests).asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+	dh_testdir -i
+	dh_testroot -i
+#	dh_installdebconf -i
+	dh_installdocs -i
+	dh_installexamples -i examples/*.lisp
+	dh_installmenu -i
+#	dh_installlogrotate -i
+#	dh_installemacsen -i
+#	dh_installpam -i
+#	dh_installmime -i
+#	dh_installinit -i
+	dh_installcron -i
+#	dh_installman -i
+	dh_installinfo -i
+#	dh_undocumented -i
+	dh_installchangelogs ChangeLog -i
+	dh_link -i
+	dh_compress -i
+	dh_fixperms -i
+	dh_installdeb -i
+#	dh_perl -i
+	dh_gencontrol -i
+	dh_md5sums -i
+	dh_builddeb -i
+
+# Build architecture-dependent files here.
+binary-arch: build install
+	dh_testdir -a
+	dh_testroot -a
+#	dh_installdebconf -a
+	dh_installdocs -a
+#	dh_installlogrotate -a
+#	dh_installemacsen -a
+#	dh_installpam -a
+#	dh_installmime -a
+#	dh_installinit -a
+#	dh_installcron -a
+#	dh_installman -a
+#	dh_installinfo -a
+#	dh_undocumented -a
+#	dh_makeshlibs -a
+#	dh_perl -a
+	dh_installchangelogs ChangeLog -a
+	dh_strip -a
+	dh_link -a
+	dh_compress -a
+	dh_fixperms -a
+	dh_installmenu -a
+	dh_installdeb -a
+	dh_gencontrol -a
+	dh_shlibdeps -a
+	dh_md5sums -a
+	dh_builddeb -a
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+

Added: branches/trunk-reorg/thirdparty/uffi/debian/upload.sh
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/upload.sh	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,4 @@
+#!/bin/bash -e
+
+dup uffi -Ufiles.b9.com -D/home/ftp/uffi -su \
+    -C"(umask 022; cd /opt/apache/htdocs/uffi; make install; find . -type d |xargs chmod go+rx; find . -type f | xargs chmod go+r)" $*

Added: branches/trunk-reorg/thirdparty/uffi/debian/watch
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/debian/watch	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,2 @@
+version=3
+http://files.b9.com/uffi/uffi-([\d\.]*)\.tar\.gz	debian	uupdate

Added: branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/COPYING.GFDL	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,330 @@
+		GNU Free Documentation License
+		   Version 1.1, March 2000
+
+ Copyright (C) 2000  Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+0. PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+written document "free" in the sense of freedom: to assure everyone
+the effective freedom to copy and redistribute it, with or without
+modifying it, either commercially or noncommercially.  Secondarily,
+this License preserves for the author and publisher a way to get
+credit for their work, while not being considered responsible for
+modifications made by others.
+
+This License is a kind of "copyleft", which means that derivative
+works of the document must themselves be free in the same sense.  It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does.  But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book.  We recommend this License
+principally for works whose purpose is instruction or reference.
+
+
+1. APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work that contains a
+notice placed by the copyright holder saying it can be distributed
+under the terms of this License.  The "Document", below, refers to any
+such manual or work.  Any member of the public is a licensee, and is
+addressed as "you".
+
+A "Modified Version" of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A "Secondary Section" is a named appendix or a front-matter section of
+the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall subject
+(or to related matters) and contains nothing that could fall directly
+within that overall subject.  (For example, if the Document is in part a
+textbook of mathematics, a Secondary Section may not explain any
+mathematics.)  The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The "Invariant Sections" are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License.
+
+The "Cover Texts" are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License.
+
+A "Transparent" copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, whose contents can be viewed and edited directly and
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters.  A copy made in an otherwise Transparent file
+format whose markup has been designed to thwart or discourage
+subsequent modification by readers is not Transparent.  A copy that is
+not "Transparent" is called "Opaque".
+
+Examples of suitable formats for Transparent copies include plain
+ASCII without markup, Texinfo input format, LaTeX input format, SGML
+or XML using a publicly available DTD, and standard-conforming simple
+HTML designed for human modification.  Opaque formats include
+PostScript, PDF, proprietary formats that can be read and edited only
+by proprietary word processors, SGML or XML for which the DTD and/or
+processing tools are not generally available, and the
+machine-generated HTML produced by some word processors for output
+purposes only.
+
+The "Title Page" means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page.  For works in
+formats which do not have any title page as such, "Title Page" means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+
+2. VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License.  You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute.  However, you may accept
+compensation in exchange for copies.  If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+
+3. COPYING IN QUANTITY
+
+If you publish printed copies of the Document numbering more than 100,
+and the Document's license notice requires Cover Texts, you must enclose
+the copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover.  Both covers must also clearly and legibly identify
+you as the publisher of these copies.  The front cover must present
+the full title with all words of the title equally prominent and
+visible.  You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a publicly-accessible computer-network location containing a complete
+Transparent copy of the Document, free of added material, which the
+general network-using public has access to download anonymously at no
+charge using public-standard network protocols.  If you use the latter
+option, you must take reasonably prudent steps, when you begin
+distribution of Opaque copies in quantity, to ensure that this
+Transparent copy will remain thus accessible at the stated location
+until at least one year after the last time you distribute an Opaque
+copy (directly or through your agents or retailers) of that edition to
+the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+
+4. MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it.  In addition, you must do these things in the Modified Version:
+
+A. Use in the Title Page (and on the covers, if any) a title distinct
+   from that of the Document, and from those of previous versions
+   (which should, if there were any, be listed in the History section
+   of the Document).  You may use the same title as a previous version
+   if the original publisher of that version gives permission.
+B. List on the Title Page, as authors, one or more persons or entities
+   responsible for authorship of the modifications in the Modified
+   Version, together with at least five of the principal authors of the
+   Document (all of its principal authors, if it has less than five).
+C. State on the Title page the name of the publisher of the
+   Modified Version, as the publisher.
+D. Preserve all the copyright notices of the Document.
+E. Add an appropriate copyright notice for your modifications
+   adjacent to the other copyright notices.
+F. Include, immediately after the copyright notices, a license notice
+   giving the public permission to use the Modified Version under the
+   terms of this License, in the form shown in the Addendum below.
+G. Preserve in that license notice the full lists of Invariant Sections
+   and required Cover Texts given in the Document's license notice.
+H. Include an unaltered copy of this License.
+I. Preserve the section entitled "History", and its title, and add to
+   it an item stating at least the title, year, new authors, and
+   publisher of the Modified Version as given on the Title Page.  If
+   there is no section entitled "History" in the Document, create one
+   stating the title, year, authors, and publisher of the Document as
+   given on its Title Page, then add an item describing the Modified
+   Version as stated in the previous sentence.
+J. Preserve the network location, if any, given in the Document for
+   public access to a Transparent copy of the Document, and likewise
+   the network locations given in the Document for previous versions
+   it was based on.  These may be placed in the "History" section.
+   You may omit a network location for a work that was published at
+   least four years before the Document itself, or if the original
+   publisher of the version it refers to gives permission.
+K. In any section entitled "Acknowledgements" or "Dedications",
+   preserve the section's title, and preserve in the section all the
+   substance and tone of each of the contributor acknowledgements
+   and/or dedications given therein.
+L. Preserve all the Invariant Sections of the Document,
+   unaltered in their text and in their titles.  Section numbers
+   or the equivalent are not considered part of the section titles.
+M. Delete any section entitled "Endorsements".  Such a section
+   may not be included in the Modified Version.
+N. Do not retitle any existing section as "Endorsements"
+   or to conflict in title with any Invariant Section.
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant.  To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section entitled "Endorsements", provided it contains
+nothing but endorsements of your Modified Version by various
+parties--for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version.  Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity.  If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+
+5. COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy.  If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections entitled "History"
+in the various original documents, forming one section entitled
+"History"; likewise combine any sections entitled "Acknowledgements",
+and any sections entitled "Dedications".  You must delete all sections
+entitled "Endorsements."
+
+
+6. COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+
+7. AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, does not as a whole count as a Modified Version
+of the Document, provided no compilation copyright is claimed for the
+compilation.  Such a compilation is called an "aggregate", and this
+License does not apply to the other self-contained works thus compiled
+with the Document, on account of their being thus compiled, if they
+are not themselves derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one quarter
+of the entire aggregate, the Document's Cover Texts may be placed on
+covers that surround only the Document within the aggregate.
+Otherwise they must appear on covers around the whole aggregate.
+
+
+8. TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections.  You may include a
+translation of this License provided that you also include the
+original English version of this License.  In case of a disagreement
+between the translation and the original English version of this
+License, the original English version will prevail.
+
+
+9. TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License.  Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License.  However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+
+10. FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time.  Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.  See
+http://www.gnu.org/copyleft/.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License "or any later version" applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation.  If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,144 @@
+##############################################################################
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile
+#  Purpose:      Makefile for the uffi documentation
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id$
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+##############################################################################
+
+DOCFILE_BASE_DEFAULT:=uffi
+DOCFILE_EXT_DEFAULT:=xml
+
+
+# Standard docfile processing
+
+DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*')
+UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*')
+SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*')
+SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*')
+REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*')
+MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*')
+DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*')
+
+ifneq (${DEBIAN},0)
+OS:=debian
+else
+  ifneq (${SUSE91},0)
+    OS=suse91
+  else
+    ifneq (${SUSE},0)
+      OS=suse
+    else   
+      ifneq (${REDHAT},0)
+        OS=redhat
+      else   
+        ifneq (${MANDRAKE},0)
+          OS=mandrake
+        else   
+          ifneq (${DARWIN},0)
+            OS=darwin
+          else  
+            ifneq (${UBUNTU},0)
+              OS=ubuntu
+            endif 
+          endif 
+        endif
+      endif
+    endif
+  endif
+endif
+
+ifndef DOCFILE_BASE
+DOCFILE_BASE=${DOCFILE_BASE_DEFAULT}
+endif
+
+ifndef DOCFILE_EXT
+DOCFILE_EXT=${DOCFILE_EXT_DEFAULT}
+endif
+
+DOCFILE:=${DOCFILE_BASE}.${DOCFILE_EXT}
+FOFILE:=${DOCFILE_BASE}.fo
+PDFFILE:=${DOCFILE_BASE}.pdf
+PSFILE:=${DOCFILE_BASE}.ps
+DVIFILE:=${DOCFILE_BASE}.dvi
+TXTFILE:=${DOCFILE_BASE}.txt
+HTMLFILE:=${DOCFILE_BASE}.html
+TMPFILES:=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log
+DOCFILES:=$(shell echo *.xml *.xsl)
+
+ifeq ($(XSLTPROC),)
+  XSLTPROC:=xsltproc
+endif
+
+CATALOG:=`pwd`/catalog-${OS}.xml
+CHECK:=XML_CATALOG_FILES="$(CATALOG)" xmllint --noout --xinclude --postvalid $(DOCFILE) || exit 1
+
+.PHONY: all
+all: html pdf 
+
+.PHONY: dist
+dist: html pdf
+
+.PHONY: doc
+doc: html pdf
+
+.PHONY: check
+check:
+	@echo "Operating System Detected: ${OS}"
+	@$(CHECK)
+
+.PHONY: html
+html: html.tar.gz
+
+html.tar.gz: $(DOCFILES) Makefile 
+	@rm -rf html
+	@mkdir html
+	@XML_CATALOG_FILES="$(CATALOG)" $(XSLTPROC) --stringparam chunker.output.encoding UTF-8 \
+		 --xinclude --output html/ html_chunk.xsl $(DOCFILE)
+	@GZIP='-9' tar czf html.tar.gz html 
+
+.PHONY: fo
+fo: ${FOFILE}
+
+${FOFILE}: $(DOCFILES) Makefile 
+	@XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output $(FOFILE) fo.xsl $(DOCFILE)
+
+.PHONY: pdf
+pdf: ${PDFFILE}
+
+${PDFFILE}: ${DOCFILES} Makefile
+	@$(MAKE) fo
+	@fop $(FOFILE) -pdf $(PDFFILE) > /dev/null
+
+.PHONY: dvi
+dvi: ${DVIFILE}
+
+.PHONY: ps
+ps: ${PSFILE}
+
+${PSFILE}: ${DOCFILES} Makefile
+	@$(MAKE) fo
+	@fop $(FOFILE) -ps $(PSFILE) > /dev/null
+
+
+.PHONY: txt
+txt: ${TXTFILE}
+
+${TXTFILE}: ${FOFILE}
+	@XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output ${HTMLFILE} html.xsl $(DOCFILE)
+	lynx -dump ${HTMLFILE} > ${TXTFILE}
+
+.PHONY: clean
+clean: 
+	@rm -f *~ *.bak *.orig \#*\# .\#* texput.log
+	@rm -rf html ${PSFILE} ${HTMLFILE}
+	@rm -f ${TMPFILES} ${FOFILE}
+	@rm -f  ${DVIFILE} ${TXTFILE}
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/appendix.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,35 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<appendix id="installation">
+  <title>Installation</title>
+  <sect1 id="download">
+    <title>Download &uffi;</title>
+    <para>
+You need to download the &uffi; package from its web
+<ulink url="http://uffi.b9.com"><citetitle>home</citetitle></ulink>.
+You also need to have a copy of &asdf;. If you need a copy of
+&asdf;, it is included in the 
+  <ulink
+      url="http://www.sourceforge.net/projects/cclan">
+      <citetitle>CCLAN</citetitle></ulink> package. You can download
+the file <filename>defsystem.lisp</filename> from the CVS 
+<ulink url="http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp"><citetitle>tree</citetitle></ulink>.
+    </para>
+  </sect1>
+  <sect1 id="loading">
+    <title>Loading</title>
+    <para>
+      After downloading and installing &asdf;, simply
+      <function>push</function> the
+      directory containing &uffi; into
+      <varname>asdf:*central-registry*</varname> variable. Whenever you
+want to load the &uffi; package, use the form
+      <computeroutput>(asdf:operate 'asdf:load-op :uffi)</computeroutput>.
+    </para>
+  </sect1>
+</appendix>

Added: branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/bookinfo.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,77 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<bookinfo>
+  <title>&uffi; Reference Guide</title>
+  <author>
+    <firstname>Kevin</firstname>
+    <othername>M.</othername>
+    <surname>Rosenberg</surname>
+    <affiliation>
+      <orgname>Heart Hospital of New Mexico</orgname>
+      <address>
+	<email>kevin at rosenberg.net</email>
+	<street>504 Elm Street N.E.</street>
+	<city>Albuquerque</city>
+	<state>New Mexico</state>
+	<postcode>87102</postcode>
+      </address>
+    </affiliation>
+  </author>
+  
+  <printhistory>
+    <simpara>$Id$</simpara>
+    <simpara>File $Date$</simpara>
+  </printhistory>
+  <copyright>
+    <year>2002-2003</year>
+    <holder>Kevin M. Rosenberg</holder>
+  </copyright>
+  <legalnotice>
+    <itemizedlist>
+      <listitem>
+	<para>The &uffi; package was designed and
+	  written by Kevin M. Rosenberg.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  Permission is granted to copy, distribute and/or modify this document
+	  under the terms of the GNU Free Documentation License, Version 1.1
+	  or any later version published by the Free Software Foundation;
+	  with no Invariant Sections, with the no
+	  Front-Cover Texts, and with no Back-Cover Texts.
+	  A copy of the license is included in the &uffi; distribution.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Allegro CL</application>&reg; is a registered
+	  trademark of Franz Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Lispworks</application>&reg; is a registered
+	  trademark of Xanalys Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Microsoft Windows</application>&reg; is a
+	  registered trademark of Microsoft Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  Other brand or product names are the registered trademarks
+	  or trademarks of their respective holders.
+	</para>
+      </listitem>
+    </itemizedlist>
+  </legalnotice>
+</bookinfo>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-darwin.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///sw/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/docbookx/4.2.0/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="xsl/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2.0/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="xsl/docbook-xsl/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="xsl/docbook-xsl/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="xsl/docbook-xsl/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-debian.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/xml/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="stylesheet/xsl/nwalsh/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-mandrake.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="xml-dtd-4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="xsl-stylesheets/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="xml-dtd-4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="xml-dtd-4.2/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="xsl-stylesheets/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="xsl-stylesheets/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="xsl-stylesheets/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="db42xml/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="db42xml/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="db42xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse90.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="db42xml/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="db42xml/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="db42xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="docbook/docbook-xsl/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/docbook-xsl/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/docbook-xsl/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-suse91.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,48 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="docbook/schema/dtd/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/stylesheet/nwalsh/current/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="docbook/schema/dtd/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+          uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <uri
+        name="docbookx.dtd"
+         uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <system
+         systemId="docbookx.dtd"
+          uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+         uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/catalog-ubuntu.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/xml/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="stylesheet/xsl/nwalsh/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi/doc/entities.inc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/entities.inc	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,16 @@
+<!ENTITY uffi "<application><emphasis>UFFI</emphasis></application>">
+<!ENTITY ffi "<acronym>FFI</acronym>">
+<!ENTITY cmucl "<application>CMUCL</application>">
+<!ENTITY scl "<application>SCL</application>">
+<!ENTITY lw "<application>Lispworks</application>">
+<!ENTITY sbcl "<application>SBCL</application>">
+<!ENTITY openmcl "<application>OpenMCL</application>">
+<!ENTITY mcl "<application>MCL</application>">
+<!ENTITY acl "<application>AllegroCL</application>">
+<!ENTITY cl "<application>ANSI Common Lisp</application>">
+<!ENTITY t "<constant>T</constant>">
+<!ENTITY nil "<constant>NIL</constant>">
+<!ENTITY null "<constant>NULL</constant>">
+<!ENTITY c "<computeroutput>C</computeroutput>">
+<!ENTITY defsystem "<application>defsystem</application>">
+<!ENTITY asdf "<application>ASDF</application>">

Added: branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/fo.xsl	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,8 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_fo.xsl"/>
+<xsl:param name="fop.extensions" select="1"/>
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/glossary.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,21 @@
+<?xml version="1.0" ?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<glossary id="glossary">
+  <glossentry id="gloss-ffi">
+    <glossterm>Foreign Function Interface
+      <acronym>FFI</acronym>)
+    </glossterm>
+    <glossdef>
+      <para>
+        An interface to a C-compatible library.
+      </para>
+    </glossdef>
+  </glossentry>
+</glossary>
+
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/html.tar.gz
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/uffi/doc/html.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/html.xsl	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,10 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_html.xsl"/>
+<xsl:param name="use.id.as.filename" select="1"/>
+<xsl:output encoding="UTF-8" method="html" />
+
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/html_chunk.xsl	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,9 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_chunk.xsl"/>
+<xsl:param name="use.id.as.filename" select="1"/>
+
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/intro.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/intro.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,113 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<chapter id="introduction">
+  <title>Introduction</title>
+  <sect1 id="purpose">
+    <title>Purpose</title>
+    <para>
+      This reference guide describes &uffi;, a package that provides a
+      cross-implementation interface from Common Lisp to C-language
+      compatible libraries.
+    </para>
+  </sect1>
+  
+  <sect1 id="background">
+    <title>Background
+    </title>
+    <para>
+      Every Common Lisp implementation has a method for interfacing to
+      C-language compatible libraries. These methods are often termed
+      a <emphasis>Foreign Function Library Interface</emphasis>
+      (&ffi;). Unfortunately, these methods vary widely amongst
+      implementations, thus preventing the writing of a portable FFI
+      to a particular C-library.
+    </para>
+    <para>
+      &uffi; gathers a common subset of functionality between Common
+      Lisp implementations. &uffi; wraps this common subset of
+      functionality with it's own syntax and provides macro
+      translation of uffi functions into the specific syntax of
+      supported Common Lisp implementations.
+    </para>
+    <para>
+      Developers who use &uffi; to interface with C libraries will
+      automatically have their code function in each of uffi's supported
+      implementations.
+    </para>
+  </sect1>
+
+  <sect1 id="supported-impl">
+    <title>Supported Implementations</title> 
+    <para>The primary tested and supported platforms for &uffi; are: 
+    </para>
+    <itemizedlist mark="opencircle">
+      <listitem><para>&acl; v6.2 on Debian GNU/Linux
+      FreeBSD 4.5, Solaris v2.8, and Microsoft Windows XP.</para></listitem>
+      <listitem><para>&lw; v4.2 on Debian GNU/Linux and Microsoft Windows XP.</para></listitem>
+      <listitem><para>&cmucl; 18d on Debian GNU/Linux, FreeBSD 4.5, and Solaris 2.8</para></listitem>
+      <listitem><para>&sbcl; 0.7.8 on Debian GNU/Linux</para></listitem>
+      <listitem><para>&scl; 1.1.1 on Debian GNU/Linux</para></listitem>
+      <listitem><para>&openmcl; 0.13 on Debian GNU/Linux for PowerPC</para></listitem>
+    </itemizedlist>
+    <para>Beta code is included with &uffi; for
+    </para>
+    <itemizedlist mark="opencircle">
+      <listitem><para>&openmcl; and &mcl; with MacOSX</para></listitem>
+    </itemizedlist>
+  </sect1>
+
+  <sect1 id="design">
+    <title>Design</title>
+    <sect2>
+      <title>Overview</title>
+      <para>
+	&uffi; was designed as a cross-implementation 
+	compatible <emphasis>Foreign Function Interface</emphasis>.
+	Necessarily,
+	only a common subset of functionality can be
+	provided. Likewise, not every optimization for that a specific
+	implementation provides can be supported. Wherever possible,
+	though, implementation-specific optimizations are invoked.
+      </para> 
+    </sect2>
+
+    <sect2>
+      <title>Priorities</title>
+      <para>
+	The design of &uffi; is dictated by the order of these priorities:
+      </para>
+      <itemizedlist>
+	<listitem>
+	  <para>
+	    Code using &uffi; must operate correctly on all
+	    supported implementations.
+	  </para>
+	</listitem>
+	<listitem>
+	  <para>
+	    Take advantage of implementation-specific optimizations. Ideally, 
+	    there will not a situation where an implementation-specific
+	    &ffi; will be chosen due to lack of optimizations in &uffi;.
+	  </para>
+	</listitem>
+	<listitem>
+	  <para>Provide a simple interface to developers using
+	  &uffi;.  This priority is quite a bit lower than the above priorities.
+	  This lower priority is manifest by programmers having to pass types in
+	  pointer and array dereferencing, needing to use
+	  <constant>cstring</constant> wrapper functions, and the use of
+	  ensure-char-character and ensure-char-integer functions. My hope is
+	  that the developer inconvenience will be outweighed by the generation
+	  of optimized code that is cross-implementation compatible.
+	  </para>
+	</listitem>
+      </itemizedlist>
+    </sect2>
+  </sect1>
+
+</chapter>

Added: branches/trunk-reorg/thirdparty/uffi/doc/notes.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/notes.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,94 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<chapter id="notes">
+  <title>Programming Notes</title>
+
+  <sect1 id="impl-specific">
+    <title>Implementation Specific Notes</title> 
+    <para>
+    </para>
+      <sect2>
+	<title>&acl;</title>
+	<para>
+	</para>
+      </sect2>
+      <sect2>
+	<title>&lw;</title>
+	<para>
+	</para>
+      </sect2>
+      <sect2>
+	<title>&cmucl;</title>
+	<para>
+	</para>
+      </sect2>
+  </sect1>
+
+  <sect1 id="object-represen">
+    <title>Foreign Object Representation and Access</title>
+    <para> There are two main approaches used to represent foreign
+    objects: an integer that represents an address in memory, and a
+    object that also includes run-time typing. The advantage of
+    run-time typing is the system can dereference pointers and perform
+    array access without those functions requiring a type at the cost
+    of additional overhead to generate and store the run-time
+    typing. The advantage of integer representation, at least for
+    &acl;, is that the compiler can generate inline code to
+    dereference pointers. Further, the overhead of the run-time type
+    information is eliminated. The disadvantage is the program must
+    then supply
+    the type to the functions to dereference objects and array.
+    </para>
+  </sect1>
+
+  <sect1 id="optimizing">
+    <title>Optimizing Code Using UFFI</title>
+    <sect2>
+      <title>Background</title>
+      <para> 
+	Two implementions have different techniques to optimize
+	(open-code) foreign objects. &acl; can open-code foreign
+	object
+	access if pointers are integers and the type of object is
+    specified in the access function.  Thus, &uffi; represents objects
+    in &acl; as integers which don't have type information.
+    </para> <para> 
+      &cmucl; works best when keeping objects as typed
+    objects. However, it's compiler can open-code object access when
+    the object type is specified in <function>declare</function>
+    commands and in <varname>:type</varname> specifiers in
+    <function>defstruct</function> and <function>defclass</function>.
+    </para> <para> &lw;, in converse to &acl; and &cmucl; does not do
+    any open coding of object access. &lw;, by default, maintains
+    objects with run-time typing.  </para>
+    </sect2>
+    <sect2>
+      <title>Cross-Implementation Optimization</title>
+      <para>
+	To fully optimize across platforms, both explicit type
+	information must be passed to dereferencing of pointers and
+	arrays. Though this optimization only helps with &acl;, &uffi;
+	is designed to require this type information be passed the
+	dereference functions. Second, declarations of type should be
+	made in functions, structures, and classes where foreign
+	objects will be help. This will optimize access for &lw;
+      </para>
+      <para>
+	Here is an example that should both methods being used for
+	maximum cross-implementation optimization:
+	<screen>
+(uffi:def-type the-struct-type-def the-struct-type)
+(let ((a-foreign-struct (allocate-foreign-object 'the-struct-type)))
+  (declare 'the-struct-type-def a-foreign-struct)
+  (get-slot-value a-foreign-struct 'the-struct-type 'field-name))
+	</screen>
+      </para>
+    </sect2>
+  </sect1>
+
+</chapter>

Added: branches/trunk-reorg/thirdparty/uffi/doc/preface.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/preface.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<preface id="preface">
+  <title>Preface</title>
+  <para>This reference guide describes the usage and features of
+  &uffi;.  The first chapter provides an overview to the design of
+  &uffi;.  Following that chapter is the reference section for all
+  user accessible functions of &uffi;. The appendix covers the
+  installation and implementation-specifc features of &uffi;.
+  </para>
+</preface>

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_aggregate.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,524 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="aggregates">
+    <title>Aggregate Types</title>
+    <partintro>
+      <title>Overview</title>
+      <para>
+	Aggregate types are comprised of one or more primitive types.
+      </para>
+    </partintro>
+
+    <refentry id="def-enum">
+      <refnamediv>
+	<refname>def-enum</refname>
+	<refpurpose>Defines a &c; enumeration.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-enum</function> <replaceable>name fields &amp;key separator-string</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A symbol that names the enumeration.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A list of field defintions. Each definition can be
+a symbol or a list of two elements. Symbols get assigned a value of the
+current counter which starts at <computeroutput>0</computeroutput> and
+increments by <computeroutput>1</computeroutput> for each subsequent symbol. It the field definition is a list, the first position is the symbol and the second
+position is the value to assign the the symbol. The current counter gets set
+to <computeroutput>1+</computeroutput> this value.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>separator-string</parameter></term>
+	    <listitem>
+	      <para>A string that governs the creation of constants. The
+default is <computeroutput>"#"</computeroutput>.</para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Declares a &c; enumeration. It generates constants with integer values for the elements of the enumeration. The symbols for the these constant
+values are created by the <function>concatenation</function> of the
+enumeration name, separator-string, and field symbol. Also creates
+a foreign type with the name <parameter>name</parameter> of type
+<constant>:int</constant>.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-enum abc (:a :b :c)) 
+;; Creates constants abc#a (1), abc#b (2), abc#c (3) and defines
+;; the foreign type "abc" to be :int
+
+(def-enum efoo (:e1 (:e2 10) :e3) :separator-string "-")
+;; Creates constants efoo-e1 (1), efoo-e2 (10), efoo-e3 (11) and defines
+;; the foreign type efoo to be :int
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Creates a :int foreign type, defines constants.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+      <refentry id="def-struct">
+	<refnamediv>
+	  <refname>def-struct</refname>
+	<refpurpose>Defines a &c; structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-struct</function> <replaceable>name &amp;rest fields</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A symbol that names the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A variable number of field defintions. Each definition is a list consisting of a symbol naming the field followed by its foreign type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Declares a structure. A special type is available as a slot
+in the field. It is a pointer that points to an instance of the parent
+structure. It's type is <constant>:pointer-self</constant>.
+
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-struct foo (a :unsigned-int) 
+                (b (* :char)) 
+                (c (:array :int 10)) 
+                (next :pointer-self))
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Creates a foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="get-slot-value">
+      <refnamediv>
+	<refname>get-slot-value</refname>
+	<refpurpose>Retrieves a value from a slot of a structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>get-slot-value</function> <replaceable>obj type field</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>obj</parameter></term>
+	    <listitem>
+	      <para>A pointer to foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A name of the foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>field</parameter></term>
+	    <listitem>
+	      <para>A name of the desired field in foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the field in the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Accesses a slot value from a structure. This is generalized
+	  and can be used with <function>setf</function>.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(get-slot-value foo-ptr 'foo-structure 'field-name)
+(setf (get-slot-value foo-ptr 'foo-structure 'field-name) 10)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="get-slot-pointer">
+      <refnamediv>
+	<refname>get-slot-pointer</refname>
+	<refpurpose>Retrieves a pointer from a slot of a structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>get-slot-pointer</function> <replaceable>obj type field</replaceable> => <returnvalue>pointer</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>obj</parameter></term>
+	    <listitem>
+	      <para>A pointer to foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A name of the foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>field</parameter></term>
+	    <listitem>
+	      <para>A name of the desired field in foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>pointer</returnvalue></term>
+	    <listitem>
+	      <para>The value of the field in the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  This is similar to <function>get-slot-value</function>. It
+	  is used when the value of a slot is a pointer type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(get-slot-pointer foo-ptr 'foo-structure 'my-char-ptr)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="def-array-pointer">
+      <refnamediv>
+	<refname>def-array-pointer</refname>
+	<refpurpose>Defines a pointer to a array of type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-array-pointer</function> <replaceable>name type</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A name of the new foreign type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The foreign type of the array elements.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Defines a type tat is a pointer to an array of type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-array-pointer byte-array-pointer :unsigned-char)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Defines a new foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="deref-array">
+      <refnamediv>
+	<refname>deref-array</refname>
+	<refpurpose>Deference an array.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>deref-array</function> <replaceable>array type position</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>array</parameter></term>
+	    <listitem>
+	      <para>A foreign array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The foreign type of the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>position</parameter></term>
+	    <listitem>
+	      <para>An integer specifying the position to retrieve from
+the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value stored in the position of the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Dereferences (retrieves) the value of an array element.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-array-pointer ca :char)
+(let ((fs (convert-to-foreign-string "ab")))
+   (values (null-char-p (deref-array fs 'ca 0))
+           (null-char-p (deref-array fs 'ca 2))))
+=> &nil;
+   &t;
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Notes</title>
+        <para>
+  The TYPE argument is ignored for CL implementations other than
+  AllegroCL. If you want to cast a pointer to another type use
+  WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY.
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="def-union">
+      <refnamediv>
+	<refname>def-union</refname>
+	<refpurpose>Defines a foreign union type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-union</function> <replaceable>name &amp;rest fields</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A name of the new union type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A list of fields of the union.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Defines a foreign union type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-union test-union
+  (a-char :char)
+  (an-int :int))
+
+(let ((u (allocate-foreign-object 'test-union))
+  (setf (get-slot-value u 'test-union 'an-int) (+ 65 (* 66 256)))
+  (prog1 
+    (ensure-char-character (get-slot-value u 'test-union 'a-char))
+    (free-foreign-object u)))
+=> #\A
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Defines a new foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_declare.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,82 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+  
+<reference id="ref_declarations">
+  <title>Declarations</title>
+  
+  <partintro>
+    <sect1>
+      <title>Overview</title>
+      <para>Declarations are used to give the compiler optimizing
+	information about foreign types. Currently, only &cmucl;
+	supports declarations. On &acl; and &lw;, these expressions 
+	declare the type generically as &t;
+      </para>
+    </sect1>
+  </partintro>
+
+  <refentry id="def-type">
+    <refnamediv>
+      <refname>def-type</refname>
+      <refpurpose>Defines a Common Lisp type. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-type</function> <replaceable>name type</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the type</para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>type</parameter></term>
+	  <listitem>
+	    <para>A form that specifies the &uffi; type. It is not evaluated.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>Defines a Common Lisp type based on a &uffi; type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-type char-ptr '(* :char))
+...
+(defun foo (ptr)
+(declare (type char-ptr ptr))
+...
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Defines a new &cl; type.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+</reference>
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_func_libr.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,264 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="func_libr">
+      <title>Functions &amp; Libraries</title>
+
+      <refentry id="def-function">
+	<refnamediv>
+	  <refname>def-function</refname>
+	<refpurpose>Declares a function. 
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-function</function> <replaceable>name args &amp;key module returning</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A string or list specificying the function name. If it is a string, that names the foreign function. A Lisp name is created by translating #\_ to #\- and by converting to upper-case in case-insensitive Lisp implementations. If it is a list, the first item is a string specifying the foreign function name and the second it is a symbol stating the Lisp name.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>args</parameter></term>
+	    <listitem>
+	      <para>A list of argument declarations. If &nil;, indicates that the function does not take any arguments.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>module</parameter></term>
+	    <listitem>
+	      <para>A string specifying which module (or library) that the foreign function resides. (Required by Lispworks)</para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>returning</returnvalue></term>
+	    <listitem>
+	      <para>A declaration specifying the result type of the
+foreign function. If <constant>:void</constant> indicates module does not return any value.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Declares a foreign function.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-function "gethostname" 
+  ((name (* :unsigned-char))
+   (len :int))
+  :returning :int)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+      <refentry id="load-foreign-library">
+	<refnamediv>
+	  <refname>load-foreign-library</refname>
+	<refpurpose>Loads a foreign library. 
+	</refpurpose>
+	<refclass>Function</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Syntax</title>
+<synopsis>
+	  <function>load-foreign-library</function> <replaceable>filename &amp;key module supporting-libraries force-load</replaceable> => <returnvalue>success</returnvalue>
+</synopsis>
+      </refsect1>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>filename</parameter></term>
+	    <listitem>
+	      <para>A string or pathname specifying the library location
+in the filesystem. At least one implementation (&lw;) can not
+accept a logical pathname.  If this parameter denotes a pathname without a
+directory component then most of the supported Lisp implementations will be
+able to find the library themselves if it is located in one of the standard
+locations as defined by the underlying operating system.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>module</parameter></term>
+	    <listitem>
+	      <para>A string designating the name of the module to apply
+to functions in this library. (Required for Lispworks)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>supporting-libraries</parameter></term>
+	    <listitem>
+	      <para>A list of strings naming the libraries required to
+link the foreign library. (Required by CMUCL)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>force-load</parameter></term>
+	    <listitem>
+	      <para>Forces the loading of the library if it has been previously loaded. 
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>success</returnvalue></term>
+	    <listitem>
+	      <para>A boolean flag, &t; if the library was able to be
+loaded successfully or if the library has been previously loaded,
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Loads a foreign library. Applies a module name to functions
+within the library. Ensures that a library is only loaded once during
+a session. A library can be reloaded by using the <symbol>:force-load</symbol> key.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+  (load-foreign-library #p"/usr/lib/libmysqlclient.so" 
+                        :module "mysql" 
+                        :supporting-libraries '("c"))
+    => T
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Loads the foreign code into the Lisp system.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>Ability to load the file.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>An error will be signaled if the library is unable to be loaded.</para>
+      </refsect1>
+    </refentry>
+
+      <refentry id="find-foreign-library">
+	<refnamediv>
+	  <refname>find-foreign-library</refname>
+	<refpurpose>Finds a foreign library file.
+	</refpurpose>
+	<refclass>Function</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Syntax</title>
+<synopsis>
+	  <function>find-foreign-library</function> <replaceable>names directories &amp; drive-letters types</replaceable> => <returnvalue>path</returnvalue>
+</synopsis>
+      </refsect1>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>names</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the base name of the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>directories</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the directory the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>drive-letters</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the drive letters for the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>types</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the file type of the library file. Default
+is &nil;. If &nil;, will use a default type based on the currently running implementation.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>path</returnvalue></term>
+	    <listitem>
+	      <para>A path containing the path found, or &nil; if the library file was not found.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Finds a foreign library by searching through a number of possible locations. Returns
+the path of the first found file.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(find-foreign-library '("libmysqlclient" "libmysql")
+    '("/opt/mysql/lib/mysql/" "/usr/local/lib/" "/usr/lib/" "/mysql/lib/opt/")
+    :types '("so" "dll")
+    :drive-letters '("C" "D" "E"))
+=> #P"D:\\mysql\\lib\\opt\\libmysql.dll"
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>
+
+

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_object.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,859 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="objects">
+  <title>Objects</title>
+<partintro>
+<title>Overview</title>
+    <para>
+      Objects are entities that can allocated, referred to by pointers, and
+can be freed.
+    </para>
+</partintro>
+
+
+    <refentry id="allocate-foreign-object">
+      <refnamediv>
+	<refname>allocate-foreign-object</refname>
+	<refpurpose>Allocates an instance of a foreign object.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>allocate-foreign-object</function> <replaceable>type &amp;optional size</replaceable> => <returnvalue>ptr</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The type of foreign object to allocate. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>size</parameter></term>
+	    <listitem>
+	      <para>An optional size parameter that is evaluated. If specified, allocates and returns an
+array of <parameter>type</parameter> that is <parameter>size</parameter> members long. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>ptr</returnvalue></term>
+	    <listitem>
+	      <para>A pointer to the foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Allocates an instance of a foreign object. It returns a pointer to the object.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-struct ab (a :int) (b :double))
+(allocate-foreign-object 'ab)
+=> #&lt;ptr&gt;
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="free-foreign-object">
+      <refnamediv>
+	<refname>free-foreign-object</refname>
+	<refpurpose>Frees memory that was allocated for a foreign boject.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>free-foreign-object</function> <replaceable>ptr</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to the allocated foreign object to free.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Frees the memory used by the allocation of a foreign object.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="with-foreign-object">
+      <refnamediv>
+	<refname>with-foreign-object</refname>
+	<refpurpose>Wraps the allocation of a foreign object around a body of code.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>with-foreign-object</function> <replaceable>(var type) &amp;body body</replaceable> => <returnvalue>form-return</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>var</parameter></term>
+	    <listitem>
+	      <para>The variable name to bind.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The type of foreign object to allocate. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>form-return</returnvalue></term>
+	    <listitem>
+	      <para>The result of evaluating the <parameter>body</parameter>.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+This function wraps the allocation, binding, and destruction of a foreign object.
+On &cmucl; and
+&lw; platforms the object is stack allocated for efficiency. Benchmarks show that &acl; performs
+much better with static allocation.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(defun gethostname2 ()
+  "Returns the hostname"
+  (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+    (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+	(uffi:convert-from-foreign-string name)
+	(error "gethostname() failed."))))
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="size-of-foreign-type">
+      <refnamediv>
+	<refname>size-of-foreign-type</refname>
+	<refpurpose>Returns the number of data bytes used by a foreign object type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>size-of-foreign-type</function> <replaceable>ftype</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ftype</parameter></term>
+	    <listitem>
+	      <para>A foreign type specifier. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the number of data bytes used by a foreign object type. This does not include any Lisp storage overhead.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(size-of-foreign-object :unsigned-byte)
+=> 1
+(size-of-foreign-object 'my-100-byte-vector-type)
+=> 100
+</screen>
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="pointer-address">
+      <refnamediv>
+	<refname>pointer-address</refname>
+	<refpurpose>Returns the address of a pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>pointer-address</function> <replaceable>ptr</replaceable> => <returnvalue>address</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>address</parameter></term>
+	    <listitem>
+	      <para>An integer representing the pointer's address.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the address as an integer of a pointer.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="deref-pointer">
+      <refnamediv>
+	<refname>deref-pointer</refname>
+	<refpurpose>Deferences a pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>deref-pointer</function> <replaceable>ptr type</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the object being pointed to.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the object where the pointer points.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the object to which a pointer points.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((intp (allocate-foreign-object :int)))
+  (setf (deref-pointer intp :int) 10)
+  (prog1
+    (deref-pointer intp :int)
+    (free-foreign-object intp)))
+=> 10
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Notes</title>
+        <para>
+  The TYPE argument is ignored for CL implementations other than
+  AllegroCL. If you want to cast a pointer to another type use
+  WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY.
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="ensure-char-character">
+      <refnamediv>
+	<refname>ensure-char-character</refname>
+	<refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is
+a character.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>ensure-char-character</function> <replaceable>object</replaceable> => <returnvalue>char</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>object</parameter></term>
+	    <listitem>
+	      <para>Either a character or a integer specifying a character code.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>char</returnvalue></term>
+	    <listitem>
+	      <para>A character.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Ensures that an objects obtained by dereferencing  
+<constant>:char</constant> and <constant>:unsigned-char</constant>
+pointers are a lisp character.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((fs (convert-to-foreign-string "a")))
+  (prog1 
+    (ensure-char-character (deref-pointer fs :char))
+    (free-foreign-object fs)))
+=> #\a
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>Depending upon the implementation and what &uffi; expects, this
+macro may signal an error if the object is not a character or
+integer.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="ensure-char-integer">
+      <refnamediv>
+	<refname>ensure-char-integer</refname>
+	<refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is
+an integer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>ensure-char-integer</function> <replaceable>object</replaceable> => <returnvalue>int</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>object</parameter></term>
+	    <listitem>
+	      <para>Either a character or a integer specifying a character code.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>int</returnvalue></term>
+	    <listitem>
+	      <para>An integer.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Ensures that an object obtained by dereferencing a 
+<constant>:char</constant> pointer is an integer.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((fs (convert-to-foreign-string "a")))
+  (prog1 
+    (ensure-char-integer (deref-pointer fs :char))
+    (free-foreign-object fs)))
+=> 96
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>Depending upon the implementation and what &uffi; expects, this
+macro may signal an error if the object is not a character or
+integer.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="make-null-pointer">
+      <refnamediv>
+	<refname>make-null-pointer</refname>
+	<refpurpose>Create a &null; pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>make-null-pointer</function> <replaceable>type</replaceable> => <returnvalue>ptr</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A type of object to which the pointer refers.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>The &null; pointer of type <parameter>type</parameter>.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Creates a &null; pointer of a specified type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="null-pointer-p">
+      <refnamediv>
+	<refname>null-pointer-p</refname>
+	<refpurpose>Tests a pointer for &null; value.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>null-pointer-p</function> <replaceable>ptr</replaceable> => <returnvalue>is-null</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A foreign object pointer.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>is-null</returnvalue></term>
+	    <listitem>
+	      <para>The boolean flag.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  A predicate testing if a pointer is has a &null; value.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="null-cstring-pointer">
+      <refnamediv>
+	<refname>+null-cstring-pointer+</refname>
+	<refpurpose>A constant &null; cstring pointer.
+	</refpurpose>
+	<refclass>Constant</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  A &null; cstring pointer. This can be used for testing
+if a cstring returned by a function is &null;.
+	</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="with-cast-pointer">
+      <refnamediv>
+	<refname>with-cast-pointer</refname>
+	<refpurpose>Wraps a body of code with a pointer cast to a new type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>with-cast-pointer</function> (<replaceable>binding-name ptr type) &amp; body body</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>binding-name</parameter></term>
+	    <listitem>
+	      <para>A symbol which will be bound to the casted object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the object being pointed to.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the object where the pointer points.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+  Executes BODY with POINTER cast to be a pointer to type TYPE.
+  BINDING-NAME is will be bound to this value during the execution of
+  BODY.
+
+  This is a no-op in AllegroCL but will wrap BODY in a LET form if
+  BINDING-NAME is provided.
+
+  This macro is meant to be used in conjunction with DEREF-POINTER or
+  DEREF-ARRAY. In Allegro CL the "cast" will actually take place in
+  DEREF-POINTER or DEREF-ARRAY.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+<screen>
+(with-foreign-object (size :int)
+   ;; FOO is a foreign function returning a :POINTER-VOID
+   (let ((memory (foo size)))
+      (when (mumble)
+         ;; at this point we know for some reason that MEMORY points
+         ;; to an array of unsigned bytes
+         (with-cast-pointer (memory :unsigned-byte)
+           (dotimes (i (deref-pointer size :int))
+            (do-something-with
+              (deref-array memory '(:array :unsigned-byte) i)))))))
+</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="def-foreign-var">
+      <refnamediv>
+	<refname>def-foreign-var</refname>
+	<refpurpose>
+Defines a symbol macro to access a variable in foreign code
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-foreign-var</function> <replaceable>name type module</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>     
+A string or list specificying the symbol macro's name. If it is a
+     string, that names the foreign variable. A Lisp name is created
+     by translating #\_ to #\- and by converting to upper-case in
+     case-insensitive Lisp implementations. If it is a list, the first
+     item is a string specifying the foreign variable name and the
+     second it is a symbol stating the Lisp name.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the foreign variable.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>module</returnvalue></term>
+	    <listitem>
+	      <para>
+     A string specifying the module (or library) the foreign variable
+     resides in. (Required by Lispworks)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+Defines a symbol macro which can be used to access (get and set) the
+value of a variable in foreign code.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<refsect2>
+	<title>C code</title>
+<screen>
+  int baz = 3;
+
+  typedef struct {
+    int x;
+    double y;
+  } foo_struct;
+
+  foo_struct the_struct = { 42, 3.2 };
+
+  int foo () {
+    return baz;
+  }
+</screen>
+</refsect2>
+<refsect2>
+<title>Lisp code</title>
+<screen>
+  (uffi:def-struct foo-struct
+    (x :int)
+    (y :double))
+
+  (uffi:def-function ("foo" foo)
+      ()
+    :returning :int
+    :module "foo")
+
+  (uffi:def-foreign-var ("baz" *baz*) :int "foo")
+  (uffi:def-foreign-var ("the_struct" *the-struct*) foo-struct "foo")
+
+
+*baz*
+  => 3
+
+(incf *baz*)
+  => 4
+
+(foo)
+  => 4
+</screen>
+</refsect2>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_primitive.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,279 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="primitives">
+  <title>Primitive Types</title>
+  <partintro>
+    <title>Overview</title>
+    <para>
+      Primitive types have a single value, these include
+      characters, numbers, and pointers. They are all symbols in
+      the keyword package.
+    </para>
+    <itemizedlist>
+      <listitem>
+	<para><constant>:char</constant> - Signed 8-bits. A
+	  dereferenced :char pointer returns an character.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-char</constant> - Unsigned 8-bits. A dereferenced :unsigned-char
+	  pointer returns an character.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:byte</constant> - Signed 8-bits. A
+	  dereferenced :byte pointer returns an integer.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-byte</constant> - Unsigned 8-bits. A
+	  dereferenced :unsigned-byte pointer returns an integer.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:short</constant> - Signed 16-bits.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-short</constant> - Unsigned 16-bits.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:int</constant> - Signed 32-bits.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-int</constant> - Unsigned 32-bits.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:long</constant> - Signed 32 or 64 bits, depending upon the platform.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-long</constant> - Unsigned 32 or 64 bits, depending upon the platform.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:float</constant> - 32-bit floating point.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:double</constant> - 64-bit floating point.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:cstring</constant> - 
+	  A &null; terminated string used for passing and returning characters strings with a &c; function.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:void</constant> - 
+	  The absence of a value. Used to indicate that a function does not return a value.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:pointer-void</constant> - Points to a generic object.</para>
+      </listitem>
+      <listitem>
+	<para><constant>*</constant> - Used to declare a pointer to an object</para>
+      </listitem>
+    </itemizedlist>
+  </partintro>
+  
+  <refentry id="def-constant">
+    <refnamediv>
+      <refname>def-constant</refname>
+      <refpurpose>Binds a symbol to a constant. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-constant</function> <replaceable>name value &amp;key export</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol that will be bound to the value.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>value</parameter></term>
+	  <listitem>
+	    <para>An evaluated form that is bound the the name.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>export</parameter></term>
+	  <listitem>
+	    <para>When &t;, the name is exported from the current package. The default is &nil;</para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>This is a thin wrapper around <function>defconstant</function>. It evaluates at
+	compile-time and optionally exports the symbol from the package.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-constant pi2 (* 2 pi))
+(def-constant exported-pi2 (* 2 pi) :export t)
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Creates a new special variable..</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="def-foreign-type">
+    <refnamediv>
+      <refname>def-foreign-type</refname>
+      <refpurpose>Defines a new foreign type. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsect1>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-foreign-type</function> <replaceable>name type</replaceable>
+      </synopsis>
+    </refsect1>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the new foreign type.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>value</parameter></term>
+	  <listitem>
+	    <para>A form that is not evaluated that defines the new
+	      foreign type.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>Defines a new foreign type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-foreign-type my-generic-pointer :pointer-void)
+(def-foreign-type a-double-float :double-float)
+(def-foreign-type char-ptr (* :char))
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Defines a new foreign type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="null-char-p">
+    <refnamediv>
+      <refname>null-char-p</refname>
+      <refpurpose>Tests a character for &null; value.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsect1>
+      <title>Syntax</title>
+      <synopsis>
+	<function>null-char-p</function> <replaceable>char</replaceable> => <returnvalue>is-null</returnvalue>
+      </synopsis>
+    </refsect1>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>char</parameter></term>
+	  <listitem>
+	    <para>A character or integer.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>is-null</parameter></term>
+	  <listitem>
+	    <para>A boolean flag indicating if char is a &null; value.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	A predicate testing if a character or integer is &null;. This
+	abstracts the difference in implementations where some return a 
+	<computeroutput>character</computeroutput>
+	and some return a 
+	<computeroutput>integer</computeroutput>
+	whence dereferencing a 
+	<computeroutput>C</computeroutput>
+	character pointer.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-array-pointer ca :unsigned-char)
+(let ((fs (convert-to-foreign-string "ab")))
+      (values (null-char-p (deref-array fs 'ca 0))
+      (null-char-p (deref-array fs 'ca 2))))
+=> &nil;
+   &t;
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/ref_string.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,514 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="strings">
+  <title>Strings</title>
+  <partintro>
+    <title>Overview</title>
+    <para>
+      &uffi; has functions to two types of <varname>C</varname>-compatible
+      strings: <emphasis>cstring</emphasis> and <emphasis>foreign</emphasis>
+      strings.  cstrings are used <emphasis>only</emphasis> as parameters to
+      and from functions. In some implementations a cstring is not a foreign
+      type but rather the Lisp string itself. On other platforms a cstring
+      is a newly allocated foreign vector for storing characters. The
+      following is an example of using cstrings to both send and return a
+      value.
+    </para>
+    
+    <screen>
+(uffi:def-function ("getenv" c-getenv) 
+   ((name :cstring))
+   :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+    </screen>
+
+    <para>
+      In contrast, foreign strings are always a foreign vector of
+      characters which have memory allocated. Thus, if you need to
+      allocate memory to hold the return value of a string, you must
+      use a foreign string and not a cstring.  The following is an
+      example of using a foreign string for a return value.
+    </para>
+
+    <screen>
+(uffi:def-function ("gethostname" c-gethostname)
+    ((name (* :unsigned-char))
+     (len :int))
+  :returning :int)
+
+(defun gethostname ()
+  "Returns the hostname"
+  (let* ((name (uffi:allocate-foreign-string 256))
+         (result-code (c-gethostname name 256))
+         (hostname (when (zerop result-code)
+                     (uffi:convert-from-foreign-string name))))
+    ;; UFFI does not yet provide a universal way to free
+    ;; memory allocated by C's malloc. At this point, a program
+    ;; needs to call C's free function to free such memory.
+    (unless (zerop result-code)
+      (error "gethostname() failed."))))
+    </screen>
+
+    <para>
+      Foreign functions that return pointers to freshly allocated
+      strings should in general not return cstrings, but foreign
+      strings. (There is no portable way to release such cstrings from
+      Lisp.) The following is an example of handling such a function.
+    </para>
+
+    <screen>
+(uffi:def-function ("readline" c-readline)
+    ((prompt :cstring))
+  :returning (* :char))
+
+(defun readline (prompt)
+  "Reads a string from console with line-editing."
+  (with-cstring (c-prompt prompt)
+      (let* ((c-str (c-readline c-prompt))
+             (str (convert-from-foreign-string c-str)))
+        (uffi:free-foreign-object c-str)
+        str)))
+    </screen>
+    
+  </partintro>
+  
+    <refentry id="convert-from-cstring">
+      <refnamediv>
+	<refname>convert-from-cstring</refname>
+	<refpurpose>Converts a cstring to a Lisp string.</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>convert-from-cstring</function>
+	  <replaceable>cstring</replaceable> 
+	  => 
+	  <returnvalue>string</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>cstring</parameter></term>
+	    <listitem>
+	      <para>A cstring.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>string</returnvalue></term>
+	    <listitem>
+	      <para>A Lisp string.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Converts a Lisp string to a <constant>cstring</constant>. This is
+	  most often used when processing the results of a foreign function
+	  that returns a cstring.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-to-cstring">
+    <refnamediv>
+      <refname>convert-to-cstring</refname>
+      <refpurpose>Converts a Lisp string to a cstring.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-to-cstring</function> 
+	<replaceable>string</replaceable>
+	=>
+	<returnvalue>cstring</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>cstring</returnvalue></term>
+	  <listitem>
+	    <para>A cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Converts a Lisp string to a <varname>cstring</varname>. The
+	<varname>cstring</varname> should be freed with
+	<function>free-cstring</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>On some implementations, this function allocates memory.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="free-cstring">
+    <refnamediv>
+      <refname>free-cstring</refname>
+      <refpurpose>Free memory used by cstring.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>free-cstring</function> <replaceable>cstring</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>cstring</parameter></term>
+	  <listitem>
+	    <para>A cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Frees any memory possibly allocated by
+	<function>convert-to-cstring</function>. On some implementions, a cstring is just the Lisp string itself.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="with-cstring">
+    <refnamediv>
+      <refname>with-cstring</refname>
+      <refpurpose>Binds a newly created cstring.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>with-cstring</function>
+	<replaceable>(cstring string) {body}</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>cstring</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the cstring to be created.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string that will be translated to a cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>body</parameter></term>
+	  <listitem>
+	    <para>The body of where the cstring will be bound.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Binds a symbol to a cstring created from conversion of a
+	string. Automatically frees the <varname>cstring</varname>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <para>
+	<screen>
+(def-function ("getenv" c-getenv) 
+   ((name :cstring))
+   :returning :cstring)
+
+(defun getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (with-cstring (key-cstring key)
+    (convert-from-cstring (c-getenv key-cstring))))
+	</screen>
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-from-foreign-string">
+    <refnamediv>
+      <refname>convert-from-foreign-string</refname>
+      <refpurpose>Converts a foreign string into a Lisp string.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-from-foreign-string</function>
+	<replaceable>foreign-string &amp;key length null-terminated-p</replaceable>
+	=>
+	<returnvalue>string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>foreign-string</parameter></term>
+	  <listitem>
+	    <para>A foreign string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>length</parameter></term>
+	  <listitem>
+	    <para>The length of the foreign string to convert. The
+	    default is the length of the string until a &null;
+	    character is reached.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>null-terminated-p</parameter></term>
+	  <listitem>
+	    <para>A boolean flag with a default value of &t; When true,
+	    the string is converted until the first &null; character is reached.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>string</returnvalue></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Returns a Lisp string from a foreign string. 
+	Can translated ASCII and binary strings.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-to-foreign-string">
+    <refnamediv>
+      <refname>convert-to-foreign-string</refname>
+      <refpurpose>Converts a Lisp string to a foreign string.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-to-foreign-string</function>
+	<replaceable>string</replaceable> =>
+	<returnvalue>foreign-string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>foreign-string</returnvalue></term>
+	  <listitem>
+	    <para>A foreign string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Converts a Lisp string to a foreign string. Memory should be
+	freed with <function>free-foreign-object</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="allocate-foreign-string">
+    <refnamediv>
+      <refname>allocate-foreign-string</refname>
+      <refpurpose>Allocates space for a foreign string.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>allocate-foreign-string</function> <replaceable>size
+	&amp;key unsigned</replaceable> =>
+	<returnvalue>foreign-string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>size</parameter></term>
+	  <listitem>
+	    <para>The size of the space to be allocated in bytes.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>unsigned</parameter></term>
+	  <listitem>
+	    <para>A boolean flag with a default value of &t;. When true,
+	    marks the pointer as an <constant>:unsigned-char</constant>.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>foreign-string</returnvalue></term>
+	  <listitem>
+	    <para>A foreign string which has undefined contents.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Allocates space for a foreign string. Memory should
+	be freed with <function>free-foreign-object</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/schemas.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0">
+  <uri resource="appendix.xml" typeId="DocBook"/>
+  <uri resource="bookinfo.xml" typeId="DocBook"/>
+  <uri resource="glossary.xml" typeId="DocBook"/>
+  <uri resource="intro.xml" typeId="DocBook"/>
+  <uri resource="notes.xml" typeId="DocBook"/>
+  <uri resource="preface.xml" typeId="DocBook"/>
+  <uri resource="ref_aggregate.xml" typeId="DocBook"/>
+  <uri resource="ref_declare.xml" typeId="DocBook"/>
+  <uri resource="ref_func_libr.xml" typeId="DocBook"/>
+  <uri resource="ref_object.xml" typeId="DocBook"/>
+  <uri resource="ref_primitive.xml" typeId="DocBook"/>
+  <uri resource="ref_string.xml" typeId="DocBook"/>
+  <uri resource="uffi.xml" typeId="DocBook"/>
+</locatingRules>

Added: branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/uffi.pdf	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,2920 @@
+%PDF-1.3
+%????
+4 0 obj
+<< /Type /Info
+/Producer (FOP 0.20.5) >>
+endobj
+5 0 obj
+<< /Length 201 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GaqdX]aDVA&-UqjSmom=E4u;+CBYq42W:aU`jc=(4<^HFDa4C2;[pruRj?RM"`9CC5\c!@$)nLL3h\g!;4sXMmfN\;Ob/;ZJ4jmbWdP1T8;@d21LPNCB?%>c^1qP2i7r8X.ie[\P0lY%HhV`UBe#dQ"_J#\3Ui0X8G0l\r9<eU3G"mDiM+oL(Zu_Jh4NONnHDEn21t~>
+endstream
+endobj
+6 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 5 0 R
+>>
+endobj
+7 0 obj
+<< /Length 965 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0Bhf%4&&:WfGn0=3URfk)AmA]JBeZIYgNc('34da.jX2/DV"(QiZ*"qb;,h;`f<N>tfIG`k/p0G1qp<Fufq#h?fSbG72omGiR59K]PLHRI$A*j)+\jSd[pQN_l$2T at Qn#b(.i,ioD6TcF1%@9.7B8VP!SY/8&)W>ZUq5AdCn<=r\6KFJq+B'#DKK+uASe#Y^7EH.-48iCMeot"J0k2]6$(m:faarMNY-s4#$fda!K$\]in at W.:rsbO`"bFihimpH/0d]2W`'Y)hQ6WChV at 0:hFQ?-t9M!XGE<jPSU&[\le9"j at jH4&u-,-),JWsl?$'mU['``%a2hh>:B%rZ/K3PN*)V[[7-2Gd7P&&<R`>k.$Y2)-;<1#`(S\[k+:@&^f3gar)'V?+p3L_Vh9Ibga1?J*ZTNf3FWD&0q'?4/^OYR*$")_Ui#L7AHEUN,P]`Sqe^t.7$+>jT3DYW-\aR\nsG_kCnO9lShmE-OHGSHnO2l?:8eeTA)!*))0J;PpD3Ah65Y)fM^`@U1u;-cV-RmDqCj;RF/XPm5 at 2]Jb8-`#:9=8*YAh/K\#:e1Sh`L88OX6\FPZ_XDDVqi?;`(J$-AOdp;p<$-p'P;;5fCdZqc--*R.SO(,e0->AAR2DkCd5 at +JbD*JbOS4d<'MfB5,fRDq<msIJV,<4,0>`W2EC,.o at sm$[U4k-2s#:5$5):NjsEfh6S$m&l'MeN]+MErK_%<=R0":5hUopj[22Kl;R+H#[9k%Q\PY1p9<'&f7 at i*$o%1]nO`Y,,r2u`B_t at aheY@Sq*.LdNo<&"a/-F<XB5`'iUpaRmBYJPMb0?u`h%HtSEGsq#=u5\Ep:Z(/RAi[58[,U#1+a+M:=(;>jXAJ/NGa'N3o(jZFhcV4>eptt<K=(:#eQ2/rOD(),k%VDhplYNSL1TXiaFr=`#I^O:+d'4822siIHb$2T,s!u*d41R#F\(fhu~>
+endstream
+endobj
+8 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 7 0 R
+>>
+endobj
+9 0 obj
+<< /Length 81 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garg^iGoCd.c`?]8EV`b1=.gRYV7c]1UaMe0JP941GUmh0[MUU-q[K1isOjf_GG&\U1]Eh,lhpD'$^~>
+endstream
+endobj
+10 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 9 0 R
+>>
+endobj
+11 0 obj
+<< /Length 2067 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gb"/l?#S1_'Sc)J.t"a>Kp)+Vq!/R8<as$#lk6g2m=fO,_+S6Ma%fJ,om"K?N84n."\MJbW`&L8[9["ZH[O,/f-a at kUL13m8"p<L^$0q*H]&L+r8rcZ&Y8]'7$:-c\2R]=s'/7H[nC`*NG0)$P(7N?U7Csa?Bmr2MRpCkrq3/'2hql*i\sAANk at G'U$@UkM'mc)*qc?Do/'CdA\S#-(R#%**s;Xr^7ArS- at pBGbtV<O'oM!a+,Ym2]\W0^;9O!gam-Mi<,;oY;dTb8"?K*WM27$3jE:O^>Qp3;[(4CMY00H#1/WGaZNbtG6]N-pY`Bc"dd6p!QCD?\p*V8A5bKp+irL:\qZ-,#ZX0!((/"V=&nJCVMNoUT<#$QVo*7aZ;dU(A1gE=d[MRFl;<<_1fn5%k%1!+563mltaW<4K%j<U76>gl761#=.Lk%_mVW4tZUsj>-9:=DB:apP&fVqXd"9RCbfPUX`3=LkNWSY5BnYIcQ10q$Q at U\0lZ`IBYUQ,P0L-eAfbZWC"8[9.WImqTHqUJb[q)lt5Q-PN$K?f<;V\Pca#-mjO4^Kb[6C(^!0<kWa!Y'sGCH/VS[-)_Br_Uc3Q/2h-&eJ_qFBm(aFba9$nQOh0REfRQEqUUekjI_RCX^'[\?8IRg4lp_6!q;':Lpk]rO5m%;&pFUC!lHu4O,]ZBr_KZm2g?[+'EJE7k`G9^</\6Q:S4%RBWl$=1pi4^:o&n5+<8J,j<J:GZr-)XLfV%JEXLNWO;D(ag.qdTBdejS)WklJ0GL+IFf"*mTTq7)H*/$m)SRoaHig\42*_+4Ttt7OCSD`i%F)<Iigpf at Qpr5f",f.EPDR+*]TS7&NXtD*d9.mh;mUmCf9.Ohf`%NVG10DAI\k>aiQr(aI,`k../Ap=]9auBq`*SE6s/$B0djI`9n0J7_K?eDu5s7\q4pT!>&p`A42uu73,M-;6a7Va4\((Nn6nL\?1BKk=+N!3T"-8o:T%TGK^!+MhMk'[!%]4N2*!S!Y(NUkhQnl39.]R?5/loOu9fR+OKqJ#nGH**%:+VLT6XZm8ui&!.c0kRIK.CMK<5iEskj+X(>Fp\*7oXoJ+Fd:EBW?h*L2Y/T[O(b'[LW74i&VYHB"&EZlP:W$c>h4-1b;0==TP9Q)tlB$n`H*s?oBA/'E!dVBR;,om04SVEDQKB1Np%K_4L+VqTTH$VWVF#Vtjk$.*>Zmc9&ra_b at JTFUGp9g/uf at YSJ2Xa?_d>nkd-bfcq#W+Y!TuHC at ADI"de)dmZdTZ"._<#RM&PnLCJ3[J84*oi8CN[\!=)T^F6ZW:jK7Q9P8>U3F*M_1jpE?`t*NE(W0pHGSJ^0I<9&2*Y7]ae8b!1c'H15blpG$4a"M.BK\ijZL[iR?SSK=]8R;@Z:Eg6h>jZ5XL:f#PX6Q&V>Xj2(09bsB!gd*(0=6\Q.25<dm7dm(M2H$oCRB'\/B)H6LSeVh#HR[A0)5CX"<2-u$/m9:DnC1M>!hDCjQ+GdV1pCl#<Vg$\ojei-,LZqm8eC3.\oge>UHIfP;q`g*WHh*^]#mi%!sA[R;<DcB'4obdoV`e!<n/rY(-B2oC6$(Ba;kE[-35m2q2*OmDl^t-Wr#1>VNZNq_bdSl(e"aTc4]!2\d&AM0F0Kt17CD2;<b!;W,HNPh1pqql.fCQ2=S<A+;!a3dDkPs+c5lGAS&+]Z6%>'\_>TnQ`:J01-#X4r?^]G/sDYB8?sk[JqR>A"?N5qh>Lr[ApneD-FArt$)Vs!5\E>/"Lq[f,Y2f)WUE1S%IlkP+OD!f#m'J&2W:pQU>@KIgPCCQH-epS<^5BqPpS&&Q+r+>$.,4IJ\Ip8GNY@?,6Ok18eX#c!e$gFh0iTrXS_9WpKJiF2apd1APq-iI^/Z1Ik+HclS"7Y(eY5<h5beVj"uRAbBRSTX$hdtHj5.N?8BBAq]ukjc<?OuCnEI9okjLolQ8,C#]u]mFO/!`Xd*Ul(G9Q&=IDFI+/I>U9B*GFkl6e6/OjU9)uII)`JLLI6..1Nr+9Ff]_Ucpd?Eh^NC,m<T at n64IbNS@,9D+r3,*hWq<(uZY<N%3Yd+!~>
+endstream
+endobj
+12 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 11 0 R
+/Annots 13 0 R
+>>
+endobj
+13 0 obj
+[
+14 0 R
+16 0 R
+18 0 R
+20 0 R
+22 0 R
+24 0 R
+26 0 R
+28 0 R
+30 0 R
+32 0 R
+34 0 R
+36 0 R
+38 0 R
+40 0 R
+42 0 R
+44 0 R
+46 0 R
+48 0 R
+50 0 R
+52 0 R
+54 0 R
+56 0 R
+58 0 R
+60 0 R
+62 0 R
+64 0 R
+66 0 R
+68 0 R
+70 0 R
+72 0 R
+74 0 R
+76 0 R
+78 0 R
+80 0 R
+82 0 R
+84 0 R
+86 0 R
+88 0 R
+90 0 R
+92 0 R
+94 0 R
+96 0 R
+98 0 R
+100 0 R
+102 0 R
+104 0 R
+106 0 R
+108 0 R
+110 0 R
+112 0 R
+114 0 R
+116 0 R
+118 0 R
+120 0 R
+122 0 R
+124 0 R
+126 0 R
+]
+endobj
+14 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 704.89 149.98 694.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 15 0 R
+/H /I
+>>
+endobj
+16 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 693.89 179.44 683.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 17 0 R
+/H /I
+>>
+endobj
+18 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 682.89 176.22 672.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 19 0 R
+/H /I
+>>
+endobj
+20 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 671.89 192.88 661.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 21 0 R
+/H /I
+>>
+endobj
+22 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 660.89 254.83 650.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 23 0 R
+/H /I
+>>
+endobj
+24 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 649.89 172.33 639.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 25 0 R
+/H /I
+>>
+endobj
+26 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 638.89 207.43 628.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 27 0 R
+/H /I
+>>
+endobj
+28 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 627.89 204.67 617.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 29 0 R
+/H /I
+>>
+endobj
+30 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 616.89 210.83 606.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 31 0 R
+/H /I
+>>
+endobj
+32 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 605.89 268.43 595.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 33 0 R
+/H /I
+>>
+endobj
+34 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 594.89 211.33 584.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 35 0 R
+/H /I
+>>
+endobj
+36 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 583.89 210.22 573.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 37 0 R
+/H /I
+>>
+endobj
+38 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 572.89 203.56 562.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 39 0 R
+/H /I
+>>
+endobj
+40 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 561.89 314.52 551.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 41 0 R
+/H /I
+>>
+endobj
+42 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 550.89 263.73 540.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 43 0 R
+/H /I
+>>
+endobj
+44 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 539.89 216.88 529.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 45 0 R
+/H /I
+>>
+endobj
+46 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 528.89 312.72 518.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 47 0 R
+/H /I
+>>
+endobj
+48 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 517.89 178.87 507.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 49 0 R
+/H /I
+>>
+endobj
+50 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 506.89 177.32 496.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 51 0 R
+/H /I
+>>
+endobj
+52 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 495.89 195.83 485.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 53 0 R
+/H /I
+>>
+endobj
+54 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 484.89 193.43 474.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 55 0 R
+/H /I
+>>
+endobj
+56 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 473.89 209.53 463.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 57 0 R
+/H /I
+>>
+endobj
+58 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 462.89 188.43 452.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 59 0 R
+/H /I
+>>
+endobj
+60 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 451.89 203.58 441.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 61 0 R
+/H /I
+>>
+endobj
+62 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 440.89 182.32 430.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 63 0 R
+/H /I
+>>
+endobj
+64 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 429.89 182.32 419.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 65 0 R
+/H /I
+>>
+endobj
+66 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 418.89 198.99 408.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 67 0 R
+/H /I
+>>
+endobj
+68 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 407.89 205.66 397.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 69 0 R
+/H /I
+>>
+endobj
+70 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 396.89 212.3 386.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 71 0 R
+/H /I
+>>
+endobj
+72 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 385.89 188.41 375.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 73 0 R
+/H /I
+>>
+endobj
+74 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 374.89 182.88 364.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 75 0 R
+/H /I
+>>
+endobj
+76 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 363.89 166.1 353.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 77 0 R
+/H /I
+>>
+endobj
+78 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 352.89 235.08 342.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 79 0 R
+/H /I
+>>
+endobj
+80 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 341.89 219.52 331.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 81 0 R
+/H /I
+>>
+endobj
+82 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 330.89 221.76 320.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 83 0 R
+/H /I
+>>
+endobj
+84 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 319.89 223.97 309.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 85 0 R
+/H /I
+>>
+endobj
+86 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 308.89 205.65 298.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 87 0 R
+/H /I
+>>
+endobj
+88 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 297.89 196.2 287.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 89 0 R
+/H /I
+>>
+endobj
+90 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 286.89 230.61 276.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 91 0 R
+/H /I
+>>
+endobj
+92 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 275.89 221.74 265.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 93 0 R
+/H /I
+>>
+endobj
+94 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 264.89 216.21 254.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 95 0 R
+/H /I
+>>
+endobj
+96 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 253.89 199.55 243.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 97 0 R
+/H /I
+>>
+endobj
+98 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 242.89 233.05 232.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 99 0 R
+/H /I
+>>
+endobj
+100 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 231.89 212.32 221.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 101 0 R
+/H /I
+>>
+endobj
+102 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 220.89 205.08 210.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 103 0 R
+/H /I
+>>
+endobj
+104 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 209.89 160.56 199.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 105 0 R
+/H /I
+>>
+endobj
+106 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 198.89 227.31 188.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 107 0 R
+/H /I
+>>
+endobj
+108 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 187.89 215.65 177.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 109 0 R
+/H /I
+>>
+endobj
+110 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 176.89 190.09 166.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 111 0 R
+/H /I
+>>
+endobj
+112 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 165.89 192.33 155.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 113 0 R
+/H /I
+>>
+endobj
+114 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 154.89 255.08 144.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 115 0 R
+/H /I
+>>
+endobj
+116 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 143.89 243.42 133.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 117 0 R
+/H /I
+>>
+endobj
+118 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 132.89 233.42 122.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 119 0 R
+/H /I
+>>
+endobj
+120 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 121.89 223.88 111.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 121 0 R
+/H /I
+>>
+endobj
+122 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 110.89 193.43 100.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 123 0 R
+/H /I
+>>
+endobj
+124 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 99.89 223.42 89.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 125 0 R
+/H /I
+>>
+endobj
+126 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 88.89 222.31 78.89 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 127 0 R
+/H /I
+>>
+endobj
+128 0 obj
+<< /Length 395 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gb"/g:J8Sj&B4,8.H[!;h!T(Rn'RjY'ed^U&eDfr8g#IJ<5ieE/h%+X._W7<-'o^;H'q/FO3Gm$RcOT!_$"S2#cnUAi\(Y'Kqa_='4J\j^ghDA;n-3Ze<=ImDi2+Y2HALbWm[RZ)M\-O,"4O';A9L0\5(uhm*1b;S;.4ZF at qXqp7nVA@^YTnj`8S:;5H.Io"463c^1Cpr/`T^G6a\YMhr/4*9loWi+2[ZDg`I%c.Zs#<6)Ef.8ls?$B/Bu@:fk*7G[Zcd=$=<`l5327uA#Fs3`fLbVj[J/UAEI6&+;P*,!t*-Q-Mg!:e=)K+d"6\_Xm10Y`88*uV93LMnh<@Zg%kmTo'<f0$Ze4E4N:<@bQ9W:W9'EB-cK!`M<P8BfU<j*c7+(IIR::&~>
+endstream
+endobj
+129 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 128 0 R
+/Annots 130 0 R
+>>
+endobj
+130 0 obj
+[
+131 0 R
+133 0 R
+135 0 R
+137 0 R
+]
+endobj
+131 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 768.889 177.22 758.889 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 132 0 R
+/H /I
+>>
+endobj
+133 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 757.889 210.93 747.889 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 134 0 R
+/H /I
+>>
+endobj
+135 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 746.889 177.33 736.889 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 136 0 R
+/H /I
+>>
+endobj
+137 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 735.889 155.55 725.889 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 138 0 R
+/H /I
+>>
+endobj
+139 0 obj
+<< /Length 590 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gasam9lHOU&A at ZcHqY%9q?(6;7d<Uj.@'*Gb/%M'ee/?)Rn\B]c,.IB9fEXs at NI=Djup^HeCh;o"XJk78O9I6"PO7dj=Uj#JI$3u5t25YT>:'Sdj12lj?7_goqSQu!$dijlE3"3/-*^N6q+X%eOOKE_2c)c,smE<43&Nmfe5`:gs5bX5R2"l8\`E$^`J]Pfn_P;7":!n-&%nfP\O%`C5RMj:e"hiP$$&6rVjhH#:O4=B1WPkS(?j%8l*IH:id>GPuA*Odr9IWR8dpqkq&ag2Ic5c&G8D][<u0cEs<$8kn#t\o<!RZVq^(K2]X+[6X7QX4u&!m$7d$]5i6HDFPZG`q_fEi=<@]9Xh_Mc+"3!>DM=$cX<%FcC'^1pfD/f4 at 2%$FdMVr:aUa@`.cT!W\\E5hk0!;W<8BGEo,Q1.k4lk_>k,f-W!)s?lb[Li(e<7$oH0,NbJj\6fe?_+`]>?_k0oUVEkJP(Vm2F5g"T0JcA]'VWq#P1U\?)5X+_l!\pVQ at H!CE[r9ne%Hi:-RBM68d/LuppI3Y6_"<!RP:ta1]Th^dZpEBO"q7aQXKfnOK(!tdGKB6>;"b2b"9)~>
+endstream
+endobj
+140 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 139 0 R
+>>
+endobj
+141 0 obj
+<< /Length 2030 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm<968iG&AJ$Cn.oY+AdH-(>HPi7FI^8ibL=Zl4[:8@@8%7a84n#SI?t"+/7m7Mg5IZ>Ks:@G]tj=+in]T,\\9*)T!c]o*,BU]/-gXBMHno at +tp2'0=4bAl]96NQ<"HYDlkNKMX2U3P0gccp6bh]2H"(&g2Kp'[JmO6^T'(046knf-h8;8::s->^M at C,C,YDc/E4HpclV1iN%bHE^8j/o[_2#>KUoVGa`8_2R52\6Zog]d`p-Oo262LB_Ipp!IV4f53=e&-+(%:qL63J\j"1X[.Q*h59crU(+_nHm6-E0m!H:342jL,?YP>7MfT)4+<CZCXGmW?L.98X!@]*(qfJ#u-d&#C^Pb=[R]=d6JAZ/(cn)[P8b>#&-.pa]K'd-WqLfa)RUlr(<4s'kM`)oQdJoV=OfgsMVg%d<EJaF*kRih>t5'?$9U$Z#S,=V>F.I+GE'n8kl6W!BbA'J%bL<bK at _R.j=\M6ch1Q>sV1W:<f9_"@lY,:"YGr"T`b^/@ahtATl!7p7*:F`HR at 8Me]7Gb8sOFV`!1A'IjOs1BP0-FaQ2aT:65n\+i;Q"ui\NQtcA/HC_R*L$1pHgqbhY=<nQ]QjWhBLbt8oR5JQF()>dpgaG6/iagNOG,85Zu"5dYtj at Wi6*]@=`)!+gn9g_\gEk]eCt][RFXUanG3W'd:IZ&<MP*j&M5:A!%n\QE$V**)i+te;dh12TfEB4tA*%T!effUBFZtZ<mk at I7-WM&SK62nKZeFKCPNB"XD)uW-Y8k<.Ccn!c,Abf/7=PI5I&bc?7 at YJi?J[]k5N?0dL7S,#]9]9q=98-2dqdZ2GsC4prd.JX)!2#>(t+Pk_NK!ut0j!AlqV5gq2LeG#pC2#G(XXeC"2#)O-$/Gfa\rnGf,X1g`J)Ns7L..e[9>LKf0qGN4/9nanCqEb->caenF?A[C?TX:H7<>hQg\md,7H&=Sp&t2!&W*a>@/p32NXq1. at HeqFMS1$a6UWe'UnNp2)Siufb;MVA.7#NC]M<a@/cl@\Cb]>QF"E*:\[l!;:4:h(?F@[fpBg.<,NW32sL8&N0G$p;o(9/]2p6P-/G]47]L.k$j(A"4W9\IjN:kM,a at 5Qe841,Hg2t`)(T$?NQ at Dmpm(-8#'EK;Dh,AuRq&N$_se?_a8#G1<.rO@`:\<;6;3_gdVX<->%M)_\G"_e2^E/1N6S5!V5bTd8el3Pe*+S37e-LkaS9GB]c3mi0-iD8?92ZQgN6M5Cs0Gs,A[g)%;L*#DXjRW%]bpfB:q>BaMQBs0qmMj:#p&06TnEjUlW-\P>N?bLj>ruB:f_#pH`bLm"%-r+DB&\@7J%_=(!PUp52"'YN6-)P)_Z(\rs"MM8>Z%@A00_U-#E_"C::,p\4(tG71N.iNVP+7:%.sF4N#Ya-POP-/SiY5Vk7/J7b(eda3KHQakC'=3q.ZoTnc!S`kmNFom_j[u]B(:\2\$'Xf;q9UUTX!4TcJ:CZtM7#VGu08msT(iLSLWi2*NEXEAZBXb2.sV61A'9N\_*IkcWSldIbW\fCQ,_Kf_m>,lMsa+7De=-IVRTB7!/XpRQcZ(V%r^3BNb%`!OY]Sf>=_&r/c*"QMWMII[!B5+N^f.fUq-?DZe*mPR>7U+>YZ571l0<1]a;QV&h:>q._p<HlLq_C at U/D&X at b=j$"J.aQo#Oat3%NM7uNqZ;'`85GfqL-]+oC1P^&#:G.M07oqsC\/mFBCF&&XBY\F%_QB]_^YgNNf>,I7+LcIs6&I:A+Y<!^HW0r9pl(Fp;%HhBCG"<cjr+u0h[iB>aa/fT^Sct)tc%t*d7B&JIlg,8>0&c=86sF?-Il1;J;u#<<uQq5qT/L2B+udhGT(h[hk)q]]YHh)\VdAgR[E"]Bllq at j;DPE?%`4NL?pqGUT/e&0Stg7`*GN=3%_DE3o_6pPc"X=^9h8G_3n"L!6dmnF5;L`0a+uS#)`.5HHL:;X`"'A&N=No&9cV0$e\aW?'&fafPF"[u9S&l(>l]EG53 at K9Ae+%5`Ye]^>%JB4=X8(WdPS<r~>
+endstream
+endobj
+142 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 141 0 R
+>>
+endobj
+143 0 obj
+<< /Length 996 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GasIg95g=S&AIV:i0[&<QhTO/Wf^2Y;Cg-ngOg<d at KgRWbc^05Y;$OuK^C8CBP-V!q;uC_e&/)M^iF7%>A8)]Xn0B6D"ZsnN]RNA^dWF.=D;XNHMHm=_4u,]KAknM1XCp;gl^o+b0H(!+"R;i9SSJI`EX+N-sk[*q==*fW!"2A>h`2$f.(pp9&l-p6sp<tA6]D'af5SiR%\M")5ceiL'pRn,GK<ZOd[t\-0;3s'=^b/4Qfa;;Z&G)M,9kXjVP!lSUlS5L0cr'[LL>l5r3JjOgM!8(G)oj2('l8rlI]A8HeO'V,NnQ at pB(/L2<jUZu)Hqg0"[Jl(EgYkFaQAQ*PNHqLYm?bUgglGCl)1GtW\D]E<qP)nNo>)lRWT])gt#+CtLd9AfK*kH)S5e!>G",!0,3luu'h,e#hr]AOL*kJpNgm>ZgfaB%KRn<?Kg$Ch-Z:<5idj?fkT&m?Nl2iXEpUJSqC6?jkqc]=0+Dfh*2R?eO0BE[FKarZ3::>\,_pOb\-BpacbM#^D>](6\T^K&02#-E42([YlQg*B8L"W8V4VSL"fJ<;D^5A9e,kuP(/N#"gb.NgnI>?h"VE*Z891C#5?kk[Tu=E:'ngPqNc)mU&Q[Sc%qRJ-6L2Dc9@@4h=nJp^Q>+`MAP>V1e!rE,p^4rH@*,TgGj!Y'FL]9Y"]Q$hpMgI=d$Y;'Ri'X3Sk>LHNTb"D%NE7=$V9s0D7AU5^(XK2,<-`qpEN*\.N9j$-VEno!sYS.f-,o4P[+3rs"5"UFeg#p:If(@dl->.RE6&^ch>Ar_'NP"/hjr8"l+qeqSg9N)V-HeB\&4TYOD[]PUJBZm*hRo%R6I-s*9MaRY*e@#/RBYZ'VXS0Rg#LF[[eeRBJt2Qsf_(ZjD0oO&8^L)c.+,"<o=k3e*o=r at T(-MjI,r8'jf:$F2[V*?4c4hn`Snkr3Ao\?Oc'i";RaK:H"BnC]ZWd*HcAEaqjump5`QX`6&>GP[-JW?rr>IB>Z(~>
+endstream
+endobj
+144 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 143 0 R
+>>
+endobj
+145 0 obj
+<< /Length 2451 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%%99\/>&\d_;i([,"%a=Z72bTDf46=CP4??V*E(P#)LbFl1Xk(6N+<*R)32 at q$WNBWZ!4j,/IKB?)r:%U&i:nHge%dtF&$Bu!n/PO/4=BZelQed9U*+X)Xn2GEO**Y1I!k+Ir$5]Rl=R<men6o>O0QHYH/"5E at LrCMTDA-)q6tGE.nFecZ>cs)'&AX\5lq[KDMNtU]USLqoUY-2\8gN at rGCJHW'k'h>:Emqr:EHL*/?)p6 at N_hIMr$D^Sk`;9PL"J94?s9 at N&SLn]S9u1J/l-7@>p]h`_p,J$R`U%%*Z at Yi_o,\[ZI!q<RX%GVRt*^\BMRC#:Cc=5(HN7DU at Y8E>#u'MK52quqnhN4GA)r`o&W9/]'IY_=GNk*I-G2A[C%2[j2g(\MeK)S8bW,`Bdu;==R[b#gn0rOVmj4cr$"75sh]lAqB^S^0A!VZ#V%H.nd`1523l.EZY<hT=)Qjt at qK]B*lo^-3a6Cp+-Bm*-CLXjki6S#N:eMWS)_,'(>>VcgBsXFD7$F>3pZGnGMe[p6MaKg:'/TA?Y!_CRuO#Z*!YRHqHM2Rj2iYLC^")_:L)#"n,`Q2Ks*c0D!0c?%bHd5JsXI$ANSOckc8rjmZFhc&l1b]SE+\(g,EN at NJd/!eQ9/0F]>Wu+iG,EhapQc<]"C#V"'A2['AJf2>>Ll*VWM%$MaVO*OD=>\/>1B*8o2:"q4XN0c;n+`9r<,>(%:3/Yj"#Ymmk[ELk$96N1eDlAQHU^RNi_LnK_^&gp$.q,=4lX7l0_O8kHm5BY"XHbg-Ylee<So:q%)n>WqK<DZeHS-;&]C-,DqBfj at Sd\P3JkHJbIW>*`JT>aNL$B9UOXN[F<.3Xj!,c5["+feTTJGH.QplkX;hm%d4M&gX,7*/r8s!#KjEE+,l4(2Lf-qD=Z)->gq)T%^)YL/i*.W>_uL5M!pp_s`6 at V1R]aQT]H2%?RoNF;0TAR%cJ6[L!N6>?!\2h:0cnsmo[,!@K<b:o6g/eHMcE"4lQAu%r'=L<W;.OO(CBYH\s`3Tl07BCNDbja/C`ZCjM_oQ?Irb(GM7lr8m)_(`o[[]6fbQf18`E8S[L9`ebM.A,Gh>>F3ca,o:kZkf.5`4QoD<sYgJ3iB8Q6JZiodZGP2S^63nAe?Y6''SYNJVR%Omf*DFo3>I84".an6kkYXl\4Tekepe=DZRQV;?.ac[QeKq*Vr0i-Qd7RBY$44RfJmOt6<9QfgSqVb5/S$aVaHep)0OtH[lg+1VHnW5(4l6WLlp`m?bKk,*eX&4bfXI4"SKl4Q&\\=nq8,(1":aJD<-&$HH)X50,?a`rRi+d<"@/B^V0MCjP/*,t""'#6rOMKZA`g"nMWCBb:ML+.)biM;Q#'l*-ejp__Du^u)PAulJXh*@gF."&1.6TV?hcQ[k5Z+c)o@,iBT;(@)\Q+3>@..`ZXqRH].CJV(Cd7M9+]qN)ISVkNZgg/L9VIHA6NUc27mkX_"X7`-2()+?8QH!+8U0m-dk',,&,,!Aq5k9]$pZ9ZjB*\"nK*;0n'Wp5L^uQ6KZI!ZPI7ZN77eM?6*eG;c?ZE4C4Al3%dt34,`H:3N6UPEhoR at GU#`trD2n3^9l1/fmY at GZ%l9%qna6RTaO"$IM[D["(]*I-j6OjHs9/J+Ou/G at 0.IjZA6j7<7fH<LpD7o at Ylh>:8u*;NE5+Ea+\-3L=^tc,58kWbD<5Ac`d*qXe/siR>`bZ&@;;(&Agi2JE>pK'YOSN at P0WaqB:?&k^<?M1\T:>g4,lT][5()R2WTa13m$BdO\9J'/Z4C'Z*>IZn"]e)F3k&;$?-WalfK%J/\O_gs7iUr;4is6Hk7Q,3)%QYq?(XR_B^XP3IUX#*mqo):9M[jeG<M026HHcuDJ>@oScJXUV!S<tShc!*G-c!RL>BJ#R:$Y/Q,sD]OuudP\3d;Y+MQ/2s/3&:+^ICfNf/c4<'bo64B'0FCr2;kpa4]:G*\ZB+&cqlD/3k`P=X&YAW#_g6Uq=CXar0b7!V-ro>YZ5lDccX_WI&]9P9DVg$H1tOF9fPb#l_"*Vj>j>[6*bt`Z-ed$jOtP.Hqcf+kgcB\hS&pQ"g8iKA%0CemBqt*kNC-FOb'n at eTQ2giCJfYQN8TVCMC"GTJq>+Z]uX[11cDYqfAb0$L<d3:b6E%7Sfsj7%>ep:,[,Gr;8gk/]&FBVaQFp)K-,k"<X1>31gI8Hk25bV1Y\ROH::5K"N=?G,Y6,A\h>uTT=MO4,G^pC$)0=O=QSF/HYmV=c/9sh;bD#KC@["MPsl#N!G&M1GFKu5fgL[#o_Im^Wl06e>>H_T at b4U=[hF#U3cL6<%L8>YoT"*/^_4u7C&!Vq50I;^;Z;'lh&DC::"'pSbfpjN<N%?bDH'_e8r^TU+25UAZp5.'?BEUZ$/L.-EoX=(:*Xt_LOVL83,^0;]*AQsGPf')@U>-U;9VB"?_mb1pb0+Y\X3~>
+endstream
+endobj
+146 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 145 0 R
+>>
+endobj
+147 0 obj
+<< /Length 302 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garo<4&<aJ&:f!)MVCZ+]=)4ioi_Y+"p at g^_ at SS;'.FH2>U9;3%P9+r7(;"<qsFq/g"fdBS8kJIiS]OmSjIrUA4dalRC3m2!M6VYC[p%9!HXn[?Y6U5pkj0RiH1#8I_HtBd9Wd^F]6*$O-c.ncf#&-qnE[gR420ma%5BBMY*\.:Un)TgYu;RFkF0FC^.!4'n9GMp[bY1kqZ;E at W+R&Jk;_g1CXB$OXG0O*i.BmrHLtPR$9@#mMXUmo>`Q\cjW9#qBR3V\%olqEW.%a-L(eVj]Kbq at 6g/QR579;Q[Jn6<c-I~>
+endstream
+endobj
+148 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 147 0 R
+>>
+endobj
+149 0 obj
+<< /Length 468 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarnS9iHZu'YO#fEi_&S#!rq^g8YCU:<+573?GDQ`Jd&9J_'\`%3KG#XhuHsm(Sg7H*bH$H(ZPkE>297Ccm;)cUYp&^1B<b\Nk`Z*/P4Q"aZ`p_(&6'>"_ka/+eRZa1_VkK(?@e_(>^^&<Ag]"RE25/a0<ih9j6(:TS5?nq37dXZ*i at n!\:S$7;_V#9!\[LMGqrRG<gEou@?><)LaWZt!'8b<l3L138s:2bFllpJLO+e^P(4"itNP^YW%"Yf$'%CFJLr595oZV/94">#j_^eeh78XRYOd^2VFU<MaeS*4$[q#<R67](9d16`/DD:0Oe@=@cBXPl<L<a4W`rE"K`6%E9Ao@,)Yq9UFcoEfAUF`]A^;ZEF?VBXpb,0(V?*DQDd3lOaLE7OKLG6%5GN?iB\A>pI3?NFES7g+=G`$u%sGn(F0Vk@,KAqN(3qOp3YY4r&ln*/a_2bh_7pgq:n.~>
+endstream
+endobj
+150 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 149 0 R
+>>
+endobj
+151 0 obj
+<< /Length 820 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GatU29on!^&A at ZcHn/0*l>J&`Z!EHig6F/9?:k_O3,Bk'ck+q%n*;6L*S?HR.k]'(2tQt0_`S'SG;Fu0!pZI%*al>m&;8;`+ at Q;U`<@[+;37O at _l#3=,P2'A*t:gbK$=;u3WfYi*/[UTZiR7N4>)[V!ub*8rA\%[WiYllj!<*#lNln0%saW+RC,7*qjk-pW,U^i]!tQ<dVlXC%\k5_+T,GsoSc-e!o1P&If^40K;+T:Ts at jtZ, at HM(VCu794UUSpf'*F8[1:O3\+uGPQG2'DM6-_/c/b^4]K:@1M[[94osaYQWeV3"M[E"XQ'+e]#qM52SkPmj&G)B\'+ at MEXLQ#/P%6L(ZCI6o-/=VKV_%`VkYM4gbu4DSl3\bRL0'h[<$bec/s6&;%J<?[hf+8F7)js*%kC^r1JP-\q[%f6Z:EZ`diEAan;V,;3C4fUmd[B!>WW!"?ckeB*,3C$MSj`9c"T%PM.g`n$OV;8Bm+2bXr8kh?I8CEK:._We!kDK^!C?N6hqOTpCV+>6piYW27,S:*UfCLW+L>(=r(h3IGVEpXOiVBK8,M\dHbXbHOoi!-n;N_r)u1_]c>mi]O]iEbMCnjYH-5'.6J\%1DQ4qefHTmYXaF&92cTmWpS/6$Q]<=<q\<g2PM#eks!HD.gl5mQJ<]pY%XV^TB59>0R$6Xm*J-iBY\L^n`<\gH0b)m(Ei#WsYD(Ju:_X7:%G]-us4j8CpKWgpSskP1".]j6r=uRXPrChD1H&K:gEgKDM*nc'%^H`%_ at o">VB)BG:uk$m(#d_kte^j5abbp]=!oFX<PJ<8,QG!E#<U+T~>
+endstream
+endobj
+152 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 151 0 R
+>>
+endobj
+153 0 obj
+<< /Length 1246 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau`T?*g"Y&:O;Vd,RhJ<^6`VnWm^SLJF^@-etVq%iBsoK#-QdGPpof/<!W^Lm#3q\T;E%8dCnM]36e8(N&#VTSPS[pF2!*NJ7'F)d3-3N<fhEo3C?R$i?NJU*KO*oVp,sH(1H%/$pUoLBHE@(j_&l-f2L&J"Z!AKkCfmRj."jfTPIUcFc@(r+0"+k(AS.92&qBasP!@>_66Rme<M.^c$LRjaO\Z6OY>P2/Mi(?\#+s>]fm$GgCq"?ofs)U.^%\3Q-'1[(L8VW9fO+h%H'RH8noM.1fULU'&/\eMSUV'GK:,"WU_qcs2UCWXoXR=%r<Ue[Y?>4acFZQ`<fGi=mZsj#tGD2sJj72u-(%3sI%A%h--=KL-_Y/6O&`*O8\h53Mg+"/c'@Qa^&H#/aY&9R4mhrkD,L at b?0P<=5o<2/g+<"L?!3[P>.MV/cHAV)0)7m)nJUhf_:1 at P]!+JW at IE'Nd=[:X?q*PQg7r%<'d9WfsebakZ5J0PLN=8V7^NNhp.<WERaEreup)k;@Cq[@0EM\@]+q1#4\-^RK+]ruXlmZ$&>^$tX4.JI!"J"bf at M\N1KS"B4]C24 at A;0>t0P[:2EifGpp&25ZKh7"Q7C)VOJSd0$CDi2i`S+dA?eS-]e,YCV[a27*#?>1O5sp<b\<l\Z\3&-dD/0bK+F_VZRF&P?@c at j3NZ*GQ;?baI1#3C?2:<98S6#&4^E\nYK$_oWlU(9Y<)a8X$#1`%ETVX at F.[3MRnDR6?,c=jJorQl**ILDmkZKKI(+cc^"^WJlE[iQG3b_dlV/o^HciIKU^T!*(]*4sem)=#FQ9-#4n[-DggnW*>`_&\-90L5Yk]<eq-d1Ba7Zup7MS:7)]Su:ToI1NY,#lNut425RH0_'!#s6K9sNsdn!n+o)B^PS"s)7Mu]O.5#hJ@;VKY0)JT0cEf,e(ipC2\@ab)ujfHqS[]uAR^&/gV[P at K3k_J@DZ:*p\1NbafrY].-o$Oc)Yk3B3+aN)Bq:FH+I,&ktET?_3,H")UXFn_Nf[D28"A=K9#B1JX*F@?k\jg8IV)up(4\D?[<@leAI/rhQEp[:?I+ig]OCpl;gMEKL5jQ>u4e_ojjq^qBTCq4I-AbZ0*F:o*!!@pPgOVAV[AT[PYou`cMuMT$4QFo8ugo;TKq/mX;]_j>@ChWQt[YT;0Z'o#IT-cbAN#rr,3D75==;,W)\bau7"QhF5o4be\C5jVYD@`A[Bchc`(4FOX5Nrrk?/:U0~>
+endstream
+endobj
+154 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 153 0 R
+>>
+endobj
+155 0 obj
+<< /Length 961 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gasaoa_oie&A at rkGUh^IAjoTC`SR+C"]D].M?rUCmX^\g=GXE.EYAD#WQh4ab;+J(cnh1ND`6GJZ]AH"5TF5DptM2=Sn86fqM,'kciMpuOActj1&,h]+Cd86It at Vo>>]njXe:YW",+i*:,$4g2V=tq,"RoG+d6 at F(7:Bp2_0itO`&'IZT"U8a8I`!Vid+"oW26^!1okR0k_Ci->I3YA<<]:$Sf"rT"\SP6!'QaVD1Ka^_48\B:2`3/XTJqI?Dpn'&PjQUQO&1QKI=T.lEm)0^M,WC&RrbIlbLt.4Q)nLOp^O1R)]:nupL/rY"^h,UsAd!nkZ81X9+[@X0,H4)%^2CD^4SXd+$(%lO&hg5DMu<tPbBLkn+s?c2kB8 at HVq0g8TO0+2@MgST6Y(1aos&'GHZ,F#!2':(-W`a7J[`b!p&hPoR6#7(`pf/<(OGnAgts20O%ca-RUdc!,\j,mu+6_5fTZt(q:Q;8fRm>Z&MlP>eAW0a,R!aMbG"mlNdE;t?l3 at VhloiQ)#7I>^ib_e)K-:b!"#tS_c48iGR$UFigL8*f]c*>oTM32+cR:RkW2"S<@7RP+s$P?uVc^L]HS/XdAqI3h>NUQb]SD13OK<Y=bdPqUZ[4&nl.U%h3>8eZe(mIm>ZsKk,V9ND/9(!QrSXSe=V$lBrWbE[;AYh@=YJ&c*aZ,4.V93O,+qIR;C9(?a=Z-X2$aC:E2t)`VD5Gd12*Xlij$?EeS?u#"\D!F75../`]dQWH`X*ju6bQoD<0-!-F]R&KG,p4(5M7]C#j at B4j5b9aRL1!_+scI(.Y(1rTsQ<-7HU:K7g`!=RNT</E3n,^'hm.`Zg6WsD![F4DjL,bRTr]tQm(+n]mC,ddg[>DO("`/9]&VZLPZ6JAO?TErp4"j&Qn:C%b2e0kTV2^Es`mX6*A"Hp2bECpQ_-Sab](ng^"6!iIE]9G)Kuqrs.CNCSL~>
+endstream
+endobj
+156 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 155 0 R
+>>
+endobj
+157 0 obj
+<< /Length 746 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GauHI9okbt&A at ZcHqZ$Kq at c57=`&J`e<R%%]ki"6^grSCUkEPCs1[XM,`@IZ<L$3>q!m4b]GVd!cKDAF?ic)p[]tJ#_8-,>*sR<^"9da]E!E`gG[<MS9J+(6Yl/01*+3;0(f1IQU^@B"TLTncUgc:.$^D^=>@*<olk3W1>3lM,_s(%;M,pMt+G[^8r>?+4bD&:T<nM1#;jmuH?I3B^0#Jn%&Q\=p]KMlQNd(ZZ>]_FPH;&;$iqX=D)^NI&WOHQ"DW!pUCUgN?m<Y_WEaCN\OSN48?PS?;VK>tm<!X=[bY2/^1ckZ$l+&;@['Z]Zg^m:WCh_?Nn88f<TjO]j[a.mQ]/!%O_<U3AqH3'][<"GYH*%^N(N2ZA,70bi<L1NOZ.uC$l[c&qAZ;CQA9;\f&(b43)5c!s1"#(RW(pc`*6TVZZa7jW"9V=Zi4g/X.@&,PcpN7L[XOFn0t"[icHnE].>G?::qQH[:-1hr`B>WOMBm;)H(mr3%*uYp&be.YU><+$]co3nKEQK18N4f<qc(+GRb)uU8F5g[$-&(S4%R4)=h)N#b$hdSA8tVqGKZRh]'@dTd-l/<-Ag5c6*0*KL#m%".$S-g./uM$TuPBZ2<ChRW5`UiJ!h$FJuY=-Z@'gf*ONc[1C.s_cVW.J,h!@u-7R3DS+qBU#Xcu%i`<pBlhkY7`:Z:NluhRuJ0>8VhuH%Q$3ao%L\%a`^21AP-Z8WbRt*k""lLHgG![l:rrk,-j;%~>
+endstream
+endobj
+158 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 157 0 R
+>>
+endobj
+159 0 obj
+<< /Length 1112 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:?#S1G'RfGRY]sT'Ll&n+"::k)6NW6=BRpuBK9s/TUc'Yn3nV413_jH<D&Nta0=IA1F76YHIZr&`]P!$k9Oj;>B-CI'#R]N\OJFj(Op`fE8*L5+]=:i[I>P\5oHU"3+sD=6TKRg%F!)@>&[d-u[pB<mK;sOj,mpS)s'Nu!Q#;rR\uFLd\Y[-AXO3:p>*d]i5<7`$&Mn>"#2F[<\N+.SN>!l?Le"l0Bmd_;0eXul;.:]@<*#7hKVrEXaXH:RKYg(DSr-#93o^U)@Y58C']aq7*KYrp54NTJ1n\p$aWna)f-#AR[\Dr-@&TtD$jGd5A1tHm<kF>DChTZ`M'*e4>:b*tY=@mTS2XJc!<c*C'Af8#_Ub(qip(>XQ/4PT)SOQ6rWA>eE<JXc7]l5ISlPMr\^meM&q-l_^/^(R;b^TnB?S"fhEUsZ)@\b159O2oRjRESEJ`?K1+8Npm!s?@O at tLWVsCG,[nU0EPPp.^+\i;aRPCCAJM+BrDH5*PW.A8a7Ht at dOh.r@90W`oUXE at j8`1W=k@>h at Z<?heSC3OV at gmO6ksHE.^#f!2A*ilKRKq1+7D<$l8f*ohIIPgWm95ug<'b0G5[g'?.niW?U,^"&?2T)#S)(M*2r:^cc)rPOr`lm/dporPPBh]rn'Rej+LDZdNT?^k at Sqa;JPCp`O'9I.bX<ZP0G(5lJ>HP%DDitM7S[/49]\Z^s5(66"TkIYPbS$rYUti-eT?Xg%Po\qm7#XAPY%?cRGZDI#q#Nc_ArJ[#-+]Q;pb'G6'<\+I^puoHr]B!4432W-PM[i$)Yi'lEtNb"`sGjCO_tA`M9T)TIBtf-YU"QJ@`#NG98tHpWqugju;?7Ol:rU!+uPNa)3puMZ.tbE88IeHL6`@j.?.NLZA:DGTdUqs+QG9J&`7X!g&'W&,k5n2a[R$0+oU*`H6WP18PgB:U9DZFI+Y&Du<s0heLp"7#%0H5Xb?g\h/h)(cO:GVR#U9BPDSgl#H_[:!8JTd9k96ME)jW'$>;Xj4(Y1I?ulSeb.T%'*r+o!09ja:1lfXCVB[!L:7t00,,Yp/Hp`lM(4LNZd5s:l1!_h at lEnSCV%lpR7*.&qjC/F8,XB[?HaD~>
+endstream
+endobj
+160 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 159 0 R
+>>
+endobj
+161 0 obj
+<< /Length 293 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarnQ0lFl_%,CL_Nm:IU&g^Br)^$$0'EtiY*J.<M4?-(N_a/e0\5$NYBYfD`h=6<U7((l+(lKOk`(CWk8cr?kK/&$G(5*!H=GSQA(6<U/;n_YK$6G-3Q at VX=7Jo3DdgFqS50\EBOYqcXJ2F6tLQmQ at SZg91c@Mi)XDTM)`eAU@*Lf8Uh$=hqjS(b(o)a:-g1,"ql!n%BeY58Z\6Y^'[Td(KS7nD+)=C5hqYN1NcRH#hLBBQt:kBu_,7Xu"j91`o;4Df+p(mHGjt46oTP";gdE3/Uf!G$.^7]$:~>
+endstream
+endobj
+162 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 161 0 R
+>>
+endobj
+163 0 obj
+<< /Length 1766 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat<A?#Sa]m(L0NkQ+&/24F3s&+uN?G9*mg4()a+QXp\fUSPn-]4X4mp"tgrA5c*:V`P"e7#D[C78j,l]_LSi*mfSE1g"WK_I.RRK+NJg8/MYc6pr;W7'M%GrkA5t4fRc*T4%IVE('d:JH2'`#0Jtp_AS2u at G%OG6C!>(lX7Q'DY%V^=G"m9[4P#$+<hbbQRBg0b"3LukC9)NL+u0-:Yr(FlDuS;Opml&PT>^G=;o1DZFm>P<24/_L_EC64LX$#dI:+&/rmG6mGLDQC1h>j[GNeHs7EL at 6`<l.);%j;Ml*V7E]6O0_Wcb0AqEPh)+f&F%X_-^g at n0*A4-U2^YF)'?ePG*KkK*Dj/Y^KP"=jV0b]oKR,\YiTQtlf=*oVTa/h_.41]Dj'`t/HS^ob,;1 at utF#poq>%\-_%BfCndiqb.ENKa at E7:Y1VdMk'H(X2Z7jLMnK=F$bJ at 37:L.h0.eY4*2RoZqFm1]E=kX_GqC9Ma-FR"dKOsmhdd"33)lr8m.ehk at K<#Z'pbEjin&CfFd[>Csgnj?]8<!Q8 at b#[&KG^V,(-]Y/Z;H1DFZW_!(LQmXlPUYhFcBXoe&h\ie8iW.cO<SC,I0Obn*196`f;cT6%Y"@7UC.kNka6iVS^E-YjJ\;,_cA.>,?($&F"kjIh5G5sj)Gm=,>ERHDb!2BE"9`kJ[*Sk"SM?W4r%@&M[%cN0"W+;6-pAJ")NnL,e*lIX(LKfNtX1.'kg4u(o>A*G8#[h)%$=qO]ja-*07HlIhV[l$J4DE:%3FY'-Dj/]"<3DHGjcZ/-7H,UL0d"?_PT[N$ou'nL^S%T<G+K6MgD\E9b#Xa#f0gJC9.<H`A/_.H#3X/]b5Y\"I%"U?Zd!$,O=#qLgXA;e,2I<;ne^p!_od/j%j?m'(]0(!V]t"gmriqfZ4n\=>9YaRFk8S/iS;PRmkZQR;a,R_18ESV3UV"U,;o4CUH`^<^QC^>k$Fo>;W/5t)XJ]HcRY4dp?,V=5B#R at onICR/8p<7qknC(4$,e8*Gq+p:&6mI\Z.L_i-"oromN(9mUCJA-RY`oP/WWRcK;<)p#0)+PnVo/NO'+0N9XR\;lKKP^\nBO+L9)@,WbJ=+/H$UZ`knh0NVUUQ&^R<`hM4.AnLNFLcp&>-jkATfEL7$80KV9c663bBTrFi'o<+a]h;H9)DFl)5O`D\,%629qNT)[=+R0>o#n+Q@:r<!X?X2U5IN8QDld+0^Rpm9(U^-`GjJ<5.X=V,TuW=<.2Z3&AHVT7upYjaB_M\kV(!TSaqcrO+-/g"S)R=O%^8%U>\u%/Kkrm-/f!jpJ+CM[Pn$,r]'ZpC1nF?J.A0@!-U]+`t>>f(nTWFZl11SAXZJ>7hrA,1#Eq"Y at MB7O\7'jsiVtf/N^&g>-?ggRe8SdrF$jfkZ.5s#M7.!+*][11GgV^&A0sA8T(sZIV@/TZj7==lF\oO?'jkUdW:sE6L^BD6(eeQ(gI`&>Z#cLg0!:jn<f-(lVR%:.1LA7[X+i.!M[EI!,BI)Zo.6KHh2dUS'gcD3cq$`q&g&7,&6l4+]VDYo/<4)5frrLLR%%h=/tSI_/U*485>U<^F\t\G`ji0u6X_rR0oZ6V])MEd-OQEW/H[GO.D$(el5!R/IqFVsR=[-Q2*,3+Wnc]=bHlHG3FVHA>amR\]9XAZkZQQgHrX%n1ilD=P8O.6Ipb-pH2>IX1J.Ht:`KBc%GR6Lt[I4<^F!qEe#Z@!hG,`M_fP0hd7JJoV^pAN(4=>9kPDfr#6Irs+Ukg*Q~>
+endstream
+endobj
+164 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 163 0 R
+>>
+endobj
+165 0 obj
+<< /Length 1042 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GatU29on$O&A at 7.pse_4$8l4M]sm>uV6/74Wf;==H6<\mO;seEA at qa-Mnq=(=XTK78.dXihE5Bk+1KGHk:\fF'VH^Rk-Hboc<q4K*t0P!@6c%=.#EQ;559Er`:j*ip_>?pl6m:\:f#G(>l[9PK44smA-4_PT@^)(B'MFE,LUtR=s6;)FjG+PH0lTQ:QV.n5S/Pn*b;cB_Zq=fn8PrbF0%@bj64uR&-Quf_nNCW.aJZY8`PUU"AsKVnhpo2V[T>F'IQV3kAb0mnY+sMEb6qKZ)N(8YA]&b`@(d:+r5,pD3'#rPpnGa+=/_i<L0,*rIYhT?D"!-MaC;IBF90jdrL9)EQ#`e\UN;:bJMqIa#oJ at d'`n9H]b3hSE<I3Q[MiI8]H3Q_\gi:OPoDX<J%=\mQC'M?h;FnAa[PbR56d]cBTeh%@m$@A\6>(dEHSo;7eQ(_a52CZrX&$[6r%&qc(5DY3MkeULfX2crphO?3 at d8F_4bjjWEo9eo,FW<:*J`\CaCap[-nHED"SGDraH-Hpd:mf3'C0[S at XaU*r_:-E%<r$<C;4Bi3TjVAoB+l?j!.o7:P+(!b2<GF%_a?^N6FSTM#kS40D>%-aJS]P(5]O4L(p8F2(d;N&dJZNk#Uo\#.%V2$88lEHOI&m%XJCW0iH8]&R94fo]G`ML&KLNU&>8+j,.9#?cfII99ic+uEuG13UB?Lo@*,7kim-aB#'(ra'W&[g(0?J5<Sn8f#mih6L:'\fS:n5en9p9Je[b4MtsDN9$eD^F;bot"2UU[B8Wm+hpoJDrc/g5#Oc6"N,YXfeQe_?;-k#K_ at T)cfu*bsN,l,7h[`:onkK#^]Ci?bNs8Y<7X*qWh15-qZ&GZe4c`/bY:h4B#lgGgd1^oW\DN8'P>YR2Wb(rq!e>U&GSW)gu-cn_noNS<+OX,20E!]u?U9q%%`_JUmCPbd]YYmA\WKIMV4ibXHWAJX1/+j&6-mbLph2<&F30O8tg7]bFq+1uhEi1_gPlg%X1eE]c at B!1oSB[^CRg at 2b4EFB]2`Qhi@)3-gG~>
+endstream
+endobj
+166 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 165 0 R
+>>
+endobj
+167 0 obj
+<< /Length 853 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:9lHLT(r#07ppTl-c^u$r2C[1^_k^#\ML&EKTZ!Xt'$-$\[JTVQE<)1fdRk5jr9A]TTD.Zf2p(.ZB*tkn,R-h(6!uRd!4`=:5p-5\E@<dKaTh[UqNc$K2>@?<0+Pr%7aAi$)?;+l5u7V-iW1Q at Vq&Ace&QRDF3lAp[EI*P&CI%t-u629<)mR']@S9 at DT^4s?QH%+Q2.YJ27q*#N.Pmf at Or%A at 3g7B?dm5`/OH$Qin=qM%%/*\quF_""A?Zf[_2Y-(e88cfKO4RGKR<s0@(3'dIG7 at I-f4./j\6=/WU0iP&Lr(RFQ2M$G5bd&5[Dk>XaQ^msJ2d\2otQY:5eT$AjBla+l*)!R/,=DG+8;ANGGqK+TPld];ADf>f>OG-hj0nLnkj&HTp]^F_eTBcki/Z":5!h&hYS\fp/-FI0#U7P+`A5&,/g`G8 at 5b(dhT[:\lI9Nd?L65E(c0OEOSE]q0gRZFQUF!JfdaHQOtWm'\/eR`_t(g.P?aq)WSb;*'t,EgZFZ53mVO@*MN*cqr;Hs`j>R<5S2KtTV8[6J29:p'VF_6+,"J$j\aUI^=e=0@#CQ*U4REj:Fk5[MeRL*:$C]?d+tc#t*udXYs,VP"cH8Ngg.qSR&i[k+F]CHBAFg<s"a[+>sMXd<aA4ZMM%\fmtg6skiVrq6a=1I`sgnJ\uZ6QF(:gT=e^T$#CN>\1 at T39ZStLhLjB.#Slm'h(m\al/RDgW*1i?d/K?`OJ=c^#ZAR9/qZ#f_JICp7%STH]`6Sh5.OXEot:H)!93pK6]6Jj"FJ\^DLr]A*KkO66\BSO9;7C55 at CQ8WK@t2UE&^p'r8%SVmij,M6f4AmOX#,q;Qp~>
+endstream
+endobj
+168 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 167 0 R
+>>
+endobj
+169 0 obj
+<< /Length 818 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:9omaW&A at g>pr;`q`ntqL+RP%T!XU.)BJ5T;[WPcK-7Oe`YlC:SBcAFZq]VY(;*:<1Gr,%Sc@%g#qiLq2+]0 at W-O;7N(ng`A5SAm'A/n4e5b*BI2d_bBhh%ICr`l3X^o2FT6$iSYc6+QeK!^')[aStsf]f7e\^fdnQkJhWDJ"RCDY7;idc_KQFf(u349DElOc=[u=P]uJa.7%WS_J"\i?9!Tb(X4OU,J>kah0/7M!,\LS3][S=VT#-#KGs59b\J<Ms"G)B7UuHp3!.B<GM/PEInO__p.&On'FE[?Mf)O(PKV\n90GrEk0G:DOV,-#pYI5?.F>M><aG"X_VB*caKu=_GE_S9/J3"L.`%rG=!4Vn75F]g+;iZSI\Y`W/K;oru=NNiGm)2;_oam]@-_;/W73mI<bt[qN1%-/p(Ys^$tg+;>3_I?^'1d)koB.?AkeE%NYF/?C^(/.;tS[cYoWET``/H;)0G$RNHW/0?qM*,!S.5R8B"9h2I:o`Z':(G@`P9:'T\fc_%-oi;VSg$+-a2O;F&G#Rn>\TBnPTD<3;+cUrtmHD4'KnSKnk%G]pTTNM[j`+5 at k_qu`oXM%1_;U2^L83n<E(,[&Cch8To.&IsL);[?r5tmk5H_&G`8a3m#[qBDR;88[X&U6,?h4(kaBr^@)3\*0^'i`T[(,,4dl:!F^>j\\T]-`R+&,YPAZZ1h"OE#_D>Ttl?I,Cg3DGF0:mR;R]G+1Jgq92F$3PsdC_*^?\h>Zh!IL:'clZ=#=O at TimjIk!FSU?p^a$XLU+:WQ:%THF-"]5T9J:#[PhM(q6g<))e~>
+endstream
+endobj
+170 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 169 0 R
+>>
+endobj
+171 0 obj
+<< /Length 670 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=)95iQ=%)2U?kh$lVkq-\['[7*i<hQD=bHcccaJj_Yc5[()rdElur(&BK.ss'cIc*_F,^ga>hgSCP,pX(Ydf=r9J,s[$#*M4S,i_^A#3%f at IJ9]7Ac_m]pnpK!J<:4YTF1a`arr3bJi&";8OHbtqA^RIba,,.J<97Ml>B=Pm&^MVB%@rKL[JMfTOg;)="!:X4<5Qi#6R'Md`7kc-re+^QVNFN6`=3W<&oWMO=>+M/K1B'3/O@[\?1)s$If[Un,n).g'GQg,.t`FMsY4sCg$L/8uO^]Xs\BKZ=!7l<41E*XD%i>(eTL;eGQUnG)]VtX`*No''4!"_4#keOlhA>[aq at KT=%'MLJ\GmXG;UV88+1(-ORDQ6F/JU.WAE_:+9_9BW+%\@o?im1<](O_K"b9S6UUD72f6(lEW at SYH4>o_X at 6"B+]iRaejmE]A=WQK/oLT^UeOL;K,&De9^]@ZjZPQ/rf>SpQIa$WQcb`hK6#/b`bJ5Ft/!,p,Ulpd>k?We0O-q<]B;=8>OnNDZ@$^50B*gaJ8I[/8KuPHl?>;o8G,MN40&T0t3dsM^ZOA,&:ZQOk.-Ak3&g.l,l6J1K'cL/8c?,io"bHpT!6t`$'9b17+S'%c!G%_LOIf$LZs?@)3uY7!A<.\Xse*J.$T>;Cq[o*tS=PV>~>
+endstream
+endobj
+172 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 171 0 R
+>>
+endobj
+173 0 obj
+<< /Length 1143 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:>Ar7S'Roe[&Gi]p6*,;I#IK#N\6+J:lPs>%;=?eN-qAe=H'FgOs*gamM3Mkr*\ceHkE+R]hmr6<+-YBi:H3kETK#L5=VRrM0So?+"-,V\E'aT',Y0i0\$u+r7U?7J"j*qd70=Ck%3!^u+>O:a&R`Z]*i5$FQn"B8>Ql:FB)V*(+mu-FRHmRI-ClWg]RPP;K2Xtq'LBNfFo#=2WHpgc at mk,IN'fkK$(;kE7Ro^3d/gJ4N(&*!mE8NkBj3Mb>L_1R<%pPDq#5n%n=5e+QZ''"UC&_DJ3_W$kA%]baJs)N"uup?6=LT(30O:uL7?d][99=-!\WCZf'2Jkp^f3)Fj+VIMtM1#V`F7f)70]68&7\@:\#55?,8S$cFjr7G;3/CSEH[<:\+0UF,sU([;mja;`%^H(&:L"XXAocT>P^:rfq;"+eS^dW-WMVbQhRNfFdP?1rKe9K,Z,L?gRTt\c at e?J/?7GBl0_B$.4/m at V.XXa<jj)p0;b6_%ILc9Ml="rO?UTJMq&I=^=bK4NN0tcI'.CU+E-$bnl%'+G^<4//S>^Rr.C1n.RV)`YQOD$>`Qi4U/MA(iF-<Hch>B/9UtWB2>K^JY$Na/9G[c_."itLKj!rDgXRGX(SEcYcYh2BSMLAjM&=>9lJJKDcTs%47n<QfthY:@QsR6mKT/%;=2L]1k`cKY9%%ES_>IcP94ddb(%WoIkEth#QOg^2e:s>atOJ/;LEjrgu$tZ:(\3 at ogMX$FqTN8E22;tpiYo1dF8aoZ-[>U7K\uU+S7A_qK_%q[(DiuVJ*XBFk'7mX3`HWK^1^<Vs/)/-oEC)1K!H_k@*'lHaKk202&iVp%9>E]%c$=^XP=mr()7)G)4lP/8`%boONpmO'P*-=b;do_bBKP[-Cd)bP"j!`EhLs?Z)'7_X%"b&q9iYp-)V17s<MT^t+R at IIb=G`H(Lj,/_mR)0a:@bBF^U?S:MKcOV0e,-C8S1(V@!*'H=uGqQGsJo9#V+f0Sh<q<n5W#IGY?U/rsEr=kkrp%C4mhRY_3+W'2/J`k%fFQe3mVe>s*4^MHg0NU6k9rS"2"6mL,+8CHTB?$!EC9iYGpX-Sqe6TB)CQKaZTi%DPJbY(!'IN-Gh3<$@`LU(%.mU,jNdG56ho/Z~>
+endstream
+endobj
+174 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 173 0 R
+>>
+endobj
+175 0 obj
+<< /Length 888 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:>Aoub'RnB3YV^'02W<UV<8+-Im2dUVdaVq`@h4fkP_hZFAR#1_N?,50U$4pu']g>346J\,\6:OLIN\[tL]akV(I$J(&Fe5&JABM:Jhe_k"m[3(H#Xelj:_ at ll`UZ7!:nYD"mQ*oG7$VijOaGj1A0?F.uP_C0^DIe,)h5 at Y%=%:ZF5YCr_:R.Am5LdA>sk09/t91F*'*f4>_/o`CX&>LiA4W3X$<*dVoi7!JUFX%+A]gTbHO-?P at ilah"`dR`TqU%gJTkO##$9Kct'Ji2YM>4'=C$;aS9]+f^]*Ce!uV3,`C,**&19(*Y.njDpeE.d+j.Q*%kGd">;p:3 at VJK0oQa@2\5g$f<^!9&V=:(ZVaF1L6%TXF%it,LSlnZUJDX5T4UZi*+]'Q0fO"S`Zf*.5bPD#JScRbjhJ0JNaggh9GtE\'LU73\`(P,ZQI!8.6sd:&CX9)qFbZ!?)@Xm8crA+G56t9-3*8U+\S_>+UH]*sTSK$SO$#+hL]O[%(S7DhK6B"#cJU0N(^4MK,5S8_cl*OD1o2s"+lhn]h>ab+iD2,D^36C>#DcO0*623\MH at D`>N+Ucmt];4=^NVq0K*.raVl]QXjqrJqibGgA&kC@\>UdCq*>kkH?uh8K@[Ad]f@\uhb\W;_X;7TQ]+ZY/!$9%`W0HWZql7p=%1d^>tTf1eRkJjJ9>T0?K+Rj_I2*@QN,;?mDSQYkes;;\1Kipl@:di<=_<MS"6>@=gG-S+.e3rj=/KDl=gdL>74rGqp_Sh]W<Is>bbQGlMp+poda=&1%5JrK;`kI[g0j%b(fB1Om2(4=9_B"dtL5&g/-^h8`3Tc-Y"mPCM:)5nfO(Z-$1lf6/<2.Yk3n.hU2`JFSR_g[`B^q+sr6YJ$S~>
+endstream
+endobj
+176 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 175 0 R
+>>
+endobj
+177 0 obj
+<< /Length 305 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarnQ]1rG_&FB?1>:'u!r3iegPS>q[aW7+c`u5GA4)h8DrZ7)ii_uXdS)'X'IEXURc!GtNke2QZ)2D9?JH(<'kq$kX_'tE$Ba>gM]R"DNWQiI@]Kg]i<,5>;"kIt[1\!lteC409h!>IU5(W6u&oq_h,LIob2?$pN$!c#;8jPi4F&*0'^X]koD*9G7LVqcqRC^#Y9,&g$l4sKAOuGTOruCnZ;`ZPLp!DMseLYTsM5\>flWmn*B2AP7p"Z52'kjaH3Wg?2,_F+/fJZuuX[[GcH*P&GBU&[0;7j/cU+33n!S9/EoD~>
+endstream
+endobj
+178 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 177 0 R
+>>
+endobj
+179 0 obj
+<< /Length 956 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0B>AqtE'RoMSY_3.[7#b]sEBM(5:(1i-+JD6::`eEAl%7?ZUb6-Rof/;h-g at oN$.P=:oR,iuq&Ea3P;aR#ncYg5MNS93l\UCQrHUq19T\a((>MF-#(=,YX>YB^^8'ne7<.B#X'e3uJ4D,@?k`jQ!N7P"@V,0_.8$/6o3&?rTjolI1Wh6(MZoroS`['NcA>Ng^=.IB<$#g&.2&<<5$MqjYBGhbZ&>=.WJ:T/`;W?IAT:,Z;aa^o!o[QpNb$nunApFu7fAnjo<>>0$qME6b at 588,$10GmF"N'9N]$d\+oC6J[_L=@R8a1/IuYkP4Af>0A$)\c;!+-+gC%!?Zfr13Ib&^^?XEkU.p'HoWXDub]K4Hh!ZJ^HdMYu:ercRT`"jo!8=eS_bLp%Vgs>&<Ee)q>ll4%^\'7L]>^uC)<hOgP3MUY0R\bE="...#mhd)VWG;gUlAY.JJeHm\Q>XYWUg1(QlD:I-9[]"*N)K/=0K5V"n"/\fB`Ni;O`*&T4moCAZ6_s"\>5eGuI!]c_m;Hd_(?KM?Fh^m#Vj24jh60FI=n=K-"Qu2bREXMIf5jrb(li0p779EBP:RP_QIb`kY*,jrG!%!Z?537jmcPd,DnQX>";hH*;F3RF^^G>rTJ'1#qZ8q>Ui`+LhTVE:c<$FFNK"Xd%-p9RP55I.LQZ[M]pq:[G'X9O<OcA.<9nZ-pa1B?GWc(#.Q;QL9)skKk8&D$l1Mr"EaMY)<05du.q:nH?aW at N!1GNe^sEXh at eN3FI]c&;Pk.0!uL6/T\*b$YNUo)$q8[?+SIT'm>cd2NHTAh\_XPOrk`57BXZm`[nU:_m<fYqpF6u\U57e91;iNr\o;*AW"eD7#A<U(XDVXC@$2Lo'srk@),_GV\.]PPFp+CZ.99ha"3I`o*eR6;)M9FNKVDMa`Z*7%XcJ)1ljFjg'8q16ScF^g/I!9rrL-(JJe~>
+endstream
+endobj
+180 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 179 0 R
+>>
+endobj
+181 0 obj
+<< /Length 597 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$ubAQ&g&A7<ZGYAV(o!P3:9G$A`TEU2Y]sKrD1?C!i6s$85k3kr8[e4S[\^5%l45?C[+Wo1s_m:IZ!Dc6i7$ML37]?>(;&gu]&j`3:BgoblIEj<`:O\DtUIQJ9e/*AV$,CdV.)@(h*M@))=VS;!jecA:eZ6gJ4]u_4Fa)_'=+0`-9D<j:RE at F+II)Dp"6f2i:mu712U at mrpF5!?n:-Z5U\'D.%5YhgPe'>A1Pg0Dl;O!-p5I at bLa46T`B`^4A2rQd]f8:(klEltS,n7ZNA_Mm$(>?/G\B!jb1*SZ8L`$-UfX9sO5d at rp(0X,5"`j:2$9].jXgH$J4uhjLL0D>/Seu']5`#(@PbLCna`Q3)BKY>LKVk5--.A"k'Sr]]IA'-[.UNB;(rQ+FSWkd,9Bc*+8/&oX1.if\"fJX(:SS#PN<#><!&>bj7#sLc,^jIU@>)IB9eS8m@&ml"(CL7<0o!UVTI4+D'(PlB$b+lYFm#'r3*h6!'B#rje(>8]?[j[eh<j][)1-f(ZD(r]Gt at J7_cO4[&ltLJk1"<T.;0$O>M\+d?j&OSJK6Y`0JJDGHUlP.hof::@$rADuCJg<`dc~>
+endstream
+endobj
+182 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 181 0 R
+>>
+endobj
+183 0 obj
+<< /Length 1266 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%#;3.J1&:Vs/5l8o?V;d*C(fkCJh<Xd.\nfi&g-.?An:F6e,FBD%^$W#,N=@e!Cg'8b11SYS2ri4?cGOPkp%ORb at K9>F=)J*.YR/!.IR4Q4&9p0(!2J3$S\.1q5EZ\np&=T,5=d<cKn8#%NCJO3.KthT8>%kc at GT<a\Y/:cqu#\3RWl64&!>STh*["#oXc5?CW5^4X[&nDkG2V#[Q7_Ulh74_k3Q;?-%bl6Z"j0SMq at V%3A2eJ1<5_:LET2DSbWMR$U.^(k8($p,WGpHp-u0CI2JJ7Lk;IUrUuWbM)bla"^`4[^U<VK-9WSgkp!i$Jd_>1Hu"]fb`a\nf8FtGiNR"8TEN7WK1J)7(PhuXlY\[rN'W38=It(-O at fG2<'>*Ub$Gl(AKeilW*KqU?fksd/.HbT`M>@9:R.]S#I7-Qj:4sf?%Ds*%L4nZ3fWIp>`0I^D8&KaX+Y\ZRu=)P4K<Qpk$5NQ#aoj+KiP\,oN at cE[%GcRA/o4ts,80dbT`k#3I(nap/SSnQO1Xr_kJTmFX9osVfNP.R\/1pOu-O7J?+o(Ts@;_p?u[a$eFP0FJUq9Ba,aa`rdAT)^Pg3j>lpVDE=<8]U4^m7,8H7?p!@L<iL<mlfDgP`A0bGgJ7C!+ at F8kh%#m1<TCfE<PU)5EYdP\q"<J?7FW&u`&P0X^LqET_SrDr6^WB`#QcC\=HQ?5B;%6*>K+O$8&lB7D+F.mF4GL9MRcn[S1A8UZCK<'Ig,Ft#H9eVa;OF>aBt6paTC at J<RHHWW`3ca8[,<l6cE.2_u3N++.X08]@eK1_o#)%nW)^HoCG#Pj&hbg=MoC]9MS=D[,R?:VSNKSTI^ud;*cM!mC5.&m`=-XF]<%^qlLc4o1BEi-d"-YO`>R9bKrRZB<VhM0Z*&JB&-CC6&I$l]faiWof(!Gag?I at J%=In&Kurd3:H^TQ):qXo:nBc+\MI;k8D7D_BG<hKG+hr\e4t9JiBhVpRQoH$NkhmeK6L@*VUMuC<Zmf9A-gbrrT8I<NtP.M!!g at H2UE*kEgdmVD?95Tc<MGaI5nh!bdueL#<HP)^dFirmR'_YY*3+)[4dnI$pp1-tg*=X$@b06"`uLa0Lp7gKs9g0MNj5a7h0hl1GtsP>J:(X6>"g6g*p)Vmf-UM&WGBU]2'1H:lS00loC7*)b$*Iq2hL>kI?ML[o?@0KDYm\D-q`rs0&1dK"hhVAfaPJ/EP45b=WT\bUOBYZl!?@Luht3C\dlr-o8d&';P!g'iWmoY5f]!PA~>
+endstream
+endobj
+184 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 183 0 R
+>>
+endobj
+185 0 obj
+<< /Length 817 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!bDt%*']&L6]OPOcj(E7]"B%aS"Tfs:L^dpX[S at dk4@l!"iTkJiNK^f76'\J&^?7]*4kG,g(9]rA6if(S"jqpprIQ5&IM;h#"G)XOUd.4tIb]>X'6T at bU>Ve48OSCi0VBIP=hOj+@@+BP1B+>E/97Jd;"6_loM]WI3)%nXGAG3+=FF,Z.ai at icj.`PXceYnL347 at hn)^?_eSe=Q0"hle]p>u^+E$FTB1On95V)%Mb+n\98?`J1Q#JQ/cBb#/[@1L^I3>>L'n\'s#IAG#F&J<i5D12LdhrVXeV2n9OOL7(:#Lb<MECI0F!&U8VNibh2U"C_dc]1H97O\!9mDj5/!9,'tLgjOQA8M)/H.oeM`Fs<T%:=35ekXo<9ohe[B/X at s'OaKj*m5/7DE`/3LC9n\$E]7@`['94pa\Ef.EoB#2nSf_U>Z^;85VN:[QhID\V5 at -JU7ID_:CR-5K*IJ:pVaY&$S#>?o](T6"t[Bo-(;_*JrEL@?<;J1^4EAldtr1A6ApK!ciP:@%lHpNsLcS6$YqH3\&PPf)Cp<*:jObF)dIGU^L(F+1%aX'YBDlU0$qeG<D?!,ukX[WSJJTj<8^)PGk\iD.jK,:HT.X?%_+\`$`aW)0rlgES$``u)g?;$$7=\cLT0IL07IZ1m&pQr`HMG3ecFpb`P0noT5a\k"R9[5ZlqO;T[`)5P6W>>>8>[$kfr_He]E at c@<Tri(L4?SWJ5K;F4)eOT6Eb92Kk.?rtXFeF[p8r2u4<cNSHmB!<$m[Ts7"mtTip5SIQl<T6-T<URkfbt]0F&k/geS(56g0$qj5"2~>
+endstream
+endobj
+186 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 185 0 R
+>>
+endobj
+187 0 obj
+<< /Length 611 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$u9omaW&A at 7.pr;`1#CfNs!3%Kk!=:%(BJ7.EgH$KkRhRfHi8<RBZuMO/gJol24jWTA4O;e1dG'_60E`G\,`=(m,=\X3(dSXrTN$G6P%6qohgA!Sp6PV%aX<-IKM`iL5mIDMbm"LbRWj:!<Ksn6GNjG at lu%#?m^R"@DLQPb_s3_npT=pblX+g;9YaXD*"K_H)&sCNS3kLdRnhr*FQKMI_FtP]Z_<M41c%/b=@OZGNqsGp]/*uLSs$d6n+5"M>_a at BfJ^$/Es[T%mXg/9pD[>fD>=aZ-mnmmja+:_9V;(QCar`PP[T)s9lkU=0sk+RJAoI-_"$\Y:UA3s+tj&eT75Np%9H(h3\[1lDH:W\=p23lg-!mNm+1(X$X8kkbe*7`I'];)A[prt&cuUF4!>^4DWQam>u]q)mSeR=W4r4:fiMn_IkLP4)fRDk)%3)M4-:&mg5[671<[>LB?b0iQ-+VcU*!*0Bs/XsAeU/NIp3sUmY%KfQ[,P2M=NO:,3HZN,A6grAQpt>k7RAS;=DtGs)RDAVbVr78m!FfT5KIoEA:H9 at cJaBi2?nb7 at YZ,oJO3U:4oqW0b\gPBZAY"+Aj$ep2N)hrs*cuERF~>
+endstream
+endobj
+188 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 187 0 R
+>>
+endobj
+189 0 obj
+<< /Length 1060 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"hf"u<&:Vr4_.3=lMf"FCUeOHcWcdU</k)80AIk"B_F,LKZF'Z1bYK/jP"$i3GMIE"h>)HlPrlOh`>YNPfpWjR$n[u7bn(E8-j#,m9`c^t20Z2$RQbt3I\H_kgb/^t1h[-s!GVWHPmWB\YYYd2nr*hM-B41?B,@"s880ea+ at N&J_ZO>5pcOm(:VJ`#ck4_]@K_8$C>uFgT;<Q[m3Csq at 8R;(FthDM$&q(rZHN>k;j=gq7MTh2[c'`40sh2LO.R]mT,2Dl>$73KRTRW6%$;GlbJNY8-Uh#t8c^0`'_P+b4o%V43'W^0>slIOTF<;qNN]du#FOn\RT(!c_:9"CN(7;#($Wm`mMFe%Ti+65pSpCqX,<8bM4sXo72..W<dYaaP[A["KYnEReIo6'%5KZ+N2pXn*SS$iZ`0u\[NEhTCpt&54^u%4;O&F2-ej_J"AIRM_nP*?T1,4n8s>GP_R(2rU_sbc?>QqnIqKs?([Y7c^H+8.c;2Qh`4nn0aIH=M]nr"[F'ssVq*5,i__l0`NHl[koKkZlH_Y>g3)4n*i-NjsHC&2Qnj+B6(ZdI>(L0CCLjm/\?d=QpF[$kWc%g`^22.9g0g^U4"#fPf2H^s8TqQ1$L;FPh%*sgjO?51j+mIbc)'?%`l1Ar.WqF2;hkP at Ce8YkUP9#3/#/ms>o.M\[Fr5"5/C\9YA2`2/'#;FlIXZC7j>E-*C8+sY%hk)m;CY**;RjGB/B]Xt*I6c7;d?,-.k-ipjX!fn`A%n0o_KV"h-D/\hpSV at G+KUa]a="Khoh9<hSK%5d6_,)A4Jn;d;DahJsWiAGG"20gksikQ%%T#TCqO'PH-os]6eLfH-^EM#JP at YYu8LZBC=R+8H!Mg[Oi_Jk*Ir52P8<e:Ce+L5lfY<r[D%AhMLS%J`u(Ah1W#B0L4&E@)Cee/3M>RR&anFs#0B;G*3Wp'G,#M6X(V;W9&/.I9rHK?JM<)MMc9*Vl)ks'StXq#`_"B>MiC1451kXgJ!Pp/GP'6!2=%0$RXaY=74F;>i+t+ATtt#iW:WTM$;V.!"hg$+4K\J-i~>
+endstream
+endobj
+190 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 189 0 R
+>>
+endobj
+191 0 obj
+<< /Length 1072 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=*>AqtE'RoMSLrN(8;%qjH(^[!4C_B8]TbUl^%pnOC6#@7)'XiLP01h[EB`fbuPiJ at qF8O8EHG+QGMZ_$#MM$&_#_Uq7#,-KR^^pbR7OVZ/"RAGED>?aCjCRgD=F\[q1k;93cpFi77-9#."<un0A6p:A>U9nIfp>6EW at if<U5!a"6&9gO`\LWpTRIH[VhG**8gRF7b7hGRm,?:W_3b3r"pVb!<h+.17hLQ4,%Znu"08bCd\tGUd,!#CKa9sUEHh at OOf78u'/2<L&VGW'ZU&GGJDkRI+<"N_h#EI-I4fW+N'uO8eZMAMk at uC"6dG`m&L)`MlD1W5mWah=D*u>\i"QeE]mMo7^P`!;!8t47/q0$P^c7kVAHJ/YV^%V!XFBB2F=N:LW0l^(Yh8XEW_t0HqNU*R^V)WV[^(V1a at -kjF'ZF[-t_7*?(D/TWI.O$!Jr%Fj#^Bi.P'hdaCbmLl=3MWC at FZL.I7d`6]'TJ]>R\IK3Dfr.G=FUrlKZeU:((b%8 at N=!f'h$QSm8p*6MCQS^sN&*OClo at pW_.mD*I+*JkWKnPH`0,JA%%-%!QU$4,hoL4**fs-7k=hLm`mHk_?VhlF&>QK*'3%Of at mC9u^=g,FPAIaY5l-Un#-Wd7Y]X0b]$LM9c=b*><2F<N7pQf]0tMQN#&",8m[V(-Y-bXbE+,,*+Pa*;@;FI$'7XaCq'rofhiiA5%JUJNb_:1:/um!NW=O2#hk72o+J6NAQahG7Kp2I\S&R-OMoZ'2oF[W9_UDpm,MgIs>3X>(%9H!]QP*^2R%+:O_oE+S^`@G`tS4JN_GHD:G6(Jt<KLY>/MDC+uYc$*<=']sf"F/8>"E7b+^R;X*.0oQ)?QH-;P4f.=o-SeUTApap:0\^Y-^Dc+ at D1ml\dDQUIo1/6`"#I[HhS)5+[P60W![#S+a3nMpA`$P#Ou1\)/JOe(nq:^a2M.J%r`^j`#@6Y:3XWk0TFm-r?!SmQX@[[l]u\G,gLe=2:q9^^I_$!=C6(`^].DS,M#l&O$3:U#%+<,X`V"Q$*9gJm"D@$6id0k,]&uSVD3cU at WrE&VeX]G~>
+endstream
+endobj
+192 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 191 0 R
+>>
+endobj
+193 0 obj
+<< /Length 1011 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=*gQ'`:&:O"K=SpU5M"*>tO?hM7>mVd<ck]q9&)#Is#.7$A;V:sFod0 at 0%A9Xt`gsB\ba^]=m<\=!NWLaS$,AT)+L#'XJFnJF+:nRi3#%m6o`9GIIZ=p/)Z0U$O#i.#N3n3IC'$(D$\B#T',Mdtnu/?#5=WdgZV'Y]\cs57`c&C27!.#&\sD/=ob^]"'m6]aWFV`Q=Y.$6Rd^Fh,oeZpJFgb\\W?gQ!f"US+ud#YW7)g+.-n"IoO,;E3*.2RTc^l%5=Mj"0B at WcZeu3"=a6X7FZ`-k)56R)q85uG=-r3la=--:4.W70RP`dO*cD7QnHjgki at ampm>_F><OQ^1f9]uZ.^pGNhkL(s2#hqMY'<(I:kX'KPmKeRr]"MT<fd3&p3:.`)T@>@kL6"M<%\OrVoa"KmJ_:l38_l5/#*d^lJUB:H^$<uJo342m9DS0V2tkpg[Dg,A!Ig0RV/sZbk3aQoc228B+J.oQHlY-1m?[3jl(K"R`Esj0\Hl_E/8F][!`dM at fCkccdeHf'I#+iY%1>UU"K*A4Ybj&d#9-h6gCC(bIt!gH/%O1.Jn:YB>::C]INZ=>fh)SH"EgWnS4u&k\>0USh\'["\CSfBR=!Xnf8c5>.u_N/eG/F[$\>4Ca6WrVY)$Zn?tne\D2'@6\O4S&g_+Y at EYWnfBEED4V<F9do5cDrRhZYT0^Hu(OMcljZo\D8YTXXZ_Kl*L(lSUAtI+il=bBt:p%5dp)H*B82E+ZkE=26N;q)3`2A^+N/a[aL1ie2q*(p at O]e=&S7jN2g8[jjZ`TuL`BFuDGq=pF1mZ_Pc:H3eR&_EOo$jbQ]:q4_=P9Z>pnqW)3 at +7Q4b3(qmd at t=BqRe"aPegB4r'sDYPMA'4Ohruh;"Rsg_lr#XK>m"5kcmrZBn1IF##5b"J#i*4'Z98m7UKG:Ob(C>\kX->HJ^VgioDS4[9ubXdfes82R`];un:2ZM:`8?&tQLnB`t_9hlt`+'2DAXiHDtRa8e3kSGHuGDu~>
+endstream
+endobj
+194 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 193 0 R
+>>
+endobj
+195 0 obj
+<< /Length 691 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!9lldX&A at ZcFA*2$l4ZaEA0u$H6RU,P-`!*;#D,B<CP*">gALi*%iYX0\DrJmn'g%cG.$*1hRegW&IDF1+SIL8oa&G.8!'NsOlQS>i$d6PDc`"Yem+sl./7=M!YK5N/Ed'VZoX;-Jkm?$2Z.,%l$fsAm'7lg9n&';<)c^rh^OiHmX8uidWGBU8>A[3PZ+'7_t3[$n1]tAoefP^dH1O$PWU=K'(C#GqA_tM2N\kSeU]@[E.-;f(/=9X9r/'`nni"dp_XkMDJlS35-@'(PoX)4`(kT+b!B6IC at GO.]&/s`/?1a%$!ImX99HBIrRZ"p2oV#A`]0Xu852hb3RKj=%hX"k1Gn%-/rP)BQ_,TSH]_I?rj, at oFmlMVmuC7(jsE!3!>h\t\BD/Gn6&V:5d6h0-`K]^>f9<K'<OM.+<tlSa.,Jdl9V+01\\bSi_dZa&=DiI_&..Q2rPiP&`q-;9X8b`^'K)07/Mq4\PZTi3/H,)R<uc?^Im#0qN+9u_erWD9U*JP=h3tH>JmS:R*16O.9RPOr at R'^p3\U\'<`lW==Z1#0-RJ&,Za:7XEfd%pg;n?H*MKpo)IZ[M?5dHg#_,4e=@.g*9sGtgkXGU]Q at b^@j]2E/-G?bo8Tg2'GeKK[OF#*p61(oT\Q3mqr6E:_dK)=3tlme$/56r,SE9\b"#H%r=;_KVqV~>
+endstream
+endobj
+196 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 195 0 R
+>>
+endobj
+197 0 obj
+<< /Length 656 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$u9okbt&A at ZcI,$k=osaIbQ$1^M:i0:6QM/c#5SB9'7=YH=g4*H38\hP:>B.KSH%'\gbkO at 3hL&^e.%h00df?.K5S/)\6&G_5M at 374UNhj6h)m$2F,PL?pnL1_7'K='TG)k&2P:lj8UE^OaKi$$Cu1O//8nBV7 at S>hSPh>8 at T,5YE(l#D,BO3e7<KB=B*,#rJ at 2<5n]Shf(!0ER&3f)tOrXt$1$VZ)P^q7HjAW@`MCZ8/e-;]m_"Gmj*2*M]'ri^kCp&)Wq'?"-46N6SSU\'X>O""ne9\=cP&eoKoG?:_]>NLdI?0To/I6Q;b.$7'C[52QXd%[%Ta<,Ak-_iU:n8 at 4E9GJtZ+GAh'^MB'e'+]PeB<[WkNhrpZRm>cS9HdbCkdl!7?O!K`0=lU%MhbQMueuM:\!;kS'%%V/b6jq&h_B2SQ/oqAns=s1Qp>!h6Hcn#h\clRq,#.pRM$EGBp]_"=APF$QI)>KkLOUXOnj!Gf0T'eRP3;ep-ep8lO@/HI5D=1haad at Z1.A`9hVrUSIi0O7A!RrHFYGCZ(*M%kihhOOKu1qQhp4\0RJ4rFDBbd`.VHB<H@#`*C//%Y"(hI?taY!A)Yo1'=NZ_B;Zd:`=]kmc/#ejM3BYNaGf.'G;$RmA#!#rWbQhF+"~>
+endstream
+endobj
+198 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 197 0 R
+>>
+endobj
+199 0 obj
+<< /Length 438 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$tbAP0N&A70Vp'=!$rJ9k%#^m[BKN'B`Po`9Wcq**A`&[JY)]HL`-pa+O]@P9QG]l62]XoO$<$;Vl8j*4pNrl9k"iZRRnc^N%6aVKTd5'SC0t]mG>b_Eu;A[iU'7dC+L#NLeCB,#HD7 at uiZpeRbds[f*X,G(:VG%t%7k;TDb at WA#E`:]EfJ?`V_8^#AZGX+u>q?3 at YtuY3!04o9m85$u];TM+A/&V-FLgjUD>DlT;?f;l+r\s`/s at L6gFP9B/X;JC=0r"R#!AS17)cb12dE%C,3qN!Ho^"NT39hc=);-Ieh4*trSb%=03ht/BfdSClJf>(].^&.[OOt_n+uoWA6PCsnb5^S%[cE0KgPd^4@/07jKq%1On[E(Vr&?r6m*",n-MU^":u8DBLofQD]\S0V2tOHV;(-YO1BjgI(j?_3H<P5=BF;c~>
+endstream
+endobj
+200 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 199 0 R
+>>
+endobj
+201 0 obj
+<< /Length 1607 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=,968iG&AII3E,oXZ"&T+Fpi*+$O__Mf:2D3d-QQ"5"%5Ej'9Z2fLo^OO!!F^#%p;Us([N(;rcYjAFZfQcf!Slc:h[i&R:AD+T]PYbZiU at M/+>4uY\1qcp#j9ram#YpQPKPGV6C+DIXqlL!Y>Z-i$.)(.I`MO4$+TcD=:V2e?llqCkTd0M\SR0VZ&!c^=":Sa#2Tk1rZp"S?NIQPV=to?t<F8UT'\V8eq!;\9$;$E""ig'f^f\O(@2C,UqDD+rX+-K&HqGGgYbTq2S/!`DI:j7]K;G%90IY at ZqSRG0uVVe$?.dPp2sQV5Aah8!WQbFYXHn%#t;bM\c:aZ:4r9J6<Cl54UslYS<^rcV7/m\ckG4J-\N'(T,jWkYFNboibC,8T4eu&Ab?QS4#)PcqnbcThld#29QE\mF#NXU+eD&\>CU5)]?R2G4gmhd7K=UD#KbK2>@]e#*/De/bZ^d9nE*j%<J74[]H:hF7F`boce6U5k2LjVSrBI+/H?EERDt8FOdH,8&d4d]lJ7(%3e*3p.N5mUYcelE=nZU]0CbJB.l>MdM$gpQ"h0O388Hp8%0<2dd7uW-"XZk;c]D/m[bL%(TZf7pkL1j/c*h;I44Gh05mF=V+.bbhCn==il.[)W&^rX(1c^cp5M*HIFR4NaJcs+.Xl]Y!/=j)%l\\C^Y'.hqh=10Q0E)=\:t)!eb3sTU[K,TN?$k;Ne9BB%!j9qBMO<aK=,DcM7oM=i"Bm*h,_U-[jX"FOak_j`?QIZ2!L2-Ze9dM0eb]81AY7]?f1P0l_a)+\tg5argfZVXlo$".N"kp#>eQ)B;1IU(9o4]*68SGXZd7fhqb7'H!dk\l%X)+AuVRT.[M7K.G:5SU=Njl>a*'4Ssr=^PArho.m>m\@S\Aj`B#GRp%^`BFDjb9B(<C@[>bZ[CfV%LbT at qi&g<EbB;ed0eI5SfGuf`c`#I+8DbOeSSL$^f\fk4"0SIOa6[GAej@"Lf:#Hk,C/";/I,1kTLKD(^cHJL3$@q.?h&%C44u:cHM05qCch0GO,?IL>jMn&\5k]26+*Y.CrR]]9Y5%2n$WfQ-2\^#3#6Iu+IJ['ggb+q^BMk\Q6m)(,Y[_W/.B"Xi8aE6)jGXs,\5HJ;5:u>AVZ$*K&-g1Z1YN4X`Hr_?jh^"p):PD&_s1.tL>&mcZu_0f:a^BU$WC'^jQhbbAHVIVFV+fh:LoJ&/ug)MD8G3NU<+4H6sg;pdS$YR"#Dn#P*3s]E4n'ph(S2_O&#k9e[5>f!u+K)?Q8ecL*]```5m$^rmeP..ZT.)b]Ko_Tr'4(3Z**Z+3:@O*lI8LFbX_+IpA@;'GX%R?k&M5X4*S>VV9NF2LNKsNf?hWd+D_O)B+>-R0jCU[O<"H4l?"qW9ahap=Y$!$pq%L=t^(/*es^TlJcPtAXnlmcUuu:^U%DV\Ij?u-lr/Ob3/0^dBhJCq1u#qmUums'#<qWc3elH*l=#BZ&X.Hc!*9:s5I3(cJ!ud-p%>[]6qDeittO)]7c?KBDH&[5:;&45'"aA$+g,gK1.p">Q/Q9]bb_e]4#5qNm#[Wb5p6FWO8:FQsIbMbC&Nc-Z82s3!-f5=F?ca*u,T,e)(.i8.0#~>
+endstream
+endobj
+202 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 201 0 R
+>>
+endobj
+203 0 obj
+<< /Length 1498 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%#997gc&AJ$C#jJ%p_3u+<#Gj"mfJG&(U+Oa/kbTm5=f0b<D93Bdc+6 at CHV'@JOF!uApqdp?)pWge*0/ln<o<imGaK\<Gai1(H]K]Dq=9;(8s&Mh0L at T'^!4[rlfP\C`,<9'^!4k9'm\Gu)^M?e@%n>l+=JQTY\1qdW+s<obOne7hg0&NWBE1E67>Cn=M[WW5`rl\>Y_or#kBFflO(SM>%`-+`4Qh136ub<"r^gbg:.EG]\5`GF=C%<;4Qo:J(7jC6oma^8eG!\_K:>IK>mfm9P?NiQX(fdZ*-0tS1Wu)mFrk1D^F",CeR0[P"=>SW#sb-/";P]8l6Mc;"@]U*Vn%JfW$JSH`DpZ;N,:HD-*'>-B?-&#Ba]",'fnrC0j)U>h-&BEm[uNcRe5_cS*TCk.n&M6R?HWX/'Y;.$Ub<`1IB=F6b5l6*dc!GP9uuiu/^AT#j#q)idD#aKc\.0dRar"9lO.'<#[,WZPL9(G="9`fuO\l!gsZ]Ok<ap9&F[ETO(C8o`&n9tBr;2r!_TdFN'<A*n#QZ+Y*[?Bn<fSfTdJh4>FmN)S[*bj'>B$-bdtoE2F#s/^Jp==JL4T<)<#QPsp++.9]!P(TbK#la('Vr-$,CB<`0QE$8>5h*b]KS%gm[a;8-<I=\XRA1otJ-LF;qE&1JlG;bKPKl.)Uo'OUSu[4XN%)SR#-C,_PqqYYli!RBMf%k^P8h[soEDoXTKn9MUt9pXNHf]!.as]C<#&b50cK4N4,dZ/^@1`1Cmr,QqQag;]sF'm>T6sUBUpgo1\+SU>9b0aY0Q=Up3$HG at 2O\u.7R5l_=pWRJsXPBmLT#rjgF>6SPJj.\Jk/di'=.;;cWiBP\X>A]eE2XR)Bp<NetF2B6A@#%Q0q"K7\pO^gUJ>!gK)OjbcmGTGp?::jkCor8=UGXE51=k/sgi.'b\Sa=7TbT\J<cZ=^JG*8(q*l1/VZ5)`6d;F>u8d\XWJL#"LLb=>D>oeTP<@1WM;C,SH21[S-%LK$Xt5A-up$QGo`hD$FO.8")+m/GAX5"U]''B./_(NfFK^-\g8o<Nq at CmY)._AcS]hi at ljL.Ho*)F at Mgdis>'c#.UGpjZcm at An"`-S`GYc9+l4eGqgrK:W,1X&c.B?nV&2P#T.SIDhadHVmcb[$qF_a`Pl7#b.rap:r#d2bqHm1*h&ZT88$eH/\*<7<(.SN-#2Um7hd@?K at K,C8N\^C=]b7l/[6.JO#N(!2R;5PXIFA.#FVMI=5C1.\4Pu`:g&[$@]1m5K3iLp]oVKZrg)(3#^"'"7TXF34.QT-jgPX#LLEkko/=5:6F7GH0Z\9ot"h[>W6LjeLTn\.jpFXd7?D@=FTs?TOQ#WR>I`#oNinG5Fbcio135;<qYG.%o93VF`&gbRm`(V7I,=b6bp"=XFOYNn[2Z+pJ,//kJ#iT53ag"Y.H$d^k*hs/MlTQn588sbUZ`/YMO0:Rq2m/$TmNX:Qc>)#?22jW,KZV!B9u_]/J0h~>
+endstream
+endobj
+204 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 203 0 R
+>>
+endobj
+205 0 obj
+<< /Length 476 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%_92!/f'SZ;W'gl#=+Lgs6N1aRP?+:Ham&WaHcI@@kR\lhYH7)FV=;q])]/021kM1>V at rF-SLg\"H[N7nRO!*d)6%i)_.R?@6NT+Sm2d20Ken/PF at maIb-<oZl>>gJY-uf]8qgS3O*]@$/9e4!-"/gm5)D&n!DMqsWGFItg^Fm)fnPpB[eshOP^gnN6==0ZVca"lR at 6hcFm/3SfZX0Z]$oi#mbjs84MdF#c`nC1/Lk/Ac5.ocC15J?aj6$9!.i;su#Bqq9La\onI:n=A[;2mUc(!;=Ch6j-<=6)U*0"R]R^CeU'[^7bEDiJj&D9=OMql+ at YE72W-CU7DSW-bmGqVC:D)h\eahN4["Fc.fHV_mZPneT8FC]fh<SO>#LF;9Q/^T<F7[V0OC\']XQfq2#72g14lBOUO"=akdhMjIR>:,UBYZ at nf!dqNRPMaj0QOZ4_f+]K/mc]5&#0g7?qZ9k?h"h~>
+endstream
+endobj
+206 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 205 0 R
+>>
+endobj
+207 0 obj
+<< /Length 2198 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GauHM95iTD&AJ$C#ekCZGSs*&dlB9O%AX7J[,%>=*b^tIe7ch'7."U`lT9JbUn2^[U'M<LAiWWsB0OK,%l\DKYi>s:8[*9WDd;Je`cGD[k;e!]TK#]:(qV2Q"6XWFIbXh<S$IKWh`/A4LEFak-plS(:';cDgA(J;Rr_.SHKX%<aRNO*@m3G/^0j@&O$`1`WF$_g4q84a>U"u#i'q4EJq,q0*+9PYBpq#n]W3hpZ?jCMCdML+N9c<qA6;$?PKpi2 at i(u at 5PF6WLAQE>bm!eY4.Z^2T.2n1h5XH3De'DL*X\'<X>!S))h-_p8*O-3eB](W!aqho,k!a/B_bPEfEhTb`gt&K_a<Bk[F:?3PD2g^:"N(s)22?h[s[pXDj62L=C#4Aat3+G+-&chOl6jpmS9Q$8'5OUnPjY1[7k1.j:+1S<*u-9n35E8h6J7_<-^T+oLNamL3hDdb]5]26-.b]1VP7o5.aC,iP#h2M`UrKIOls\pXF1M1kZ[P0f2^]pf+[L6ObY_]&YHFEb$#ZCU7V_[ASn$E;/!'(,=!KVL!Mp9eYMILL7'=AV>uYkugAGHH)@bS2JJ=o$YoK&43'@cOWFN5DkR<:b8$5'kE[:Pq#5`%%OkeKN&Lt9kq#3?\t]e_[udG?[(niYdmW",>2">T-2=Cf2Pf;@*p/:b.GZ6JXGPe<#nCH%8nK&9N'qu3a%NU0$h`<B:A;dWrNJO="8UQh7g\4WmA//QgGORn]g\OYa@:VS0Ap_arbgbOV^P]hs2gU^0-Y\;A>p1ra#c/dQ#^[=:&Dt_N5c(6X6/sd.+-L[q#>&Y7&YN65`Nqg1T^EBB`**7#@`XFI!B:7;jm(1MKG_F6(WNA8UW)NupS(U<KaIV;mt at bG=DF^!3`lbAUHELE5LoZ at Z[qp:>H]BaEH)CH5D;+L>B8/so;RMnQ[fFu&eLFN="*dTgi)#gH2>(lpOeX9PW?pS(G:=ib2FBP`R3Z:\nPQH1ff!%PL,RAbT'L9c<6RQ%&(GD9ZIO_.^j;).-6*/NlHY4dnqRei?$e$=DoSd^V$n1I.t'o"9\feRrN8(Lp^7s%NqM`2pf;j2f#dBtaj+I5_`2sW![$rKsVU,AcZXBPAL%*/-!hd*J/el,[[6\EjpltV8cQ>=DieX>3p\:*^IDC>K5M`S;$E"F9A>@tl,1h_##kM9:-o)CgpLi$Q;W1e at u7iN3IV^(AiF!gBc'Sila1BhR)Qkn.Ze+6Xe8DqK98QR:bj6g,eG]\'9.A5"6EP%NkOGjaKE7h$><RgU4^9%.ioFd]--OKA'Xm%..(Fona#n"PWa^sSMNc!%%0EK8/3k3[fdtF"[,u%51Z(27$mE#8Xg[^a/B!BlE\"C*K5E(nk(lJL8!!Eoj_Ah3P'o,lDo>o4U1op^<U,L9kd/OL_>0?90TVF"8M`0p4(m\ej)a:on_$8gq0AMq5C\^j#4rS%nWlH`B\Gh0=]ebi:`Vp5:E2==iC=p)('26WUX'r:l/ZB-d-Ce(1bcLDjc<c=T?U"^!LDTk/VF5 at TH3n99PP+O&Dle2DE\fJ0n$lZaV7$!7i9&iI`Wrc`_#&-)D8=;&]\p48K^Edi1 at T%t@?mF8RPhs-.L1LTah^26g2*oBQN;ZX(;-h$g0--,X"*g0;8k_,o#+K^D&OA4g9"R:U`fe;<e*AO?]E3U\<956H5OY%!4=WYN20Uh+P]f2SC4c,F+p7_rQJ.EJJ[kdWYp!ABpM&24elCjASihIF"antNP$R+Ts!.g\V8>tHWIWDT8<o*\gZcLq3nNBUh&-8D\VA3+:AWM,t!*3;!XR<onbPrkjMc6UFru%\@&`<'d]ui;\u7,m*A,S:]6\M;<%0LP-pu$$Mt5d<Vtn%^hb)Jo:Ngn!jGic;PO=s^e;8qrYasFEK'hjPt7gH7!LD?3B_G[gNueV!me_Cd'J`[X4_@(X2Q(Q6HE]IJP='CBal,_E%rIf]S9D^:i+\)h)3f35i8gI/&Z>,<hGu/86oYP%\YV]b-EL'W.kp+mHJ]6"U&1e3Z_NncQmf'Kq%J-a^9s$2G_XnO<8??W([X"Z%70-H_X5H,/C2\s'Z"]V]&nE3M[b?La*NJ!8<0kVn*^BK0K#$#J=Y]qA+4m$&Yh)eB$qLLRUNYh`YMT-1I;@8I at -n_]9+*(PPUOSc%WJS+h^&jsWK>A`r(Is3sONNZC*X+BI at W^prnn,Bc86~>
+endstream
+endobj
+208 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 207 0 R
+>>
+endobj
+209 0 obj
+<< /Length 163 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garo9YmS?5&-_t0MH=Q!md8imEc"&L)\KLlbDTJ)Qm2?S:BClT]_9Uoi3[]SP2JeqKa#"4NdX3VaI3RTL8eXX1C[*kK- at mG5-><i/O4C>U>"h&`<uNobN:Y5Bti21M_"`#)sUVi:ZZ(<b$E5qN`08TdD!%*Y1b85~>
+endstream
+endobj
+210 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 209 0 R
+>>
+endobj
+211 0 obj
+<< /Length 711 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!997OU&AI=/ppb\7&AR6-8 at q\.#Za82E<-OmFkTB';XB(W^W3=[ERHb):o2;jSSu5fpG%Y6]r)-/+:1Yu-q;qsUY'uKOp#5>)$e8$8e:.Oh,ALDpZO\25<'?I3-GK9oE)h(;b0MG&.ckJlBaERW\F*SQ.s<Ceb1&d#k&2j^(DQAo[_dNTZP(B!o)4+m66j0(aKWD+_3SL1;P)t&,B.iRsI>u9172WKZ([UXX&5u31f^a*%1,:S:P9T3<goqk4P5#r60h&:tV8-Goa;<dUK@=:rYZ\_/.kYY'_1a"N<*:'s9G.q+J/7[Cr!hWN]V=+;eJ3o#^t.GfHD3M]%':]KMJ%HN8b.;5EeCp2YLHAnr)Z:pKNXheARLo%91L[C?[iF[aH%*QB=q-kQ@@qWCLZ?4&-+g!BNqRN3)/*M3^]_Rj&uij-4I6(gnqjXBEaqbZ#o89N>D.Yt4WRiq[dNIO$Y3nMqXZeXdf(iA%+\6*ln[;\QO<``pc#o/WNjgGME0A7oMr>Q6h/o-&LFOQ]Djt0aX)TE%:dI6CB\^?T]=r2n<)nS3u=958sV0K!j]hD+bqsO*S%6F%CklUn[]?!W6!f:Cd`TrhO-iI1Qs2jqJ8$`)HqRLFrXOAi#:2p>oo?.]rC%TmS=.S]@fNg2ObM8Bra\`Hd)3'O;F7bik)[cjl`cB]9=$K!I]0sI2p/)F#rrHj!W.b~>
+endstream
+endobj
+212 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 211 0 R
+>>
+endobj
+213 0 obj
+<< /Length 715 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm9a_oie&A at B[GYEX6b#K,d/Wd at -U$.(N68*0cMG2\)[(';nk3ks"MR?Sf$5C41oXoIU]G]T&cKbuL&IHrSIcOnDG6l(J8!'NsOlQS>i5e^ApT#r5WisePnin%W5Qi#."*t._g0 at 0<_5.nYk1MCn<1>ApKOn0%g&;n,W+aDXIS_NkdlV>Jp,>;;q'dqWrFtPqb0PZ#69#-"QNF#e>\+$:*/$b06Duo]our+?$#m;B at L"9*$1Ad%B(6PY,,HD)V1lR-gR1i22uuIZW$ZBe/KV<$-io87$b at e\FfI7P"=ZVC_G*V.h<=bg88;F:9X67NE%+UMc=V>k4#WTPk2rrL?s3]VC5R!$0[Lf+9o4TgBDP`3&S@]?CL+[+AQZmk.aGBN8`1XJ4mPSrrs='M.?o.ofU-h3KR'XuiY`)L6N<]3;(;doqc?D0,^9u%H-#;^fCM2kr];U:*rP[mXpu7WifjKhA+,D4fmM'Ij,20UlN6$s!I)07]T78_1b[T3dU?.YX+`EZkdJ@[C`nKq*Rl9.O,7bO1h\^J^)G)R&.d8*eQHQcHBM$djC(mLJPiGr]Qe`gL1UR-F5P8SRue\0Ku^+A"IW6IWTU0)ch'7O',6,OD;+BL:q)&n,U;UO\>jC#ejH);\.J6C[_D@^5(9W)LWs!Z]M76^$A:^<6DMW4F)LrUZ"l2&@+gTtGnZT&q[IeJ'./(k^FG2Q!W~>
+endstream
+endobj
+214 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 213 0 R
+>>
+endobj
+215 0 obj
+<< /Length 653 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$ua_oie&A at B[G]\I^b#K.:$0iLf/gqq)de9?TPcI-//(-lXpSAXp>3n5"!'u[7a*BK4aLaEVJ'S[g5U-tU!Cj\O+RC/$,R',P(E`lOEJ_E5^*KPh5sJ6EdBNfufEF7_O[*Tl+;olpp4TNpHCYu/jONZ&Xf5t9<^/!t*o4FFO%N^/c*PFqUUM:-NW'@@_F]j%,`!'=<A3QWOuDuiTpCWkEXSQd^t#t."sUkk-KX3F3 at Bg?4DAe+3 at HA'dVZ<PPe+/t/Q>>=JoJ(hWpKpR-H/9?QfRe8$Um<1EaI([!Hrc9UtZ\(I]4G53:J?_2u'%?g>mUMf@<me#Y'?$_)nbPg+I>>+DP-Mm(pdi"5_YLjA3a.,q4^49l+I6 at Au-1`PGJ!JB;IS+g%f[]!6$T0-%2IJRc.D!IXaIQ2`abH]X790DC0<L[KJ!hMl7eZH\j!hHo1=CurZds#q:cOo7-uAtO+MpLpgg27gl3&"5!QR*/gY6b_(aPA[["Vq,+D3Y)rR_M0S<Y4O4WF*G[_BWu0:7o)q%B\4-m&d;P2\)_+X!]f*`Rt%F*I%:t8e.9)Q,i(#T8mnfDbf!Dr-4^%IQZ3fX at HYp,FWR;U+:J</)J-aoi%CT+LE+s#8FL`R5:2KuiAa":q:,EF_0BRr~>
+endstream
+endobj
+216 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 215 0 R
+>>
+endobj
+217 0 obj
+<< /Length 1048 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"?#Q2d'Re<25^>tu`PXURd'm!?UeT[@XjLI at 4ZLA*W-i-qBcBeDmkZq26QkX3$blDkHgZY"^0=@hJ&Dhm!!UY'T"*'h!Zb?*d%L`T%eU+#`,h64o5jVjAc0RDjX`VH'QKeH2CMB(J>b5"N.?sGi$FMtGuRCujP(VdN_$Qd[R,e=eQn>V9!`'j2<QXWd4?NYRH,=1TH/ZN&fma#+Rh`mkmND;d3?GKKHDUp:Ef5ETd3Auk`-g7'ang<C1_M\h3tZVYAT<\caqaKs0driAonsM6NUMbBZCLc4_-[AFknGL+b?47?,#R)J$AR\bDVVNnrNj'&4>irTBJP0CH`cc_DJ)OB'UYKR`Md0oAu")FjTtgR.iI&lTKJ[1;7OK]epTFA**9CP^=pe51^g=B(_=_kqI<1=C.l\dC&RV(FFGj9cP(oeHB/RdRGeT/nfL9.Ujp-*>eXU]c4/j\iAbOn&@he\<V+0Rc+KX7O$O/Ur]`3N^lHZ>#1SCXsa1q]\J/J_ at qhOZT]3$1DaUsFJt"s5=3.&('duQ9I:?ED5iEsk at LjbUPe/1>ZJ+/K^5P'-p?giY.)Is#f(uUmJ!e8gS^@S%&g/nNuJ.X>>a2FGTIst8GBR?_:<A5jc\fQ;e(aJg/R<J*M`:c/$6d!#Qi`V>ub at O%Jhtte92P0p;%FA<cE<qGt4urLH`Gt$W at k7d*Crb-)@Np#sRn>!0aFc==K?`<+u-AAl9NqZeR%&M(%perf-H9M1i!0rm$l<@G\bJH8(7&[b`SXRt=ifo>:@B?^"A_LRG1T-)LppN^lldH/)VP:h^I=!/I(i/tfFkf"4,uFZ_Sn(>&.-YLj!Z0bisF.d,>2*qJ.r?,uWnRO)a@`_QpK4Co"Ed)T\7429qT39H>SY::Jh[gC\n^P\Og5GAEn&2\Tt73./-mfi$8578JJ<fJ7%',LiiGd(&"LtC)"dSAlD6loHA^RdGb-N[0FSAG/Enlt!Ml[==W!"M>l0hMTuERZg+JiiM`gZ38*hs>[iO6g\WUJUoB0NE;ui14s"LF2XXA&Y.H~>
+endstream
+endobj
+218 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 217 0 R
+>>
+endobj
+219 0 obj
+<< /Length 990 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"8T3'C'Y`a3pk2h-%'u#X!)d$Y<)b>5%30o9e/9VLcFA*Jo\VH2Rdmn-S15?$bM1qKQLee[joYpO!&tC]A-%>U!X6sM:`qHBJY3DW7Y>@nr&D5a>C at Ff$DNS^M?O8h"tT<kJ8dje"9XZGJN,S!\u:odO`-RX?KcKJQ=X'lApkRK0l-P[IUXk`l_5%A*C[Nb?A0V_FettXpI\bijo&9ils^Q*Z![^ElsfddiZd8OaQF0uZihumT^mp&HT_X0.H8o8knH;(*/AAJYC>e-pWBjG<u^llFd=U0?#3H7._T$BcTBGa&>HN,p0H!.@\F&ue?Os!)8O=G&<dM6auYrs at U3o[l09c%O:4uj.'rL$hc*YBnmIX7qCmp17VI:;-?4nL*m:/"@LO78NQo^Cj&7ht]GSdZ)r"[lJj[<Xjm:lMikDH:UN<pmlsTD&S\+>3PJC$XUFVn63ia5D/LRXfF3h`s+!6%d^.uL4ldhq*1Tu!Md>Fb',4p$8I(d6XODTSpK2#,ehP`c[[R18j at k`*6Xl>=H*E.22S_!&6S&E*=]LAQK- at l`fi8cN:1TcU39JX$L.=]gT('BHbT<>C#i^;1,5&"*<I<d36!(9`BiTO+h,mOtf?f:fNO5d-r>/), at 2C$6^>TBlHQ@!i6?L at t@Q/M_!H8Q!k&#;d#PguIdfMNS[?hl5cRj at hS012HE5&."X:=1[eTu9[T_ngM@"\qd18gKL[GO")O1+q#P.a?6)*C(4GbG7?*^?DRLbl4HQc`]V<m.,PG/H?!QKGsbm(!;c/ng]-4HZ=0c:i6L;h:_KR*lm!Xq1Ol,!m:BlHCM(E\(NBt7)r:fRm"VK+Jdop2n@=+(q,]]%D<c,XW?f4e[rkI]80TTe!J_+Tj7Y,J+HqEMfjpgQ$K6Fe#HFXI6Mbs)5)pOGMt;\r95i`Q7mpbY%X77&qC,nTNsp=%[+fo`Ha:PjqNm`::F6iiC`I at idgaaUX5G.%qZND('~>
+endstream
+endobj
+220 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 219 0 R
+>>
+endobj
+221 0 obj
+<< /Length 667 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!9p:c+&A at Zck.#b/bBu)NXibB@=RK3m96jAFKFD"bKNWl)qsPOB^.H1F\M0S'rHR/%LV(o[o8t4JJHRAp4<NrRN-tN?8.tESA/lk--p45B2\4;5hkD2 at r+&YE at G`D6:^b(7$:mcS&-n"cp06_AW\gcpj>u+0X.mheCk%@DKNHhch[,GDl+I05I3e)"5GuJAJ!q-&buml\42jL`6XJ2,0F6c^gdc@%3eWqH6sp*`@UNqJGuFnDQc]S,9O4%mB$O*8^_$)1?'@IOatZHO;D,W0^]u(p#bM4h\\kTArTU7:2^0\:EQi7:ZeajC2*.7LEE-f1A6oj=HrfUh?j*ebAprJV0^XR([CtcRb`#,YO/iWRs"Miseo=AL$K7 at 9kT\=$k;"pJiYF91gPIh(1tW./#Qs'+hEEm8gLDV,%Fgke%bSrC at poqZf12%>$r`bAl*)*0[X)%2f6[5TT<s!W[Q%$`<5$qa6FSa_qbtPs2+pb(/[.>P`X,Ji/Aku/dj+=!P/MAVb9J2<Y\LW7_.<BW`7A'W&2_t?H1Z?$[P*QO<!It*q,P)W)P4?<e)kSMCD00m&bTX;St[^K/=hq(.-C,&fS&*7pCXCr!df"85ZunWLucV^NcL*lmu)B+:6Ph`H6KVa[^+d+.M3K4Rdi,f;uZs1JWr(~>
+endstream
+endobj
+222 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 221 0 R
+>>
+endobj
+223 0 obj
+<< /Length 887 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0B>AqtE'RoMSn.XM$C4(kJ#772#N!H.Q6Asb&G]6TZ#ts<@$`!WGS6PBV9=#Ga(SB/ts,Okh3aBAo8-.k7#S>!+"El:(OSN>##t0;j%!(K]E"BZggr[7@"@#0Ha`oOjOYJObK**H[Jl;`!dQ,B"dug`]3nB!WGPShOMDX3rJi-trmDX99\<X4Co?sY]7i<a+RQ+?0,CL6_nS8fSA$p]e>(WFiFOf6jW6e%qi7,X\7cACs]jRPK4pFJ(5q"(D+D(CnR-Gr\Dec&<dAmLp0\uQ'mB4`-P>,o?'MB:2KR!7jq()qAc9%5X2Ojpg/VfB(,`$TW=2h?!X1W2`iuA73HNp6m4-IA"XD[Nu+&I_#CD(T6183n)NaQej&LPfOFRFdW at sb@JB&cmlZor=IrIF^pW`!L"2@$S'n-'8iYoh.P_/m%VfB]H/X>!ebcBQPT,0o8p8l'/d=@q6,<lMAi.]`@#i+'`<=L0MI3ASe>NJe.ioK]s:l2Y\0YDI:'W/=cl[c1U/&#Jl9ifs8;e%AS4e"U@*N+N!WFCY!*/a2SP`]?_&E=S-s9RYmlMKN%]^m^ci+Uo!#fl*"uXSe<Y;. at L43g<e1#1YPS(GsQP4Q^Cq`@L<^_Zmj4Q23e3;3=%CWQl;ohdaN2g[kFE+S%g<X7j+a3!P5BZgI at .2(k+TL@,u(n$=_6M8u/D&WZ4\2a:;ASJ_SeoK8-&JsfOG.Hr;V52?^,h(e%d*1Nbc1&sj1*;!KcVfT89QjNtM&3XWB*]9h\c!`=[A__PS]IY^)cl5/u2h*%%Y*dF&WUJ<9QAp@(Fc&/SR%9O^'<Ze,Djo6PR-tb)JJf2VKJS-$",-gHlLX:%S/V8GUbe=&!6eAsEkm(dp$d7FVZ$h'Q7I:~>
+endstream
+endobj
+224 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 223 0 R
+>>
+endobj
+225 0 obj
+<< /Length 203 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garp%]*cD?&;B(lTAif_$R`8BHYik^&0#%>Yu"";Kb:)o^QBY5+B&aI*53o'Z5+9M0a_s%(al/rj([^&'WaY5VALlT);Cm7oZ)<&l#1Vo9F-k,-]_a1rN<cMYTLGgXEMZ8[ERnsD&XfkA4I7G/.7m(^uR1+B[oRPq)A#5jA/q0%f4_7o!d<u6XBha-Q=D=Pn2m]/FYIY~>
+endstream
+endobj
+226 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 225 0 R
+>>
+endobj
+227 0 obj
+<< /Length 1437 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$8gMYb(o\EjtFMNtH0dkh"a]jX75_lMX<b!fS0IS\f'9OT-PgfHs7uEO%b*Ll"JAH<FF2.;EC at UmK3.`SE=gY1EEO9#e-rrPLV$P":8gm4ZM,sN;YIi-"T%und8#ou3'ocV&/h!HF!$[Cn0`hY:"<1AnX(,(O]P[)3-)17Qh&<!:5p'33(P556.GSnc#,Bgm:+Uu>ac4s1MGgf+7=J!oBge+N5k7R*>!a'u;'MH'.%B'@b9T!GMlh*JO0 at p2TRFF4f%s]K\t`q`ZQ03qJI$jh+9HRONPHpH4mlJ%oaXVnOAe]7i+<Y<Ihq]SqfL[/j#3>nOQOp!ANmgGR8Q-rTbp^i7sD6P]e'?A$?rY`m(Aem<q;-7Vr3$5 at h/!k`aZ;m^k!RXGNKrb0&=(*.ehjo/%UhQS5Z7!9C%h!,?,G<NaR7h/#u"+a)R&ieFh3b+o$o;6\quRj^F*B%P at o83jo?W0;fBL7+')ekcBj$LEG+5IjS7OZQ%(!A$YEX['FQ*QoGo5[?k0cjN_ng_h!YU=\*$\!E>KB\?l1?jGd]0j;iaADN2pt2#BYbFCc0?m1Qo^-<]];c9"[C0&0<:l[o:V2Ai+H6M_Z_[\)Z*a`,cp7`39(5rt3a\i9jQ,MW>M'lBNO#d:]UN6NCOfrf:FQ"2 at ThT+J)_c_:*4He1mV6)nj)m[X'E62dV3hpQ9Ck&ooIBuS?`,RIop/[ON.<Nh.,R)gGV<p_nVQE1pYWXn_DYcrdZHN- at 1Mh6i@"^h9A>)bj5CU1Q"=EW.j<9c0Rgh#N,EO)&G.%Cg6A1shSpB^f<RX]''sA9O7<?$[F%Cq>R?@._TdDd>KYtmD&aY$;#FhXm%D at l\^j^i;gp\:WG7GUJ["[+DN`i=C0;9#Uot<^qGE7hUlcO?8358[Vg3`ULNII:_Q!n=VqX+mfouKSZpMKTq?.b`k?%$M-X45:Gb`#mBjHt4nLY<WM(1meMU.:fAkRJIicf0]1fE99^A)2DP:C$?(>Kr6i0+E_FE$iK0T.M]_#tWQ,(0LA,f(.(N`$(Q68MCO/]Sa97%LUN<F)_.U4LVA[_P,hXkH24Q(Uc99Vh(<V+FsZW/2=Fp0Nea3#^4b/D&fTn%9#(p?<ahnE1,IokHr-`nde<OOQV*$4c&4-rS+9*+eUh:dX1OcYY4Q!/aIS^m.?rq2[p/_Kr`0W`?UlFA0YI=rT&LLUY6m"%GNGW>p7enkI#p7IZGWT=ZWjiRA\CVDn:j[]e6SdLR.GWYHi]TVF(rlJ<8"Eq4]o<YhMBD'e?ns1U)'W;EA5G]\V<(47Wg!'Z at 8)g-#%K=ST+F3Sfo-1[RC&J)ipr_fSSFP4cq&e:H[6]K;S at HWpT;=p-59)Eb2=?d0h)^R$BjEMco0Mucfpa(fZ//?0K#0A`n0QW94/R at E7.0NW1"S>uN'%-9a1'E'"hF.kM~>
+endstream
+endobj
+228 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 227 0 R
+>>
+endobj
+229 0 obj
+<< /Length 1777 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat<ACN$",nGE1lPY,d:h)^qdE`+FLXuWI]>,fcT?b63OK%[QK at Y3QZr;.CKj+2p?W/;dEL)G?pO8ZFkh1'Dr*$T$*D6oLE*ELgu`?2NT#ME/Aq'bkuCO<Ad\c"ZTOZVl9C\t0jnh"Yc!l:ZMYgXa^f0Os4)0-Ljl\nhs*f>)8pJkJ+GLkL<42TaCj+IV_'"$GEYrSfl$prd'#$Jeh=WEBP8BUM".?^.*@UK7PO&QTI*qF/TE]pm#*If#QU at X-u*?stVViNKFX_trJfbLY19WuNN:5[o^lbMq2rr.VY#!0#rah_'8PU3AF=rc%EP]64oaHDX--e8Gi!lpd&n`*F7Kd7h3?ah*MOm<2AJqrX<S4HNOILSXYq:H@`/^b7/GFUUF?a>dcVS@,4K:Suq(?87]bD>IM4RBWu'F9EX8smf;X>8roY)ga'R^saNc.Wb"I09["\i#'cZ&CW$Tu@(OV[IG=>3Rf)5K$%jR[d4#kG-,0IAkCN-SYiK.u45iWQ[rs#:!'+hq^In?G<]0L%"F<3f*l3_8*1XLk-2Ui-i$VIUF,b%lB.7cM&MsHt-c!:qpQ'>TYDM`0DII8S(^I&^h7V';+0!0Q4<^ZDO4i:2.*Y^)%[W8Q%?I^dO$p_GKSu$:>W;5mb:A#!+IK^9MKBB)n41,W2OG0a8OXOO$QL at VLqrNTPNT)n0>7'6B3.3IkjVc5H$@;L^\.1)SgCl\Ui'CN"TSUDZ&Ci!a;qU`eS5PnX+!a/l>$25d8aJo$N(L3 at LR>1AhI8e"7&+?-59S5UUg- at gR&Re,b.VFX:Dlf=Bl<g"r88#YM``kaKcYLPZendUM[p/`a"Lo7FuT%fV"U!cLl-!YPh6$S5c$;3Y94pgn%4%D2N+oROkF'P#V49$a.STm>Y4V at 7;()1k=>n3_f^bAO=r^gE8>0/T>7L(VU^g_N<!J,%)QuB1[g];?Wgu/A[6T`D$;36kj$M#_g`=50/5rqTRWbUaE9VY[f$5c$J0Z[)'/DLCuXPraG=S at -h:>b#]4W*rXs7Y(-Vfs$9"[-d9H<E'bjSRBqE>UnCKTEW<R8tN-+6FuL at k._II@X="@gjF5'*:M0XN4Jc)P4EJ#tTq#7TT at q)[;q'][k`DD;=[(0dc*Ff:F_Eq?qqso(__5_OTeH\]o<qnJg3jVKJF0\^?dNebVP>Bjq(p.=/q%/@cB1RZCui5Rhs.D]&X-"(Y,t\$IgR7\E>jN2Q,flMkn]LTAn.)djB5Tp4nV_NTkCUEsGbMs;Y,0Q\V9?B'8,W2WE2:#7?&.#SH(+:>A)''JVYJ4j"rI0iLFW/"'keu3JXU>T`##>9)"(;-W>*;)%hB;M&r4j#1Iq%#r_,UICO/'_E(^Et'7d\[qJ!O-`f&T^9K:u<<H"HXUlLB'*mMG,=H-*cF(k=7i7&QV)T'Pei&*d2"*o7DrYeDn$J)^"mP-._In]$bM,[Hm:IQ?T_IITPC]2nZ^<+1hJNb?sj/"BnYIc>KLn)K`Tfj)5L[^En8tY-9k`'apP'BM+EL]Y*V1Ye.S?DK^4kT,EmcqQ!"nH*2A*i,5`%'h9*XoZmii2!nR+CpB%(-ME'b at t>%t/?Bi&r]%7Igjf%(8&A0nR23*;cZ&126,die7l0>&H6*if;<(9P$lSNuqt at UA\9!nkrqA7I2$e at Rn2RGgMMlWP]"!l^U'U&rn+KYAXE(om,^uV51Kp1f\#WU+,?HPd`qGP,&\ZF)UKZkch(DeA.pMtWqQue+Mb%q+-taoja?b at rM?OiBWW@@Y&`Z*'8?MU~>
+endstream
+endobj
+230 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 229 0 R
+>>
+endobj
+231 0 obj
+<< /Length 257 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GasJK0aiUf'SQ5YMDshYCQ-9#YsLNo.qC.N'Vc,58u&6ThcCDKK2Al/4-$q#Kd):.LR97heIW'>M1JDTL7$5_i!_'$TUp*1Na2o&j0Kh at kBc=;O0R8CQ1fMXD-'nHHcIsLO,m#bR`^o`]1EK=^UpeWS+,)!n(GFVFc at R"6!_Q'Ok52mi5cUr>XD$rA:anP%SfAYY,"lE3o^8f'2psdn8iNtoM/1EdJD>*O_ibH[icQ#M#a,U.[L&jo5-_R"^Ho~>
+endstream
+endobj
+232 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 231 0 R
+>>
+endobj
+233 0 obj
+<< /Length 1328 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau`SD/\/e&H;*)+_8BS!&Z at BM,Jm68='JC0Eg->m)u[FZ;'!TABC[D[JonF7EVDObAMh39n7n@][u>fj6=I%[WoXiA,sTb17O!6Fp<RqrPF(.&-e(i^aKMTqr"+$kB,&=Jq&F7Db>ol0N8*GWDe=<1DiS(6:N+3`Fb^,P)F03cc&MRnottp&_2KBY6ZjQ4Xo(,Of;Pg"-,+AP_ko_;e0\o1'Bn-R)kkf at U4nt3%9+qoDj\V!bb,af#t=sdk<)>AF(_qN//rX$85gq/\l=9!f,1M7%nSOcpV<3m7'X\Y"L3kk)\B5'`[]KcKgol:SL#o[)-A?P`-U^r/4K<V"O.:>*&eZ,,9Q>\':K\F^%kc5XHVkKe52GqX67Z]XZ60@]Dq.";!sa6mds=$KIi&]fRiH/OcpeF=I0p<Ror$2Uq;Xkdj`k5nlI\oo;+CPu\r+[(#4gjdsnc_``uT"C8=H,B=5>?h$4NeAZb3eprk/"/LDoY!M'JILetk[%?O2<H]DQ>D!(mQZ9c=9S2?+BTTH5'[Qs(dVZ(/D*dH1ZCt=\(d3s3c_P:^SXHs`@Qn_ at Vr[@;X8kaSn18Es01Kr\AQg5+h\-RI++M%Y*/]IXXn)[0?QZUI^'FpOLu.2eh<^9H46Q(=aE'j/D6pN9lBW at oM.(L&)bN'"N?e+[H4o"YEpH1eobca[a-'0Ee^lLnrfH`^c);..8XR[e^FH43^;3(c*+m&3-YqS at 3=D65j54I\o<jpj0:nG'Z$Fr>"d?@3<)$4e5H`2+_ch/T+l;j%39kSM[>pu_#>'HHY<'KS84$p_Gi7+UMF2<,R[OD:)@%+sG3%om]Jou2%X;UM%=!Wd-"IiCDdDm4Y'7<LL/m\QfkbkFN>Kig`MK>(B/]'C=]JpBYd0kDFaL>Bi-9bA\rfGC]CRkj at kkFKMOci#+`XGk6<;!]9Qfg'qHu0SOXN*l+2=WJ(0tZZ-4HtFq[hK/rcMsV\'s51YI?HJ\Na,enoZS7rO['=Vk'=/]4&^4BNLQ&fR62%;iC3C03XWpd^:U_ihEF565RNFN44O8B2"ed$j9FX&f\o=qp,!t<i'_WP>A*PN]+_EV2:==>Q!#1ptugHb4aK!WD,naARmoWs7"(R_u!O.e)m\I.V8QSASnDi#O'O<*ZRQ]og%/*U)1)n]ug1,bLBpCBb2u7,$!Hdfh\F,ZM9:jX*Zn8%HY<H_u!dEX5d3h0\-tphVo=!(dJMAMmDJ^)b]dolPEDWV?^?:!>CP?C`L=PEq[V&9Xf&I.OU5iFn7=Q$E4T`5k6%erAjbZ*"#1=i!INSPGk(r#W"?L"(JqWk$7os>RS4@~>
+endstream
+endobj
+234 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 233 0 R
+>>
+endobj
+235 0 obj
+<< /Length 1066 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"D/[lW&H:NniGWgo\p!F"ahEbNU`kDE<^6rci2'1a8F;MK/cGE'YE$5W$;Kf5(Z4&4HgW2`=0q!/!<Imo9Y`-I+g at ACJF"?^;#h2a8-2/q^hO+gc#8J+W3uPE"VsB<_'DJV"7mJqbP/"l4O:R#>$Z\$@.gZ3Jm_P>b0C&2$54&[!T*%8au*N:B(Qrs*&/:7Q"TpWmd>P.$3<WIp"1Ui'eHf=B[Bq1eU*4D+:Jo;=$j!ZA at +G%#=ub]XV`7e-]nI^+=!R%lN4X?A<7#F[jcRuMf49,S!A<_,\\_U*6$q@,XQ at bYj["@G at CUcM(k`FinJjm!qitsesPHC\_LhcKT?F5CKSi6+5MG1OEk!kH)7EZhS;.HN$T^qr(uR/@9Q1[m[3;!j<U;,o?G1B46XW[dA'VBXV3`Ls6KNH';ZS;X3k(Hq0kL#/sSLo(DF25+RCK7p at eI0LC*64'\i?ND&dVTkHc/JmW(\_nT]_PhNt4_FL_u[$*u0TrDTMh>,H#ZQ/d6X.&eZ^.Mb'>a*oP7[7r<5gT&d\RHT>ujt8=/e%F>4'L]m[]bXanWf5TH>ZSi*@6c&Mg\"SYU4JP8\Gc=Z_%;W9aKY-WP[^Z%E5E`-^<'MnV2+>-p=#"+4A*"D89(`'>Ic%hafBR8r,aT at hM[^i0Z0$$#M^MKDb6(+F"r)O66O8G@`XKVl_5^<$lum<T3fXig'P(@&`/58T3AL_]-9I6'EKA^>tmME at UEuM`YsbDJjS at lA\3^M93^De4?6EAQ/PW#PO_tV=tl*-pqkMkOY$Q\#"GV$&3fj6?1-ag=k(As^J'>:--mC(fZ;4"VjC?JL1,mXi4D#=;Y%l at m9XT^,Y8W$q3S3[im<cKd^GolUc<C+Hqh4?S_Q1$kf38YZ[7pibQiD:UX\_ZJAf/r2jI_F_=s5i(Rh[8f:0#=A\2q@`=B;VN;=mY>Cpr?8oC(a6VUq%B[h0*(:nJMl[#U\^RD02)EnJU2u24Ym!&=9f3jY:#`7Bs'G3DZ6TYiG:^W</50dK<c7^s\aZjYQKp)Z5gW!:)rESU$]4gOtrrl(X at NY~>
+endstream
+endobj
+236 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 235 0 R
+/Annots 237 0 R
+>>
+endobj
+237 0 obj
+[
+238 0 R
+239 0 R
+240 0 R
+241 0 R
+242 0 R
+243 0 R
+244 0 R
+]
+endobj
+238 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 352.0 687.572 373.66 677.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
+>>
+endobj
+239 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 381.047 687.572 451.607 677.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
+>>
+endobj
+240 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 532.89 676.572 564.57 666.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+241 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 571.85 676.572 586.29 666.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+242 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 665.572 280.52 655.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+243 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 178.61 654.572 194.16 644.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
+/S /URI >>
+/H /I
+>>
+endobj
+244 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 199.99 654.572 462.73 644.572 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
+/S /URI >>
+/H /I
+>>
+endobj
+245 0 obj
+<< /Length 293 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarnQ]2$6t']&^&GAN"?r-jS=&QCY6DnqH(8S'?1_$pKrO41H]6pb4_c9758]^t3e'Yl"u/&8WI_N?OFq(XQC.2_#?#n?k:YFDFBT$LF50&RcJF-\:`1m>67-=V?*%$aAkSQ'/o9fVhMC`.<SG#Nk_oap*qg at msug8]%nhLGL2'+;Qqs&Q47>g%9VrFjO-`BDH52e\$=>g;<H[Z78HC']T4612T5jkb5VIIuTAqPq_]Q7<U"JYW at X;*[uEC7lk+AEVS*I&Qgqq-1jYeA?aa.*Y^\\iKTla*(pb~>
+endstream
+endobj
+246 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 595 842 ]
+/Resources 3 0 R
+/Contents 245 0 R
+>>
+endobj
+249 0 obj
+<<
+ /Title (\376\377\0\125\0\106\0\106\0\111\0\40\0\122\0\145\0\146\0\145\0\162\0\145\0\156\0\143\0\145\0\40\0\107\0\165\0\151\0\144\0\145)
+ /Parent 247 0 R
+ /Next 251 0 R
+ /A 248 0 R
+>> endobj
+251 0 obj
+<<
+ /Title (\376\377\0\124\0\141\0\142\0\154\0\145\0\40\0\157\0\146\0\40\0\103\0\157\0\156\0\164\0\145\0\156\0\164\0\163)
+ /Parent 247 0 R
+ /Prev 249 0 R
+ /Next 252 0 R
+ /A 250 0 R
+>> endobj
+252 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\145\0\146\0\141\0\143\0\145)
+ /Parent 247 0 R
+ /Prev 251 0 R
+ /Next 253 0 R
+ /A 15 0 R
+>> endobj
+253 0 obj
+<<
+ /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\61\0\56\0\240\0\111\0\156\0\164\0\162\0\157\0\144\0\165\0\143\0\164\0\151\0\157\0\156)
+ /Parent 247 0 R
+ /First 254 0 R
+ /Last 257 0 R
+ /Prev 252 0 R
+ /Next 260 0 R
+ /Count -6
+ /A 17 0 R
+>> endobj
+254 0 obj
+<<
+ /Title (\376\377\0\120\0\165\0\162\0\160\0\157\0\163\0\145)
+ /Parent 253 0 R
+ /Next 255 0 R
+ /A 19 0 R
+>> endobj
+255 0 obj
+<<
+ /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144)
+ /Parent 253 0 R
+ /Prev 254 0 R
+ /Next 256 0 R
+ /A 21 0 R
+>> endobj
+256 0 obj
+<<
+ /Title (\376\377\0\123\0\165\0\160\0\160\0\157\0\162\0\164\0\145\0\144\0\40\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\163)
+ /Parent 253 0 R
+ /Prev 255 0 R
+ /Next 257 0 R
+ /A 23 0 R
+>> endobj
+257 0 obj
+<<
+ /Title (\376\377\0\104\0\145\0\163\0\151\0\147\0\156)
+ /Parent 253 0 R
+ /First 258 0 R
+ /Last 259 0 R
+ /Prev 256 0 R
+ /Count -2
+ /A 25 0 R
+>> endobj
+258 0 obj
+<<
+ /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167)
+ /Parent 257 0 R
+ /Next 259 0 R
+ /A 27 0 R
+>> endobj
+259 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\151\0\157\0\162\0\151\0\164\0\151\0\145\0\163)
+ /Parent 257 0 R
+ /Prev 258 0 R
+ /A 29 0 R
+>> endobj
+260 0 obj
+<<
+ /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\62\0\56\0\240\0\120\0\162\0\157\0\147\0\162\0\141\0\155\0\155\0\151\0\156\0\147\0\40\0\116\0\157\0\164\0\145\0\163)
+ /Parent 247 0 R
+ /First 261 0 R
+ /Last 266 0 R
+ /Prev 253 0 R
+ /Next 269 0 R
+ /Count -8
+ /A 31 0 R
+>> endobj
+261 0 obj
+<<
+ /Title (\376\377\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\123\0\160\0\145\0\143\0\151\0\146\0\151\0\143\0\40\0\116\0\157\0\164\0\145\0\163)
+ /Parent 260 0 R
+ /First 262 0 R
+ /Last 264 0 R
+ /Next 265 0 R
+ /Count -3
+ /A 33 0 R
+>> endobj
+262 0 obj
+<<
+ /Title (\376\377\0\101\0\154\0\154\0\145\0\147\0\162\0\157\0\103\0\114)
+ /Parent 261 0 R
+ /Next 263 0 R
+ /A 35 0 R
+>> endobj
+263 0 obj
+<<
+ /Title (\376\377\0\114\0\151\0\163\0\160\0\167\0\157\0\162\0\153\0\163)
+ /Parent 261 0 R
+ /Prev 262 0 R
+ /Next 264 0 R
+ /A 37 0 R
+>> endobj
+264 0 obj
+<<
+ /Title (\376\377\0\103\0\115\0\125\0\103\0\114)
+ /Parent 261 0 R
+ /Prev 263 0 R
+ /A 39 0 R
+>> endobj
+265 0 obj
+<<
+ /Title (\376\377\0\106\0\157\0\162\0\145\0\151\0\147\0\156\0\40\0\117\0\142\0\152\0\145\0\143\0\164\0\40\0\122\0\145\0\160\0\162\0\145\0\163\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\141\0\156\0\144\0\40\0\101\0\143\0\143\0\145\0\163\0\163)
+ /Parent 260 0 R
+ /Prev 261 0 R
+ /Next 266 0 R
+ /A 41 0 R
+>> endobj
+266 0 obj
+<<
+ /Title (\376\377\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\151\0\156\0\147\0\40\0\103\0\157\0\144\0\145\0\40\0\125\0\163\0\151\0\156\0\147\0\40\0\125\0\106\0\106\0\111)
+ /Parent 260 0 R
+ /First 267 0 R
+ /Last 268 0 R
+ /Prev 265 0 R
+ /Count -2
+ /A 43 0 R
+>> endobj
+267 0 obj
+<<
+ /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144)
+ /Parent 266 0 R
+ /Next 268 0 R
+ /A 45 0 R
+>> endobj
+268 0 obj
+<<
+ /Title (\376\377\0\103\0\162\0\157\0\163\0\163\0\55\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\141\0\164\0\151\0\157\0\156)
+ /Parent 266 0 R
+ /Prev 267 0 R
+ /A 47 0 R
+>> endobj
+269 0 obj
+<<
+ /Title (\376\377\0\104\0\145\0\143\0\154\0\141\0\162\0\141\0\164\0\151\0\157\0\156\0\163)
+ /Parent 247 0 R
+ /First 271 0 R
+ /Last 272 0 R
+ /Prev 260 0 R
+ /Next 273 0 R
+ /Count -2
+ /A 49 0 R
+>> endobj
+271 0 obj
+<<
+ /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167)
+ /Parent 269 0 R
+ /Next 272 0 R
+ /A 270 0 R
+>> endobj
+272 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\164\0\171\0\160\0\145)
+ /Parent 269 0 R
+ /Prev 271 0 R
+ /A 51 0 R
+>> endobj
+273 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\151\0\155\0\151\0\164\0\151\0\166\0\145\0\40\0\124\0\171\0\160\0\145\0\163)
+ /Parent 247 0 R
+ /First 274 0 R
+ /Last 276 0 R
+ /Prev 269 0 R
+ /Next 277 0 R
+ /Count -3
+ /A 53 0 R
+>> endobj
+274 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\143\0\157\0\156\0\163\0\164\0\141\0\156\0\164)
+ /Parent 273 0 R
+ /Next 275 0 R
+ /A 55 0 R
+>> endobj
+275 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145)
+ /Parent 273 0 R
+ /Prev 274 0 R
+ /Next 276 0 R
+ /A 57 0 R
+>> endobj
+276 0 obj
+<<
+ /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\143\0\150\0\141\0\162\0\55\0\160)
+ /Parent 273 0 R
+ /Prev 275 0 R
+ /A 59 0 R
+>> endobj
+277 0 obj
+<<
+ /Title (\376\377\0\101\0\147\0\147\0\162\0\145\0\147\0\141\0\164\0\145\0\40\0\124\0\171\0\160\0\145\0\163)
+ /Parent 247 0 R
+ /First 278 0 R
+ /Last 284 0 R
+ /Prev 273 0 R
+ /Next 285 0 R
+ /Count -7
+ /A 61 0 R
+>> endobj
+278 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\145\0\156\0\165\0\155)
+ /Parent 277 0 R
+ /Next 279 0 R
+ /A 63 0 R
+>> endobj
+279 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\163\0\164\0\162\0\165\0\143\0\164)
+ /Parent 277 0 R
+ /Prev 278 0 R
+ /Next 280 0 R
+ /A 65 0 R
+>> endobj
+280 0 obj
+<<
+ /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\166\0\141\0\154\0\165\0\145)
+ /Parent 277 0 R
+ /Prev 279 0 R
+ /Next 281 0 R
+ /A 67 0 R
+>> endobj
+281 0 obj
+<<
+ /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 277 0 R
+ /Prev 280 0 R
+ /Next 282 0 R
+ /A 69 0 R
+>> endobj
+282 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 277 0 R
+ /Prev 281 0 R
+ /Next 283 0 R
+ /A 71 0 R
+>> endobj
+283 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171)
+ /Parent 277 0 R
+ /Prev 282 0 R
+ /Next 284 0 R
+ /A 73 0 R
+>> endobj
+284 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\165\0\156\0\151\0\157\0\156)
+ /Parent 277 0 R
+ /Prev 283 0 R
+ /A 75 0 R
+>> endobj
+285 0 obj
+<<
+ /Title (\376\377\0\117\0\142\0\152\0\145\0\143\0\164\0\163)
+ /Parent 247 0 R
+ /First 286 0 R
+ /Last 298 0 R
+ /Prev 277 0 R
+ /Next 299 0 R
+ /Count -13
+ /A 77 0 R
+>> endobj
+286 0 obj
+<<
+ /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 285 0 R
+ /Next 287 0 R
+ /A 79 0 R
+>> endobj
+287 0 obj
+<<
+ /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 285 0 R
+ /Prev 286 0 R
+ /Next 288 0 R
+ /A 81 0 R
+>> endobj
+288 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 285 0 R
+ /Prev 287 0 R
+ /Next 289 0 R
+ /A 83 0 R
+>> endobj
+289 0 obj
+<<
+ /Title (\376\377\0\163\0\151\0\172\0\145\0\55\0\157\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145)
+ /Parent 285 0 R
+ /Prev 288 0 R
+ /Next 290 0 R
+ /A 85 0 R
+>> endobj
+290 0 obj
+<<
+ /Title (\376\377\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\141\0\144\0\144\0\162\0\145\0\163\0\163)
+ /Parent 285 0 R
+ /Prev 289 0 R
+ /Next 291 0 R
+ /A 87 0 R
+>> endobj
+291 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 285 0 R
+ /Prev 290 0 R
+ /Next 292 0 R
+ /A 89 0 R
+>> endobj
+292 0 obj
+<<
+ /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\143\0\150\0\141\0\162\0\141\0\143\0\164\0\145\0\162)
+ /Parent 285 0 R
+ /Prev 291 0 R
+ /Next 293 0 R
+ /A 91 0 R
+>> endobj
+293 0 obj
+<<
+ /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\151\0\156\0\164\0\145\0\147\0\145\0\162)
+ /Parent 285 0 R
+ /Prev 292 0 R
+ /Next 294 0 R
+ /A 93 0 R
+>> endobj
+294 0 obj
+<<
+ /Title (\376\377\0\155\0\141\0\153\0\145\0\55\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 285 0 R
+ /Prev 293 0 R
+ /Next 295 0 R
+ /A 95 0 R
+>> endobj
+295 0 obj
+<<
+ /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\160)
+ /Parent 285 0 R
+ /Prev 294 0 R
+ /Next 296 0 R
+ /A 97 0 R
+>> endobj
+296 0 obj
+<<
+ /Title (\376\377\0\53\0\156\0\165\0\154\0\154\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\53)
+ /Parent 285 0 R
+ /Prev 295 0 R
+ /Next 297 0 R
+ /A 99 0 R
+>> endobj
+297 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\141\0\163\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 285 0 R
+ /Prev 296 0 R
+ /Next 298 0 R
+ /A 101 0 R
+>> endobj
+298 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\166\0\141\0\162)
+ /Parent 285 0 R
+ /Prev 297 0 R
+ /A 103 0 R
+>> endobj
+299 0 obj
+<<
+ /Title (\376\377\0\123\0\164\0\162\0\151\0\156\0\147\0\163)
+ /Parent 247 0 R
+ /First 300 0 R
+ /Last 306 0 R
+ /Prev 285 0 R
+ /Next 307 0 R
+ /Count -7
+ /A 105 0 R
+>> endobj
+300 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Next 301 0 R
+ /A 107 0 R
+>> endobj
+301 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 300 0 R
+ /Next 302 0 R
+ /A 109 0 R
+>> endobj
+302 0 obj
+<<
+ /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 301 0 R
+ /Next 303 0 R
+ /A 111 0 R
+>> endobj
+303 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 302 0 R
+ /Next 304 0 R
+ /A 113 0 R
+>> endobj
+304 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 303 0 R
+ /Next 305 0 R
+ /A 115 0 R
+>> endobj
+305 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 304 0 R
+ /Next 306 0 R
+ /A 117 0 R
+>> endobj
+306 0 obj
+<<
+ /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 299 0 R
+ /Prev 305 0 R
+ /A 119 0 R
+>> endobj
+307 0 obj
+<<
+ /Title (\376\377\0\106\0\165\0\156\0\143\0\164\0\151\0\157\0\156\0\163\0\40\0\46\0\40\0\114\0\151\0\142\0\162\0\141\0\162\0\151\0\145\0\163)
+ /Parent 247 0 R
+ /First 308 0 R
+ /Last 310 0 R
+ /Prev 299 0 R
+ /Next 311 0 R
+ /Count -3
+ /A 121 0 R
+>> endobj
+308 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\165\0\156\0\143\0\164\0\151\0\157\0\156)
+ /Parent 307 0 R
+ /Next 309 0 R
+ /A 123 0 R
+>> endobj
+309 0 obj
+<<
+ /Title (\376\377\0\154\0\157\0\141\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171)
+ /Parent 307 0 R
+ /Prev 308 0 R
+ /Next 310 0 R
+ /A 125 0 R
+>> endobj
+310 0 obj
+<<
+ /Title (\376\377\0\146\0\151\0\156\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171)
+ /Parent 307 0 R
+ /Prev 309 0 R
+ /A 127 0 R
+>> endobj
+311 0 obj
+<<
+ /Title (\376\377\0\101\0\160\0\160\0\145\0\156\0\144\0\151\0\170\0\240\0\101\0\56\0\240\0\111\0\156\0\163\0\164\0\141\0\154\0\154\0\141\0\164\0\151\0\157\0\156)
+ /Parent 247 0 R
+ /First 312 0 R
+ /Last 313 0 R
+ /Prev 307 0 R
+ /Next 314 0 R
+ /Count -2
+ /A 132 0 R
+>> endobj
+312 0 obj
+<<
+ /Title (\376\377\0\104\0\157\0\167\0\156\0\154\0\157\0\141\0\144\0\40\0\125\0\106\0\106\0\111)
+ /Parent 311 0 R
+ /Next 313 0 R
+ /A 134 0 R
+>> endobj
+313 0 obj
+<<
+ /Title (\376\377\0\114\0\157\0\141\0\144\0\151\0\156\0\147)
+ /Parent 311 0 R
+ /Prev 312 0 R
+ /A 136 0 R
+>> endobj
+314 0 obj
+<<
+ /Title (\376\377\0\107\0\154\0\157\0\163\0\163\0\141\0\162\0\171)
+ /Parent 247 0 R
+ /Prev 311 0 R
+ /A 138 0 R
+>> endobj
+315 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F3
+/BaseFont /Helvetica-Bold
+/Encoding /WinAnsiEncoding >>
+endobj
+316 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F5
+/BaseFont /Times-Roman
+/Encoding /WinAnsiEncoding >>
+endobj
+317 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F10
+/BaseFont /Courier-Oblique
+/Encoding /WinAnsiEncoding >>
+endobj
+318 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F1
+/BaseFont /Helvetica
+/Encoding /WinAnsiEncoding >>
+endobj
+319 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F6
+/BaseFont /Times-Italic
+/Encoding /WinAnsiEncoding >>
+endobj
+320 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F4
+/BaseFont /Helvetica-BoldOblique
+/Encoding /WinAnsiEncoding >>
+endobj
+321 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F9
+/BaseFont /Courier
+/Encoding /WinAnsiEncoding >>
+endobj
+322 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F7
+/BaseFont /Times-Bold
+/Encoding /WinAnsiEncoding >>
+endobj
+1 0 obj
+<< /Type /Pages
+/Count 55
+/Kids [6 0 R 8 0 R 10 0 R 12 0 R 129 0 R 140 0 R 142 0 R 144 0 R 146 0 R 148 0 R 150 0 R 152 0 R 154 0 R 156 0 R 158 0 R 160 0 R 162 0 R 164 0 R 166 0 R 168 0 R 170 0 R 172 0 R 174 0 R 176 0 R 178 0 R 180 0 R 182 0 R 184 0 R 186 0 R 188 0 R 190 0 R 192 0 R 194 0 R 196 0 R 198 0 R 200 0 R 202 0 R 204 0 R 206 0 R 208 0 R 210 0 R 212 0 R 214 0 R 216 0 R 218 0 R 220 0 R 222 0 R 224 0 R 226 0 R 228 0 R 230 0 R 232 0 R 234 0 R 236 0 R 246 0 R ] >>
+endobj
+2 0 obj
+<< /Type /Catalog
+/Pages 1 0 R
+ /Outlines 247 0 R
+ /PageMode /UseOutlines
+ /Names << /Dests << /Names [  (preface) [ 140 0 R /XYZ 115.0 774.889 null ] (introduction) [ 142 0 R /XYZ 115.0 774.889 null ] (notes) [ 146 0 R /XYZ 115.0 774.889 null ] (ref_declarations) [ 150 0 R /XYZ 115.0 774.889 null ] (primitives) [ 154 0 R /XYZ 115.0 774.889 null ] (aggregates) [ 162 0 R /XYZ 115.0 774.889 null ] (objects) [ 178 0 R /XYZ 115.0 774.889 null ] (strings) [ 208 0 R /XYZ 115.0 774.889 null ] (func_libr) [ 226 0 R /XYZ 115.0 774.889 null ] (installation) [ 236 0 R /XYZ 115.0 774.889 null ] (glossary) [ 246 0 R /XYZ 115.0 774.889 null ] (id2463880) [ 10 0 R /XYZ 115.0 774.889 null ] ] >> >>
+ >>
+endobj
+3 0 obj
+<< 
+/Font << /F3 315 0 R /F5 316 0 R /F10 317 0 R /F6 319 0 R /F1 318 0 R /F4 320 0 R /F9 321 0 R /F7 322 0 R >> 
+/ProcSet [ /PDF /ImageC /Text ] >> 
+endobj
+15 0 obj
+<<
+/S /GoTo
+/D [140 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+17 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+19 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 736.898 null]
+>>
+endobj
+21 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 671.572 null]
+>>
+endobj
+23 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 509.246 null]
+>>
+endobj
+25 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 246.92 null]
+>>
+endobj
+27 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 213.594 null]
+>>
+endobj
+29 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 130.155 null]
+>>
+endobj
+31 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+33 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 736.898 null]
+>>
+endobj
+35 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 693.572 null]
+>>
+endobj
+37 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 654.133 null]
+>>
+endobj
+39 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 614.694 null]
+>>
+endobj
+41 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 575.255 null]
+>>
+endobj
+43 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 443.929 null]
+>>
+endobj
+45 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 410.603 null]
+>>
+endobj
+47 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 252.164 null]
+>>
+endobj
+49 0 obj
+<<
+/S /GoTo
+/D [150 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+51 0 obj
+<<
+/S /GoTo
+/D [152 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+53 0 obj
+<<
+/S /GoTo
+/D [154 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+55 0 obj
+<<
+/S /GoTo
+/D [156 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+57 0 obj
+<<
+/S /GoTo
+/D [158 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+59 0 obj
+<<
+/S /GoTo
+/D [160 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+61 0 obj
+<<
+/S /GoTo
+/D [162 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+63 0 obj
+<<
+/S /GoTo
+/D [164 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+65 0 obj
+<<
+/S /GoTo
+/D [166 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+67 0 obj
+<<
+/S /GoTo
+/D [168 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+69 0 obj
+<<
+/S /GoTo
+/D [170 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+71 0 obj
+<<
+/S /GoTo
+/D [172 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+73 0 obj
+<<
+/S /GoTo
+/D [174 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+75 0 obj
+<<
+/S /GoTo
+/D [176 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+77 0 obj
+<<
+/S /GoTo
+/D [178 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+79 0 obj
+<<
+/S /GoTo
+/D [180 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+81 0 obj
+<<
+/S /GoTo
+/D [182 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+83 0 obj
+<<
+/S /GoTo
+/D [184 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+85 0 obj
+<<
+/S /GoTo
+/D [186 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+87 0 obj
+<<
+/S /GoTo
+/D [188 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+89 0 obj
+<<
+/S /GoTo
+/D [190 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+91 0 obj
+<<
+/S /GoTo
+/D [192 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+93 0 obj
+<<
+/S /GoTo
+/D [194 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+95 0 obj
+<<
+/S /GoTo
+/D [196 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+97 0 obj
+<<
+/S /GoTo
+/D [198 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+99 0 obj
+<<
+/S /GoTo
+/D [200 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+101 0 obj
+<<
+/S /GoTo
+/D [202 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+103 0 obj
+<<
+/S /GoTo
+/D [204 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+105 0 obj
+<<
+/S /GoTo
+/D [208 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+107 0 obj
+<<
+/S /GoTo
+/D [212 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+109 0 obj
+<<
+/S /GoTo
+/D [214 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+111 0 obj
+<<
+/S /GoTo
+/D [216 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+113 0 obj
+<<
+/S /GoTo
+/D [218 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+115 0 obj
+<<
+/S /GoTo
+/D [220 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+117 0 obj
+<<
+/S /GoTo
+/D [222 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+119 0 obj
+<<
+/S /GoTo
+/D [224 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+121 0 obj
+<<
+/S /GoTo
+/D [226 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+123 0 obj
+<<
+/S /GoTo
+/D [228 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+125 0 obj
+<<
+/S /GoTo
+/D [230 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+127 0 obj
+<<
+/S /GoTo
+/D [234 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+132 0 obj
+<<
+/S /GoTo
+/D [236 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+134 0 obj
+<<
+/S /GoTo
+/D [236 0 R /XYZ 115.0 736.898 null]
+>>
+endobj
+136 0 obj
+<<
+/S /GoTo
+/D [236 0 R /XYZ 115.0 649.572 null]
+>>
+endobj
+138 0 obj
+<<
+/S /GoTo
+/D [246 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+247 0 obj
+<<
+ /First 249 0 R
+ /Last 314 0 R
+>> endobj
+248 0 obj
+<<
+/S /GoTo
+/D [10 0 R /XYZ 115.0 774.889 null]
+>>
+endobj
+250 0 obj
+<<
+/S /GoTo
+/D [12 0 R /XYZ 115.0 764.889 null]
+>>
+endobj
+270 0 obj
+<<
+/S /GoTo
+/D [150 0 R /XYZ 115.0 728.236 null]
+>>
+endobj
+xref
+0 323
+0000000000 65535 f 
+0000085208 00000 n 
+0000085695 00000 n 
+0000086406 00000 n 
+0000000015 00000 n 
+0000000071 00000 n 
+0000000363 00000 n 
+0000000469 00000 n 
+0000001525 00000 n 
+0000001631 00000 n 
+0000001802 00000 n 
+0000001909 00000 n 
+0000004069 00000 n 
+0000004192 00000 n 
+0000004625 00000 n 
+0000086571 00000 n 
+0000004759 00000 n 
+0000086639 00000 n 
+0000004893 00000 n 
+0000086707 00000 n 
+0000005027 00000 n 
+0000086775 00000 n 
+0000005161 00000 n 
+0000086843 00000 n 
+0000005295 00000 n 
+0000086911 00000 n 
+0000005429 00000 n 
+0000086978 00000 n 
+0000005563 00000 n 
+0000087046 00000 n 
+0000005697 00000 n 
+0000087114 00000 n 
+0000005831 00000 n 
+0000087182 00000 n 
+0000005965 00000 n 
+0000087250 00000 n 
+0000006099 00000 n 
+0000087318 00000 n 
+0000006233 00000 n 
+0000087386 00000 n 
+0000006367 00000 n 
+0000087454 00000 n 
+0000006501 00000 n 
+0000087522 00000 n 
+0000006635 00000 n 
+0000087590 00000 n 
+0000006769 00000 n 
+0000087658 00000 n 
+0000006903 00000 n 
+0000087726 00000 n 
+0000007037 00000 n 
+0000087794 00000 n 
+0000007171 00000 n 
+0000087862 00000 n 
+0000007305 00000 n 
+0000087930 00000 n 
+0000007439 00000 n 
+0000087998 00000 n 
+0000007573 00000 n 
+0000088066 00000 n 
+0000007707 00000 n 
+0000088134 00000 n 
+0000007841 00000 n 
+0000088202 00000 n 
+0000007975 00000 n 
+0000088270 00000 n 
+0000008109 00000 n 
+0000088338 00000 n 
+0000008243 00000 n 
+0000088406 00000 n 
+0000008377 00000 n 
+0000088474 00000 n 
+0000008510 00000 n 
+0000088542 00000 n 
+0000008644 00000 n 
+0000088610 00000 n 
+0000008778 00000 n 
+0000088678 00000 n 
+0000008911 00000 n 
+0000088746 00000 n 
+0000009045 00000 n 
+0000088814 00000 n 
+0000009179 00000 n 
+0000088882 00000 n 
+0000009313 00000 n 
+0000088950 00000 n 
+0000009447 00000 n 
+0000089018 00000 n 
+0000009581 00000 n 
+0000089086 00000 n 
+0000009714 00000 n 
+0000089154 00000 n 
+0000009848 00000 n 
+0000089222 00000 n 
+0000009982 00000 n 
+0000089290 00000 n 
+0000010116 00000 n 
+0000089358 00000 n 
+0000010250 00000 n 
+0000089426 00000 n 
+0000010384 00000 n 
+0000089494 00000 n 
+0000010520 00000 n 
+0000089563 00000 n 
+0000010656 00000 n 
+0000089632 00000 n 
+0000010792 00000 n 
+0000089701 00000 n 
+0000010928 00000 n 
+0000089770 00000 n 
+0000011064 00000 n 
+0000089839 00000 n 
+0000011200 00000 n 
+0000089908 00000 n 
+0000011336 00000 n 
+0000089977 00000 n 
+0000011472 00000 n 
+0000090046 00000 n 
+0000011608 00000 n 
+0000090115 00000 n 
+0000011744 00000 n 
+0000090184 00000 n 
+0000011880 00000 n 
+0000090253 00000 n 
+0000012016 00000 n 
+0000090322 00000 n 
+0000012150 00000 n 
+0000090391 00000 n 
+0000012284 00000 n 
+0000012772 00000 n 
+0000012898 00000 n 
+0000012951 00000 n 
+0000090460 00000 n 
+0000013089 00000 n 
+0000090529 00000 n 
+0000013227 00000 n 
+0000090598 00000 n 
+0000013365 00000 n 
+0000090667 00000 n 
+0000013503 00000 n 
+0000014186 00000 n 
+0000014296 00000 n 
+0000016420 00000 n 
+0000016530 00000 n 
+0000017619 00000 n 
+0000017729 00000 n 
+0000020274 00000 n 
+0000020384 00000 n 
+0000020779 00000 n 
+0000020889 00000 n 
+0000021450 00000 n 
+0000021560 00000 n 
+0000022473 00000 n 
+0000022583 00000 n 
+0000023923 00000 n 
+0000024033 00000 n 
+0000025087 00000 n 
+0000025197 00000 n 
+0000026036 00000 n 
+0000026146 00000 n 
+0000027352 00000 n 
+0000027462 00000 n 
+0000027848 00000 n 
+0000027958 00000 n 
+0000029818 00000 n 
+0000029928 00000 n 
+0000031064 00000 n 
+0000031174 00000 n 
+0000032120 00000 n 
+0000032230 00000 n 
+0000033141 00000 n 
+0000033251 00000 n 
+0000034014 00000 n 
+0000034124 00000 n 
+0000035361 00000 n 
+0000035471 00000 n 
+0000036452 00000 n 
+0000036562 00000 n 
+0000036960 00000 n 
+0000037070 00000 n 
+0000038119 00000 n 
+0000038229 00000 n 
+0000038919 00000 n 
+0000039029 00000 n 
+0000040389 00000 n 
+0000040499 00000 n 
+0000041409 00000 n 
+0000041519 00000 n 
+0000042223 00000 n 
+0000042333 00000 n 
+0000043487 00000 n 
+0000043597 00000 n 
+0000044763 00000 n 
+0000044873 00000 n 
+0000045978 00000 n 
+0000046088 00000 n 
+0000046872 00000 n 
+0000046982 00000 n 
+0000047731 00000 n 
+0000047841 00000 n 
+0000048372 00000 n 
+0000048482 00000 n 
+0000050183 00000 n 
+0000050293 00000 n 
+0000051885 00000 n 
+0000051995 00000 n 
+0000052564 00000 n 
+0000052674 00000 n 
+0000054966 00000 n 
+0000055076 00000 n 
+0000055332 00000 n 
+0000055442 00000 n 
+0000056246 00000 n 
+0000056356 00000 n 
+0000057164 00000 n 
+0000057274 00000 n 
+0000058020 00000 n 
+0000058130 00000 n 
+0000059272 00000 n 
+0000059382 00000 n 
+0000060465 00000 n 
+0000060575 00000 n 
+0000061335 00000 n 
+0000061445 00000 n 
+0000062425 00000 n 
+0000062535 00000 n 
+0000062831 00000 n 
+0000062941 00000 n 
+0000064472 00000 n 
+0000064582 00000 n 
+0000066453 00000 n 
+0000066563 00000 n 
+0000066913 00000 n 
+0000067023 00000 n 
+0000068445 00000 n 
+0000068555 00000 n 
+0000069715 00000 n 
+0000069841 00000 n 
+0000069918 00000 n 
+0000070088 00000 n 
+0000070261 00000 n 
+0000070455 00000 n 
+0000070649 00000 n 
+0000070842 00000 n 
+0000071062 00000 n 
+0000071282 00000 n 
+0000071668 00000 n 
+0000090736 00000 n 
+0000090790 00000 n 
+0000071778 00000 n 
+0000090858 00000 n 
+0000071982 00000 n 
+0000072183 00000 n 
+0000072325 00000 n 
+0000072603 00000 n 
+0000072730 00000 n 
+0000072890 00000 n 
+0000073139 00000 n 
+0000073302 00000 n 
+0000073435 00000 n 
+0000073580 00000 n 
+0000073887 00000 n 
+0000074186 00000 n 
+0000074325 00000 n 
+0000074479 00000 n 
+0000074594 00000 n 
+0000074930 00000 n 
+0000075210 00000 n 
+0000075355 00000 n 
+0000075636 00000 n 
+0000090926 00000 n 
+0000075850 00000 n 
+0000075984 00000 n 
+0000076116 00000 n 
+0000076347 00000 n 
+0000076503 00000 n 
+0000076697 00000 n 
+0000076846 00000 n 
+0000077077 00000 n 
+0000077209 00000 n 
+0000077368 00000 n 
+0000077550 00000 n 
+0000077744 00000 n 
+0000077944 00000 n 
+0000078109 00000 n 
+0000078247 00000 n 
+0000078432 00000 n 
+0000078653 00000 n 
+0000078865 00000 n 
+0000079077 00000 n 
+0000079294 00000 n 
+0000079483 00000 n 
+0000079660 00000 n 
+0000079884 00000 n 
+0000080096 00000 n 
+0000080296 00000 n 
+0000080478 00000 n 
+0000080706 00000 n 
+0000080907 00000 n 
+0000081081 00000 n 
+0000081266 00000 n 
+0000081470 00000 n 
+0000081677 00000 n 
+0000081849 00000 n 
+0000082021 00000 n 
+0000082281 00000 n 
+0000082529 00000 n 
+0000082751 00000 n 
+0000083017 00000 n 
+0000083174 00000 n 
+0000083393 00000 n 
+0000083597 00000 n 
+0000083883 00000 n 
+0000084046 00000 n 
+0000084174 00000 n 
+0000084308 00000 n 
+0000084422 00000 n 
+0000084533 00000 n 
+0000084649 00000 n 
+0000084758 00000 n 
+0000084870 00000 n 
+0000084991 00000 n 
+0000085098 00000 n 
+trailer
+<<
+/Size 323
+/Root 2 0 R
+/Info 4 0 R
+>>
+startxref
+90995
+%%EOF

Added: branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/uffi.xml	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,24 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+<!ENTITY % xinclude SYSTEM "xinclude.mod">
+%myents;
+%xinclude;
+]>
+
+
+<book lang="en">
+  <xi:include href="bookinfo.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="preface.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="intro.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="notes.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_declare.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_primitive.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_aggregate.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_object.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_string.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_func_libr.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="appendix.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="glossary.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+</book>

Added: branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/doc/xinclude.mod	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,24 @@
+<!ELEMENT xi:include (xi:fallback?) >
+<!ATTLIST xi:include
+    xmlns:xi   CDATA       #FIXED    "http://www.w3.org/2001/XInclude"
+    href       CDATA       #REQUIRED
+    parse      (xml|text)  "xml"
+    encoding   CDATA       #IMPLIED >
+
+<!ELEMENT xi:fallback ANY>
+<!ATTLIST xi:fallback
+    xmlns:xi   CDATA   #FIXED   "http://www.w3.org/2001/XInclude" >
+
+<!ENTITY % local.book.class "| xi:include">
+
+<!-- inside book elements -->
+<!ENTITY % local.chapter.class "| xi:include">
+<!-- inside chapter or section elements -->
+<!ENTITY % local.divcomponent.mix "| xi:include">
+<!-- inside para, programlisting, literallayout, etc. -->   
+<!ENTITY % local.para.char.mix "| xi:include">
+<!-- inside bookinfo, chapterinfo, etc. -->      
+<!ENTITY % local.info.class "| xi:include">         
+
+<!-- used for xml:base in docbook 4.2 and prior -->
+<!ENTITY % local.common.attrib "xml:base  CDATA  #IMPLIED">

Added: branches/trunk-reorg/thirdparty/uffi/examples/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,45 @@
+# FILE IDENTIFICATION
+#
+#  Name:         Makefile
+#  Purpose:      Makefile for UFFI examples
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id$
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+#
+
+SUBDIRS:=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
+
+
+base=c-test-fns
+source=$(base).c
+object=$(base).o
+shared_lib=$(base).so
+
+.PHONY: all
+all: $(shared_lib)
+
+linux: $(source) Makefile
+	gcc -fPIC -DPIC -c $(source) -o $(object)
+	gcc -shared $(object) -o $(shared_lib)
+	rm $(object)
+
+mac:
+	cc -dynamic -c $(source) -o $(object)
+	ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $(base).dylib $(object)
+	ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib
+
+solaris:
+	cc -KPIC -c $(source) -o $(object)
+	cc -G $(object) -o $(shared_lib)
+
+aix-acl:
+	gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source)
+	make_shared -o $(shared_lib) $(object)

Added: branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/Makefile.msvc	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,27 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile.msvc
+#  Purpose:      Makefile for the CLSQL UFFI helper package (MSVC)
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $
+#
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+BASE=c-test-fns
+
+# Nothing to configure beyond here
+
+SRC=$(BASE).c
+OBJ=$(BASE).obj
+DLL=$(BASE).dll
+
+$(DLL): $(SRC)
+	cl /MD /LD -D_MT /DWIN32=1 $(SRC)
+        del $(OBJ) $(BASE).exp
+
+clean:
+        del /q $(DLL)
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/acl-compat-tester.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,600 @@
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by
+;; the Free Software Foundation, as clarified by the Franz
+;; preamble to the LGPL found in
+;; http://opensource.franz.com/preamble.html.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License can be
+;; found at http://opensource.franz.com/license.html.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple
+;; Place, Suite 330, Boston, MA  02111-1307  USA
+;;
+;;;; from the original ACL 6.1 sources:
+;; $Id$
+
+
+(defpackage :util.test
+  (:use :common-lisp)
+  (:shadow #:test)
+  (:export
+;;;; Control variables:
+   #:*break-on-test-failures*
+   #:*error-protect-tests*
+   #:*test-errors*
+   #:*test-successes*
+   #:*test-unexpected-failures*
+
+;;;; The test macros:
+   #:test
+   #:test-error
+   #:test-no-error
+   #:test-warning
+   #:test-no-warning
+
+   #:with-tests
+   ))
+
+(in-package :util.test)
+
+#+cmu
+(unless (find-class 'break nil)
+  (define-condition break (simple-condition) ()))
+
+(define-condition simple-break (error simple-condition) ())
+
+;; 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.
+
+(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 , at 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 , at 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) , at col) totalcol))))
+             ((eq state :compl)
+              (cond ((not (string-equal lookat "elseif"))
+                     (error "if*: missing elseif clause ")))
+              (setq state :init)))))
+
+
+
+
+(defvar *break-on-test-failures* nil
+  "When a test failure occurs, common-lisp:break is called, allowing
+interactive debugging of the failure.")
+
+(defvar *test-errors* 0
+  "The value is the number of test errors which have occurred.")
+(defvar *test-successes* 0
+  "The value is the number of test successes which have occurred.")
+(defvar *test-unexpected-failures* 0
+  "The value is the number of unexpected test failures which have occurred.")
+
+(defvar *error-protect-tests* nil
+  "Protect each test from errors.  If an error occurs, then that will be
+taken as a test failure unless test-error is being used.")
+
+(defmacro test-values-errorset (form &optional announce catch-breaks)
+  ;; internal macro
+  (let ((g-announce (gensym))
+        (g-catch-breaks (gensym)))
+    `(let* ((,g-announce ,announce)
+            (,g-catch-breaks ,catch-breaks))
+       (handler-case (cons t (multiple-value-list ,form))
+         (condition (condition)
+           (if* (and (null ,g-catch-breaks)
+                     (typep condition 'simple-break))
+              then (break condition)
+            elseif ,g-announce
+              then (format *error-output* "~&Condition type: ~a~%"
+                           (class-of condition))
+                   (format *error-output* "~&Message: ~a~%" condition))
+           condition)))))
+
+(defmacro test-values (form &optional announce catch-breaks)
+  ;; internal macro
+  (if* *error-protect-tests*
+     then `(test-values-errorset ,form ,announce ,catch-breaks)
+     else `(cons t (multiple-value-list ,form))))
+
+(defmacro test (expected-value test-form
+                &key (test #'eql test-given)
+                     (multiple-values nil multiple-values-given)
+                     (fail-info nil fail-info-given)
+                     (known-failure nil known-failure-given)
+
+;;;;;;;;;; internal, undocumented keywords:
+;;;; Note about these keywords: if they were documented, we'd have a
+;;;; problem, since they break the left-to-right order of evaluation.
+;;;; Specifically, errorset breaks it, and I don't see any way around
+;;;; that.  `errorset' is used by the old test.cl module (eg,
+;;;; test-equal-errorset).
+                     errorset
+                     reported-form
+                     (wanted-message nil wanted-message-given)
+                     (got-message nil got-message-given))
+  "Perform a single test.  `expected-value' is the reference value for the
+test.  `test-form' is a form that will produce the value to be compared to
+the expected-value.  If the values are not the same, then an error is
+logged, otherwise a success is logged.
+
+Normally the comparison of values is done with `eql'.  The `test' keyword
+argument can be used to specify other comparison functions, such as eq,
+equal,equalp, string=, string-equal, etc.
+
+Normally, only the first return value from the test-form is considered,
+however if `multiple-values' is t, then all values returned from test-form
+are considered.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  `(test-check
+    :expected-result ,expected-value
+    :test-results
+    (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
+    ,@(when test-given `(:predicate ,test))
+    ,@(when multiple-values-given `(:multiple-values ,multiple-values))
+    ,@(when fail-info-given `(:fail-info ,fail-info))
+    ,@(when known-failure-given `(:known-failure ,known-failure))
+    :test-form ',(if reported-form reported-form test-form)
+    ,@(when wanted-message-given `(:wanted-message ,wanted-message))
+    ,@(when got-message-given `(:got-message ,got-message))))
+
+(defmethod conditionp ((thing condition)) t)
+(defmethod conditionp ((thing t)) nil)
+
+(defmacro test-error (form &key announce
+                                catch-breaks
+                                (fail-info nil fail-info-given)
+                                (known-failure nil known-failure-given)
+                                (condition-type ''simple-error)
+                                (include-subtypes nil include-subtypes-given)
+                                (format-control nil format-control-given)
+                                (format-arguments nil format-arguments-given))
+  "Test that `form' signals an error. The order of evaluation of the
+arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures.
+
+If `condition-type' is non-nil, it should be a symbol naming a condition
+type, which is used to check against the signalled condition type.  The
+test will fail if they do not match.
+
+`include-subtypes', used with `condition-type', can be used to match a
+condition to an entire subclass of the condition type hierarchy.
+
+`format-control' and `format-arguments' can be used to check the error
+message itself."
+  (let ((g-announce (gensym))
+        (g-catch-breaks (gensym))
+        (g-fail-info (gensym))
+        (g-known-failure (gensym))
+        (g-condition-type (gensym))
+        (g-include-subtypes (gensym))
+        (g-format-control (gensym))
+        (g-format-arguments (gensym))
+        (g-c (gensym)))
+    `(let* ((,g-announce ,announce)
+            (,g-catch-breaks ,catch-breaks)
+            ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+            ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+            (,g-condition-type ,condition-type)
+            ,@(when include-subtypes-given
+                `((,g-include-subtypes ,include-subtypes)))
+            ,@(when format-control-given
+                `((,g-format-control ,format-control)))
+            ,@(when format-arguments-given
+                `((,g-format-arguments ,format-arguments)))
+            (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+       (test-check
+        :predicate #'eq
+        :expected-result t
+        :test-results
+        (test-values (and (conditionp ,g-c)
+                          ,@(if* include-subtypes-given
+                               then `((if* ,g-include-subtypes
+                                         then (typep ,g-c ,g-condition-type)
+                                         else (eq (class-of ,g-c)
+                                                  (find-class
+                                                   ,g-condition-type))))
+                               else `((eq (class-of ,g-c)
+                                          (find-class ,g-condition-type))))
+                          ,@(when format-control-given
+                              `((or
+                                 (null ,g-format-control)
+                                 (string=
+                                  (concatenate 'simple-string
+                                    "~1@<" ,g-format-control "~:@>")
+                                  (simple-condition-format-control ,g-c)))))
+                          ,@(when format-arguments-given
+                              `((or
+                                 (null ,g-format-arguments)
+                                 (equal
+                                  ,g-format-arguments
+                                  (simple-condition-format-arguments ,g-c))))))
+                     t)
+        :test-form ',form
+        ,@(when fail-info-given `(:fail-info ,g-fail-info))
+        ,@(when known-failure-given `(:known-failure ,g-known-failure))
+        :condition-type ,g-condition-type
+        :condition ,g-c
+        ,@(when include-subtypes-given
+            `(:include-subtypes ,g-include-subtypes))
+        ,@(when format-control-given
+            `(:format-control ,g-format-control))
+        ,@(when format-arguments-given
+            `(:format-arguments ,g-format-arguments))))))
+
+(defmacro test-no-error (form &key announce
+                                   catch-breaks
+                                   (fail-info nil fail-info-given)
+                                   (known-failure nil known-failure-given))
+  "Test that `form' does not signal an error.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-announce (gensym))
+        (g-catch-breaks (gensym))
+        (g-fail-info (gensym))
+        (g-known-failure (gensym))
+        (g-c (gensym)))
+    `(let* ((,g-announce ,announce)
+            (,g-catch-breaks ,catch-breaks)
+            ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+            ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+            (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+       (test-check
+        :predicate #'eq
+        :expected-result t
+        :test-results (test-values (not (conditionp ,g-c)))
+        :test-form ',form
+        :condition ,g-c
+        ,@(when fail-info-given `(:fail-info ,g-fail-info))
+        ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
+
+(defvar *warn-cookie* (cons nil nil))
+
+(defmacro test-warning (form &key fail-info known-failure)
+  "Test that `form' signals a warning.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-fail-info (gensym))
+        (g-known-failure (gensym))
+        (g-value (gensym)))
+    `(let* ((,g-fail-info ,fail-info)
+            (,g-known-failure ,known-failure)
+            (,g-value (test-values-errorset ,form nil t)))
+       (test
+        *warn-cookie*
+        (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+           then *warn-cookie*
+           else ;; test produced no warning
+                nil)
+        :test #'eq
+        :reported-form ,form ;; quoted by test macro
+        :wanted-message "a warning"
+        :got-message "no warning"
+        :fail-info ,g-fail-info
+        :known-failure ,g-known-failure))))
+
+(defmacro test-no-warning (form &key fail-info known-failure)
+  "Test that `form' does not signal a warning.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-fail-info (gensym))
+        (g-known-failure (gensym))
+        (g-value (gensym)))
+    `(let* ((,g-fail-info ,fail-info)
+            (,g-known-failure ,known-failure)
+            (,g-value (test-values-errorset ,form nil t)))
+       (test
+        *warn-cookie*
+        (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+           then nil ;; test produced warning
+           else *warn-cookie*)
+        :test #'eq
+        :reported-form ',form
+        :wanted-message "no warning"
+        :got-message "a warning"
+        :fail-info ,g-fail-info
+        :known-failure ,g-known-failure))))
+
+(defvar *announce-test* nil) ;; if true announce each test that was done
+
+(defmacro errorset (form &optional announce catch-breaks)
+  ;; Evaluate FORM, and if there are no errors and FORM returns
+  ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn.  If an
+  ;; error occurs while evaluating FORM, then return nil immediately.
+  ;; If ANNOUNCE is t, then the error message will be printed out.
+  (if catch-breaks
+      `(handler-case (values-list (cons t (multiple-value-list ,form)))
+         (error (condition)
+           (declare (ignorable condition))
+           ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+           nil)
+         (simple-break (condition)
+           (declare (ignorable condition))
+           ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
+)
+           nil))
+    `(handler-case (values-list (cons t (multiple-value-list ,form)))
+       (error (condition)
+         (declare (ignorable condition))
+         ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+         nil))))
+
+(defun test-check (&key (predicate #'eql)
+                        expected-result test-results test-form
+                        multiple-values fail-info known-failure
+                        wanted-message got-message condition-type condition
+                        include-subtypes format-control format-arguments
+                   &aux fail predicate-failed got wanted)
+  ;; for debugging large/complex test sets:
+  (when *announce-test*
+    (format t "Just did test ~s~%" test-form)
+    (force-output))
+
+  ;; this is an internal function
+  (flet ((check (expected-result result)
+           (let* ((results
+                   (multiple-value-list
+                    (errorset (funcall predicate expected-result result) t)))
+                  (failed (null (car results))))
+             (if* failed
+                then (setq predicate-failed t)
+                     nil
+                else (cadr results)))))
+    (when (conditionp test-results)
+      (setq condition test-results)
+      (setq test-results nil))
+    (when (null (car test-results))
+      (setq fail t))
+    (if* (and (not fail) (not multiple-values))
+       then ;; should be a single result
+            ;; expected-result is the single result wanted
+            (when (not (and (cdr test-results)
+                            (check expected-result (cadr test-results))))
+              (setq fail t))
+            (when (and (not fail) (cddr test-results))
+              (setq fail 'single-got-multiple))
+       else ;; multiple results wanted
+            ;; expected-result is a list of results, each of which
+            ;; should be checked against the corresponding test-results
+            ;; using the predicate
+            (do ((got (cdr test-results) (cdr got))
+                 (want expected-result (cdr want)))
+                ((or (null got) (null want))
+                 (when (not (and (null want) (null got)))
+                   (setq fail t)))
+              (when (not (check (car got) (car want)))
+                (return (setq fail t)))))
+    (if* fail
+       then (when (not known-failure)
+              (format *error-output*
+                      "~& * * * UNEXPECTED TEST FAILURE * * *~%")
+              (incf *test-unexpected-failures*))
+            (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
+                    known-failure test-form)
+            (if* (eq 'single-got-multiple fail)
+               then (format
+                     *error-output*
+                     "~
+Reason: additional value were returned from test form.~%")
+             elseif predicate-failed
+               then (format *error-output* "Reason: predicate error.~%")
+             elseif (null (car test-results))
+               then (format *error-output* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
+                            (when condition (class-of condition)))
+             elseif condition
+               then (if* (not (conditionp condition))
+                       then (format *error-output* "~
+Reason: expected but did not detect an error of type `~s'.~%"
+                                    condition-type)
+                     elseif (null condition-type)
+                       then (format *error-output* "~
+Reason: detected an unexpected error of type `~s':
+        ~a.~%"
+                                    (class-of condition)
+                                    condition)
+                     elseif (not (if* include-subtypes
+                                    then (typep condition condition-type)
+                                    else (eq (class-of condition)
+                                             (find-class condition-type))))
+                       then (format *error-output* "~
+Reason: detected an incorrect condition type.~%")
+                            (format *error-output*
+                                    "  wanted: ~s~%" condition-type)
+                            (format *error-output*
+                                    "     got: ~s~%" (class-of condition))
+                     elseif (and format-control
+                                 (not (string=
+                                       (setq got
+                                         (concatenate 'simple-string
+                                           "~1@<" format-control "~:@>"))
+                                       (setq wanted
+                                         (simple-condition-format-control
+                                          condition)))))
+                       then ;; format control doesn't match
+                            (format *error-output* "~
+Reason: the format-control was incorrect.~%")
+                            (format *error-output* "  wanted: ~s~%" wanted)
+                            (format *error-output* "     got: ~s~%" got)
+                     elseif (and format-arguments
+                                 (not (equal
+                                       (setq got format-arguments)
+                                       (setq wanted
+                                         (simple-condition-format-arguments
+                                          condition)))))
+                       then (format *error-output* "~
+Reason: the format-arguments were incorrect.~%")
+                            (format *error-output* "  wanted: ~s~%" wanted)
+                            (format *error-output* "     got: ~s~%" got)
+                       else ;; what else????
+                            (error "internal-error"))
+               else (let ((*print-length* 50)
+                          (*print-level* 10))
+                      (if* wanted-message
+                         then (format *error-output*
+                                      "  wanted: ~a~%" wanted-message)
+                         else (if* (not multiple-values)
+                                 then (format *error-output*
+                                              "  wanted: ~s~%"
+                                              expected-result)
+                                 else (format
+                                       *error-output*
+                                       "  wanted values: ~{~s~^, ~}~%"
+                                       expected-result)))
+                      (if* got-message
+                         then (format *error-output*
+                                      "     got: ~a~%" got-message)
+                         else (if* (not multiple-values)
+                                 then (format *error-output* "     got: ~s~%"
+                                       (second test-results))
+                                 else (format
+                                       *error-output*
+                                       "     got values: ~{~s~^, ~}~%"
+                                       (cdr test-results))))))
+            (when fail-info
+              (format *error-output* "Additional info: ~a~%" fail-info))
+            (incf *test-errors*)
+            (when *break-on-test-failures*
+              (break "~a is non-nil." '*break-on-test-failures*))
+       else (when known-failure
+              (format *error-output*
+                      "~&Expected test failure for ~s did not occur.~%"
+                      test-form)
+              (when fail-info
+                (format *error-output* "Additional info: ~a~%" fail-info))
+              (setq fail t))
+            (incf *test-successes*))
+    (not fail)))
+
+(defmacro with-tests ((&key (name "unnamed")) &body body)
+  (let ((g-name (gensym)))
+    `(flet ((doit () , at body))
+       (let ((,g-name ,name)
+             (*test-errors* 0)
+             (*test-successes* 0)
+             (*test-unexpected-failures* 0))
+         (format *error-output* "Begin ~a test~%" ,g-name)
+         (if* *break-on-test-failures*
+            then (doit)
+            else (handler-case (doit)
+                   (error (c)
+                     (format
+                      *error-output*
+                      "~
+~&Test ~a aborted by signalling an uncaught error:~%~a~%"
+                      ,g-name c))))
+         #+allegro
+         (let ((state (sys:gsgc-switch :print)))
+           (setf (sys:gsgc-switch :print) nil)
+           (format t "~&**********************************~%" ,g-name)
+           (format t "End ~a test~%" ,g-name)
+           (format t "Errors detected in this test: ~s " *test-errors*)
+           (unless (zerop *test-unexpected-failures*)
+             (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+           (format t "~%Successes this test:~s~%" *test-successes*)
+           (setf (sys:gsgc-switch :print) state))
+         #-allegro
+         (progn
+           (format t "~&**********************************~%" ,g-name)
+           (format t "End ~a test~%" ,g-name)
+           (format t "Errors detected in this test: ~s " *test-errors*)
+           (unless (zerop *test-unexpected-failures*)
+             (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+           (format t "~%Successes this test:~s~%" *test-successes*))
+         ))))
+
+(provide :tester #+module-versions 1.1)

Added: branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/arrays.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,63 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          arrays.cl
+;;;; Purpose:       UFFI Example file to test arrays
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(uffi:def-foreign-type long-ptr (* :long))
+
+(defun test-array-1d ()
+  "Tests vector"
+  (let ((a (uffi:allocate-foreign-object :long +column-length+)))
+    (dotimes (i +column-length+)
+      (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+    (dotimes (i +column-length+)
+      (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
+    (uffi:free-foreign-object a))
+  (values))
+
+(defun test-array-2d ()
+  "Tests 2d array"
+  (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+)))
+    (dotimes (r +row-length+)
+      (declare (fixnum r))
+      (setf (uffi:deref-array a '(:array (* :long)) r)
+            (uffi:allocate-foreign-object :long +column-length+))
+      (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+        (dotimes (c +column-length+)
+          (declare (fixnum c))
+          (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+
+    (dotimes (r +row-length+)
+      (declare (fixnum r))
+      (format t "~&Row ~D: " r)
+      (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+        (dotimes (c +column-length+)
+          (declare (fixnum c))
+          (let ((result (uffi:deref-array col '(:array :long) c)))
+            (format t "~d " result)))))
+
+    (uffi:free-foreign-object a))
+  (values))
+
+#+examples-uffi
+(test-array-1d)
+
+#+examples-uffi
+(test-array-2d)
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/atoifl.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,56 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          atoifl.cl
+;;;; Purpose:       UFFI Example file to atoi/atof/atol
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-function ("atoi" c-atoi)
+    ((str :cstring))
+  :returning :int)
+
+(uffi:def-function ("atol" c-atol)
+    ((str :cstring))
+  :returning :long)
+
+(uffi:def-function ("atof" c-atof)
+    ((str :cstring))
+  :returning :double)
+
+(defun atoi (str)
+  "Returns a int from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atoi str-cstring)))
+
+(defun atof (str)
+  "Returns a double float from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atof str-cstring)))
+
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+           (format t "~&(atoi ~S) => ~S" str (atoi str))))
+    (print-results "55")))
+
+
+#+test-uffi
+(progn
+  (util.test:test (atoi "123") 123 :test #'eql
+                  :fail-info "Error with atoi")
+  (util.test:test (atoi "") 0 :test #'eql
+                  :fail-info "Error with atoi")
+  (util.test:test (atof "2.23") 2.23d0 :test #'eql
+                  :fail-info "Error with atof")
+  )
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.c	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,91 @@
+/***************************************************************************
+ * FILE IDENTIFICATION
+ *
+ *  Name:         c-test-fns.c
+ *  Purpose:      Test functions in C for UFFI library
+ *  Programer:    Kevin M. Rosenberg
+ *  Date Started: Mar 2002
+ *
+ *  CVS Id:   $Id$
+ *
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+ *
+ * These variables are correct for GCC
+ * you'll need to modify these for other compilers
+ ***************************************************************************/
+
+#ifdef WIN32
+#include <windows.h>
+
+BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll,
+                          DWORD fdwReason,
+                          LPVOID lpvReserved)
+{
+        return 1;
+}
+
+#define DLLEXPORT __declspec(dllexport)
+
+#else
+#define DLLEXPORT
+#endif
+
+#include <ctype.h>
+#include <stdlib.h>
+#include <math.h>
+
+
+/* Test of constant input string */
+DLLEXPORT
+int
+cs_count_upper (char* psz)
+{
+  int count = 0;
+
+  if (psz) {
+    while (*psz) {
+      if (isupper (*psz))
+        ++count;
+      ++psz;
+    }
+    return count;
+  } else
+    return -1;
+}
+
+/* Test of input and output of a string */
+DLLEXPORT
+void
+cs_to_upper (char* psz)
+{
+  if (psz) {
+    while (*psz) {
+      *psz = toupper (*psz);
+      ++psz;
+    }
+  }
+}
+
+/* Test of an output only string */
+DLLEXPORT
+void
+cs_make_random (int size, char* buffer)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    buffer[i] = 'A' + (rand() % 26);
+}
+
+
+/* Test of input/output vector */
+DLLEXPORT
+void
+half_double_vector (int size, double* vec)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    vec[i] /= 2.;
+}
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/c-test-fns.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,118 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          c-test-fns.cl
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library
+         (uffi:find-foreign-library "c-test-fns"
+                                    (list *load-truename* "/home/kevin/debian/src/uffi/examples/"))
+         :supporting-libraries '("c"))
+  (warn "Unable to load c-test-fns library"))
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+  ((input (* :unsigned-char)))
+  :returning :void
+  )
+
+(defun string-to-upper (str)
+  (uffi:with-foreign-string (str-foreign str)
+    (cs-to-upper str-foreign)
+    (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+  ((input :cstring))
+  :returning :int
+  )
+
+(defun string-count-upper (str)
+  (uffi:with-cstring (str-cstring str)
+    (cs-count-upper str-cstring)))
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+    ((size :int)
+     (vec (* :double)))
+  :returning :void)
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+  (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+        results)
+    (dotimes (i +double-vec-length+)
+      (setf (uffi:deref-array vec '(:array :double) i)
+            (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    (dotimes (i +double-vec-length+)
+      (push (uffi:deref-array vec '(:array :double) i) results))
+    (uffi:free-foreign-object vec)
+    (nreverse results)))
+
+(defun t2 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    vec))
+
+#+(or cmu scl)
+(defun t3 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (system:without-gcing
+     (half-double-vector +double-vec-length+ (system:vector-sap vec)))
+    vec))
+
+#+examples-uffi
+(format t "~&(string-to-upper \"this is a test\") => ~A"
+        (string-to-upper "this is a test"))
+
+#+examples-uffi
+(format t "~&(string-to-upper nil) => ~A"
+        (string-to-upper nil))
+
+#+examples-uffi
+(format t "~&(string-count-upper \"This is a Test\") => ~A"
+        (string-count-upper "This is a Test"))
+
+#+examples-uffi
+(format t "~&(string-count-upper nil) => ~A"
+        (string-count-upper nil))
+
+#+examples-uffi
+(format t "~&Half vector: ~S" (test-half-double-vector))
+
+
+
+#+test-uffi
+(progn
+  (util.test:test (string= (string-to-upper "this is a test") "THIS IS A TEST")
+                  t
+                  :test #'eql
+                  :fail-info "Error with string-to-upper")
+  (util.test:test (string-to-upper nil) nil
+                  :fail-info "string-to-upper with nil failed")
+  (util.test:test (string-count-upper "This is a Test")
+                  2
+                  :test #'eql
+                  :fail-info "Error with string-count-upper")
+  (util.test:test (string-count-upper nil) -1
+                  :test #'eql
+                  :fail-info "string-count-upper with nil failed")
+
+  (util.test:test (test-half-double-vector)
+                  '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)
+                  :test #'equal
+                  :fail-info "Error comparing half-double-vector")
+  )

Added: branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/compress.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,116 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          compress.cl
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(eval-when (:load-toplevel :execute)
+  (unless (uffi:load-foreign-library
+           #-(or macosx darwin)
+           (uffi:find-foreign-library
+            "libz"
+            '("/usr/local/lib/" "/usr/lib/" "/zlib/")
+            :types '("so" "a"))
+           #+(or macosx darwin)
+           (uffi:find-foreign-library "z"
+                                      `(,(pathname-directory *load-pathname*)))
+           :module "zlib"
+           :supporting-libraries '("c"))
+    (warn "Unable to load zlib")))
+
+(uffi:def-function ("compress" c-compress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun compress (source)
+  "Returns two values: array of bytes containing the compressed data
+ and the numbe of compressed bytes"
+  (let* ((sourcelen (length source))
+         (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+         (dest (uffi:allocate-foreign-string destsize :unsigned t))
+         (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-compress dest destlen source-native sourcelen))
+            (newdestlen (uffi:deref-pointer destlen :long)))
+        (unwind-protect
+            (if (zerop result)
+                (values (uffi:convert-from-foreign-string
+                         dest
+                         :length newdestlen
+                         :null-terminated-p nil)
+                        newdestlen)
+              (error "zlib error, code ~D" result))
+          (progn
+            (uffi:free-foreign-object destlen)
+            (uffi:free-foreign-object dest)))))))
+
+(uffi:def-function ("uncompress" c-uncompress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun uncompress (source)
+  (let* ((sourcelen (length source))
+         (destsize 200000)  ;adjust as needed
+         (dest (uffi:allocate-foreign-string destsize :unsigned t))
+         (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-uncompress dest destlen source-native sourcelen))
+            (newdestlen (uffi:deref-pointer destlen :long)))
+        (unwind-protect
+             (if (zerop result)
+                 (uffi:convert-from-foreign-string
+                  dest
+                  :length newdestlen
+                  :null-terminated-p nil)
+                 (error "zlib error, code ~D" result))
+          (progn
+            (uffi:free-foreign-object destlen)
+            (uffi:free-foreign-object dest)))))))
+
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+           (multiple-value-bind (compressed len) (compress str)
+             (let ((*print-length* nil))
+               (format t "~&(compress ~S) => " str)
+               (format t "~S~%" (map 'list #'char-code compressed))))))
+    (print-results "")
+    (print-results "test")
+    (print-results "test2")))
+
+#+test-uffi
+(progn
+  (flet ((test-compress (str)
+           (multiple-value-bind (compressed len) (compress str)
+             (multiple-value-bind (uncompressed len2) (uncompress compressed)
+               (util.test:test str uncompressed :test #'string=
+                               :fail-info "Error uncompressing a compressed string")))))
+    (test-compress "")
+    (test-compress "test")
+    (test-compress "test2")))
+
+;; Results of the above on my system:
+;; (compress "") => 789c300001,8
+;; (compress "test") => 789c2b492d2e1045d1c1,12
+;; (compress "test2") => 789c2b492d2e31206501f3,13

Added: branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/file-socket.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,39 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          file-socket.cl
+;;;; Purpose:       UFFI Example file to get a socket on a file
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jul 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;; Values for linux
+(uffi:def-constant PF_UNIX 1)
+(uffi:def-constant SOCK_STREAM 1)
+
+(uffi:def-function ("socket" c-socket)
+    ((family :int)
+     (type :int)
+     (protocol :int))
+    :returning :int)
+
+(uffi:def-function ("connect" c-connect)
+    ((sockfd :int)
+     (serv-addr :void-pointer)
+     (addr-len :int))
+    :returning :int)
+
+(defun connect-to-file-socket (filename)
+  (let ((socket (c-socket PF_UNIX SOCK_STREAM 0)))
+    (if (plusp socket)
+        (let ((stream (c-connect socket filename (length filename))))
+          stream)
+      (error "Unable to create socket"))))

Added: branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/getenv.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,44 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv.cl
+;;;; Purpose:       UFFI Example file to get environment variable
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function ("getenv" c-getenv)
+    ((name :cstring))
+  :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+           (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+    (print-results "USER")
+    (print-results "_FOO_")))
+
+
+#+test-uffi
+(progn
+  (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
+  (util.test:test (and (stringp (my-getenv "USER"))
+                       (< 0 (length (my-getenv "USER"))))
+                  t :fail-info "Error retrieving getenv")
+)
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/gethostname.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,63 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gethostname.cl
+;;;; Purpose:       UFFI Example file to get hostname of system
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(uffi:def-function ("gethostname" c-gethostname)
+    ((name (* :unsigned-char))
+     (len :int))
+  :returning :int)
+
+(defun gethostname ()
+  "Returns the hostname"
+  (let* ((name (uffi:allocate-foreign-string 256))
+         (result-code (c-gethostname name 256))
+         (hostname (when (zerop result-code)
+                     (uffi:convert-from-foreign-string name))))
+    (uffi:free-foreign-object name)
+    (unless (zerop result-code)
+      (error "gethostname() failed."))
+    hostname))
+
+(defun gethostname2 ()
+  "Returns the hostname"
+  (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+    (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+        (uffi:convert-from-foreign-string name)
+        (error "gethostname() failed."))))
+
+#+examples-uffi
+(progn
+  (format t "~&Hostname (technique 1): ~A" (gethostname))
+  (format t "~&Hostname (technique 2): ~A" (gethostname2)))
+
+#+test-uffi
+(progn
+  (let ((hostname1 (gethostname))
+        (hostname2 (gethostname2)))
+
+    (util.test:test (and (stringp hostname1) (stringp hostname2)) t
+                    :fail-info "gethostname not string")
+    (util.test:test (and (not (zerop (length hostname1)))
+                         (not (zerop (length hostname2)))) t
+                         :fail-info "gethostname length 0")
+    (util.test:test (string= hostname1 hostname1) t
+                    :fail-info "gethostname techniques don't match"))
+  )
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/getshells.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,44 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getshells.cl
+;;;; Purpose:       UFFI Example file to get lisp of legal shells
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function "setusershell"
+    nil
+  :returning :void)
+
+(uffi:def-function "endusershell"
+    nil
+  :returning :void)
+
+(uffi:def-function "getusershell"
+    nil
+  :returning :cstring)
+
+(defun getshells ()
+  "Returns list of valid shells"
+  (setusershell)
+  (let (shells)
+    (do ((shell (uffi:convert-from-cstring (getusershell))
+                (uffi:convert-from-cstring (getusershell))))
+        ((null shell))
+      (push shell shells))
+    (endusershell)
+    (nreverse shells)))
+
+#+examples-uffi
+(format t "~&Shells: ~S" (getshells))
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/gettime.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,73 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gettime
+;;;; Purpose:       UFFI Example file to get time, use C structures
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+    (sec :int)
+  (min :int)
+  (hour :int)
+  (mday :int)
+  (mon :int)
+  (year :int)
+  (wday :int)
+  (yday :int)
+  (isdst :int))
+
+(uffi:def-function ("time" c-time)
+    ((time (* time-t)))
+  :returning time-t)
+
+(uffi:def-function ("localtime" c-localtime)
+    ((time (* time-t)))
+  :returning (* tm))
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (* tm))
+
+(defun gettime ()
+   "Returns the local time"
+   (uffi:with-foreign-object (time 'time-t)
+;;     (declare (type time-t time))
+     (c-time time)
+     (let ((tm-ptr (the tm-pointer (c-localtime time))))
+       (declare (type tm-pointer tm-ptr))
+       (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d"
+                                  (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+                                  (uffi:get-slot-value tm-ptr 'tm 'mday)
+                                  (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+                                  (uffi:get-slot-value tm-ptr 'tm 'hour)
+                                  (uffi:get-slot-value tm-ptr 'tm 'min)
+                                  (uffi:get-slot-value tm-ptr 'tm 'sec)
+                                  )))
+         time-string))))
+
+
+
+
+#+examples-uffi
+(format t "~&~A" (gettime))
+
+#+test-uffi
+(progn
+  (let ((time (gettime)))
+    (util.test:test (stringp time) t :fail-info "Time is not a string")
+    (util.test:test (plusp (parse-integer time :junk-allowed t))
+                    t
+                    :fail-info "time string does not start with a number")))
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/run-examples.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,36 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          run-examples.cl
+;;;; Purpose:       Load and execute all examples for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(pushnew :examples-uffi cl:*features*)
+
+(flet ((load-test (name)
+          (load (make-pathname :defaults *load-truename* :name name))))
+  (load-test "c-test-fns")
+  (load-test "arrays")
+  (load-test "union")
+  (load-test "strtol")
+  (load-test "atoifl")
+  (load-test "gettime")
+  (load-test "getenv")
+  (load-test "gethostname")
+  (load-test "getshells")
+  (load-test "compress"))
+
+(setq cl:*features* (remove :examples-uffi cl:*features*))
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/strtol.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,80 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strtol.cl
+;;;; Purpose:       UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type char-ptr (* :unsigned-char))
+
+;; This example does not use :cstring to pass the input string since
+;; the routine needs to do pointer arithmetic to see how many characters
+;; were parsed
+
+(uffi:def-function ("strtol" c-strtol)
+    ((nptr char-ptr)
+     (endptr (* char-ptr))
+     (base :int))
+  :returning :long)
+
+(defun strtol (str &optional (base 10))
+  "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+their was no string at all, or an integer indicating position in string
+of first non-valid character"
+  (let* ((str-native (uffi:convert-to-foreign-string str))
+         (endptr (uffi:allocate-foreign-object 'char-ptr))
+         (value (c-strtol str-native endptr base))
+         (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+
+    (unwind-protect
+         (if (uffi:null-pointer-p endptr-value)
+             (values value t)
+             (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+                   (chars-parsed (- (uffi:pointer-address endptr-value)
+                                    (uffi:pointer-address str-native))))
+               (cond
+                 ((zerop chars-parsed)
+                  (values nil nil))
+                 ((uffi:null-char-p next-char-value)
+                  (values value t))
+                 (t
+                  (values value chars-parsed)))))
+      (progn
+        (uffi:free-foreign-object str-native)
+        (uffi:free-foreign-object endptr)))))
+
+
+
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+           (multiple-value-bind (result flag) (strtol str)
+             (format t "~&(strtol ~S) => ~S,~S" str result flag))))
+    (print-results "55")
+    (print-results "55.3")
+    (print-results "a")))
+
+#+test-uffi
+(progn
+  (flet ((test-strtol (str results)
+           (util.test:test (multiple-value-list (strtol str)) results
+                           :test #'equal
+                           :fail-info "Error testing strtol")))
+    (test-strtol "123" '(123 t))
+    (test-strtol "0" '(0 t))
+    (test-strtol "55a" '(55 2))
+    (test-strtol "a" '(nil nil))))
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/test-examples.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,40 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          test-examples.cl
+;;;; Purpose:       Load and execute all examples for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(unless (ignore-errors (find-package :util.test))
+  (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*)))
+
+(defun do-tests ()
+  (pushnew :test-uffi cl:*features*)
+  (util.test:with-tests (:name "UFFI-Tests")
+    (setq util.test:*break-on-test-failures* nil)
+    (flet ((load-test (name)
+                      (load (make-pathname :name name :defaults *load-truename*))))
+      (load-test "c-test-fns")
+      (load-test "arrays")
+      (load-test "union")
+      (load-test "strtol")
+      (load-test "atoifl")
+      (load-test "gettime")
+      (load-test "getenv")
+      (load-test "gethostname")
+      (load-test "getshells")
+      (load-test "compress"))
+    (setq cl:*features* (remove :test-uffi cl:*features*))))
+
+(do-tests)
+

Added: branches/trunk-reorg/thirdparty/uffi/examples/union.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/examples/union.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,86 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          union.cl
+;;;; Purpose:       UFFI Example file to test unions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-union tunion1
+    (char :char)
+  (int :int)
+  (uint :unsigned-int)
+  (sf :float)
+  (df :double))
+
+(defun run-union-1 ()
+  (let ((u (uffi:allocate-foreign-object 'tunion1)))
+    (setf (uffi:get-slot-value u 'tunion1 'uint)
+      ;; little endian
+      #-(or sparc sparc-v9 powerpc ppc big-endian)
+      (+ (* 1 (char-code #\A))
+         (* 256 (char-code #\B))
+         (* 65536 (char-code #\C))
+         (* 16777216 255))
+      ;; big endian
+      #+(or sparc sparc-v9 powerpc ppc big-endian)
+      (+ (* 16777216 (char-code #\A))
+         (* 65536 (char-code #\B))
+         (* 256 (char-code #\C))
+         (* 1 255)))
+    (format *standard-output* "~&Should be #\A: ~S"
+            (uffi:ensure-char-character
+             (uffi:get-slot-value u 'tunion1 'char)))
+;;    (format *standard-output* "~&Should be negative number: ~D"
+;;          (uffi:get-slot-value u 'tunion1 'int))
+    (format *standard-output* "~&Should be positive number: ~D"
+            (uffi:get-slot-value u 'tunion1 'uint))
+    (uffi:free-foreign-object u))
+  (values))
+
+#+test-uffi
+(defun test-union-1 ()
+  (let ((u (uffi:allocate-foreign-object 'tunion1)))
+    (setf (uffi:get-slot-value u 'tunion1 'uint)
+          #-(or sparc sparc-v9 powerpc ppc)
+          (+ (* 1 (char-code #\A))
+             (* 256 (char-code #\B))
+             (* 65536 (char-code #\C))
+             (* 16777216 128))
+          #+(or sparc sparc-v9 powerpc ppc)
+          (+ (* 16777216 (char-code #\A))
+             (* 65536 (char-code #\B))
+             (* 256 (char-code #\C))
+             (* 1 128))) ;set signed bit
+    (util.test:test (uffi:ensure-char-character
+                (uffi:get-slot-value u 'tunion1 'char))
+               #\A
+               :test #'eql
+               :fail-info "Error with union character")
+    #-(or sparc sparc-v9 openmcl digitool)
+;;    (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
+;;             t
+;;             :fail-info
+;;             "Error with negative int in union")
+    (util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint))
+               t
+               :fail-info
+               "Error with unsigned int in union")
+    (uffi:free-foreign-object u))
+  (values))
+
+#+examples-uffi
+(run-union-1)
+
+
+#+test-uffi
+(test-union-1)

Added: branches/trunk-reorg/thirdparty/uffi/src/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,6 @@
+SUBDIRS		:= 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/aggregates.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,262 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          aggregates.lisp
+;;;; Purpose:       UFFI source to handle aggregate types
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defmacro def-enum (enum-name args &key (separator-string "#"))
+  "Creates a constants for a C type enum list, symbols are created
+in the created in the current package. The symbol is the concatenation
+of the enum-name name, separator-string, and field-name"
+  (let ((counter 0)
+        (cmds nil)
+        (constants nil))
+    (declare (fixnum counter))
+    (dolist (arg args)
+      (let ((name (if (listp arg) (car arg) arg))
+            (value (if (listp arg)
+                       (prog1
+                           (setq counter (cadr arg))
+                         (incf counter))
+                     (prog1
+                         counter
+                       (incf counter)))))
+        (setq name (intern (concatenate 'string
+                             (symbol-name enum-name)
+                             separator-string
+                             (symbol-name name))))
+        (push `(uffi:def-constant ,name ,value) constants)))
+    (setf cmds (append '(progn)
+                       #+allegro `((ff:def-foreign-type ,enum-name :int))
+                       #+lispworks `((fli:define-c-typedef ,enum-name :int))
+                       #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
+                       #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
+                       #+digitool `((def-mcl-type ,enum-name :integer))
+                       #+openmcl `((ccl::def-foreign-type ,enum-name :int))
+                       (nreverse constants)))
+    cmds))
+
+
+(defmacro def-array-pointer (name-array type)
+  #+allegro
+  `(ff:def-foreign-type ,name-array
+    (:array ,(convert-from-uffi-type type :array)))
+  #+lispworks
+  `(fli:define-c-typedef ,name-array
+    (:c-array ,(convert-from-uffi-type type :array)))
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name-array
+    (* ,(convert-from-uffi-type type :array)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name-array
+    (* ,(convert-from-uffi-type type :array)))
+  #+digitool
+  `(def-mcl-type ,name-array '(:array ,type))
+  #+openmcl
+  `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
+  )
+
+(defun process-struct-fields (name fields &optional (variant nil))
+  (let (processed)
+    (dolist (field fields)
+      (let* ((field-name (car field))
+             (type (cadr field))
+             (def (append (list field-name)
+                          (if (eq type :pointer-self)
+                              #+(or cmu scl) `((* (alien:struct ,name)))
+                              #+sbcl `((* (sb-alien:struct ,name)))
+                              #+(or openmcl digitool) `((:* (:struct ,name)))
+                              #+lispworks `((:pointer ,name))
+                              #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
+                              `(,(convert-from-uffi-type type :struct))))))
+        (if variant
+            (push (list def) processed)
+          (push def processed))))
+    (nreverse processed)))
+
+
+(defmacro def-struct (name &rest fields)
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
+  #+allegro
+  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+  #+lispworks
+  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+  #+digitool
+  `(ccl:defrecord ,name ,@(process-struct-fields name fields))
+  #+openmcl
+  `(ccl::def-foreign-type
+    nil
+    (:struct ,name ,@(process-struct-fields name fields)))
+  )
+
+
+(defmacro get-slot-value (obj type slot)
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
+  #+allegro
+  `(ff:fslot-value-typed ,type :c ,obj ,slot)
+  #+lispworks
+  `(fli:foreign-slot-value ,obj ,slot)
+  #+(or cmu scl)
+  `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
+  #+(or openmcl digitool)
+  `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
+  )
+
+#+(or openmcl digitool)
+(defmacro set-slot-value (obj type slot value) ;use setf to set values
+  `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
+
+#+(or openmcl digitool)
+(defsetf get-slot-value set-slot-value)
+
+
+(defmacro get-slot-pointer (obj type slot)
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
+  #+allegro
+  `(ff:fslot-value-typed ,type :c ,obj ,slot)
+  #+lispworks
+  `(fli:foreign-slot-pointer ,obj ,slot)
+  #+(or cmu scl)
+  `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
+  #+digitool
+  `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
+  #+openmcl
+  `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
+     (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
+)
+
+;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
+;; below
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; so we could allow '(:array :long) or deref with other type like :long only
+  #+(or openmcl digitool)
+  (defun array-type (type)
+    (let ((result type))
+      (when (listp type)
+        (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+          (when (and (listp type-list) (eq (car type-list) :array))
+            (setf result (cadr type-list)))))
+      result))
+
+
+  (defmacro deref-array (obj type i)
+    "Returns a field from a row"
+    #+(or lispworks cmu sbcl scl) (declare (ignore type))
+    #+(or cmu scl)  `(alien:deref ,obj ,i)
+    #+sbcl `(sb-alien:deref ,obj ,i)
+    #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
+    #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+    #+openmcl
+    (let* ((array-type (array-type type))
+           (local-type (convert-from-uffi-type array-type :allocation))
+           (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+      (ccl::%foreign-access-form
+       obj
+       (ccl::%foreign-type-or-record local-type)
+       `(* ,i ,element-size-in-bits)
+       nil))
+    #+digitool
+    (let* ((array-type (array-type type))
+           (local-type (convert-from-uffi-type array-type :allocation))
+           (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+      `(,accessor
+        ,obj
+        (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
+    ))
+
+; this expands to the %set-xx functions which has different params than %put-xx
+#+digitool
+(defmacro deref-array-set (obj type i value)
+  (let* ((array-type (array-type type))
+         (local-type (convert-from-uffi-type array-type :allocation))
+         (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
+         (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
+    `(,settor
+      ,obj
+      (* (the fixnum ,i) ,(size-of-foreign-type local-type))
+      ,value)))
+
+#+digitool
+(defsetf deref-array deref-array-set)
+
+(defmacro def-union (name &rest fields)
+  #+allegro
+  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+  #+lispworks
+  `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
+  #+digitool
+  `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+  #+openmcl
+  `(ccl::def-foreign-type nil
+                          (:union ,name ,@(process-struct-fields name fields)))
+)
+
+
+#-(or sbcl cmu)
+(defun convert-from-foreign-usb8 (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+           (fixnum len))
+  (let ((a (make-array len :element-type '(unsigned-byte 8))))
+    (dotimes (i len a)
+      (declare (fixnum i))
+      (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb-ext:without-package-locks
+      (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                   (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+                                   (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
+    (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                          (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+                                          0))
+    (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+                                              sb-vm:n-byte-bits
+                                              1))))
+
+
+#+sbcl
+(defun convert-from-foreign-usb8 (s len)
+  (let ((sap (sb-alien:alien-sap s)))
+    (declare (type sb-sys:system-area-pointer sap))
+    (locally
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((result (make-array len :element-type '(unsigned-byte 8))))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+                (* len +system-copy-multiplier+))
+       result))))
+
+#+cmu
+(defun convert-from-foreign-usb8 (s len)
+  (let ((sap (alien:alien-sap s)))
+    (declare (type system:system-area-pointer sap))
+    (locally
+        (declare (optimize (speed 3) (safety 0)))
+      (let ((result (make-array len :element-type '(unsigned-byte 8))))
+        (kernel:copy-from-system-area sap 0
+                                      result (* vm:vector-data-offset
+                                                vm:word-bits)
+                                      (* len vm:byte-bits))
+        result))))

Added: branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/corman/corman-notes.txt	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,17 @@
+some notes:
+  we need the :pascal (:stdcall) calling conventions for 
+  (def-function names args &key module returning calling-convention)
+  so I added this. calling-convention defaults to :cdecl
+  but on win32 we mostly use :stdcall
+
+  #+corman is invalid, #+cormanlisp instead
+
+  cormanlisp doesn't need to load and register the dll, since the underlying 
+  LoadLibrary() call does this. we need the module keyword for def-function
+instead.
+  (should probably default to kernel32.dll)
+  I'll think about library.cl, but we'll need more real-world win32 examples. 
+  (ideally the complete winapi :)
+  I also have to look at valentina.
+
+patch -p0 < corman.diff

Added: branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/corman/getenv-ccl.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,81 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv-ccl.cl
+;;;; Purpose:       cormanlisp version
+;;;; Programmer:    "Joe Marshall" <prunesquallor at attbi.com>
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(ct:defun-dll c-getenv ((lpname LPSTR)
+                        (lpbuffer LPSTR)
+                        (nsize LPDWORD))
+  :library-name "kernel32.dll"
+  :return-type DWORD
+  :entry-name "GetEnvironmentVariableA"
+  :linkage-type :pascal)
+
+(defun getenv (name)
+  (let ((nsizebuf (ct:malloc (sizeof :long)))
+        (buffer (ct:malloc 1))
+        (cname (ct:lisp-string-to-c-string name)))
+    (setf (ct:cref lpdword nsizebuf 0) 0)
+    (let* ((needed-size (c-getenv cname buffer nsizebuf))
+           (buffer1 (ct:malloc (1+ needed-size))))
+      (setf (ct:cref lpdword nsizebuf 0) needed-size)
+      (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
+                 nil
+               (ct:c-string-to-lisp-string buffer1))
+        (ct:free buffer1)
+        (ct:free nsizebuf)))))
+
+(defun cl:user-homedir-pathname (&optional host)
+  (cond ((or (stringp host)
+             (and (consp host)
+                  (every #'stringp host))) nil)
+        ((or (eq host :unspecific)
+             (null host))
+         (let ((homedrive (getenv "HOMEDRIVE"))
+               (homepath  (getenv "HOMEPATH")))
+           (parse-namestring
+             (if (and (stringp homedrive)
+                      (stringp homepath)
+                      (= (length homedrive) 2)
+                      (> (length homepath) 0))
+                 (concatenate 'string homedrive homepath "\\")
+                 "C:\\"))))
+        (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
+
+;|
+(uffi:def-function ("getenv" c-getenv)
+    ((name :cstring))
+  :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+
+#examples-uffi
+(progn
+  (flet ((print-results (str)
+           (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+    (print-results "USER")
+    (print-results "_FOO_")))
+
+
+#test-uffi
+(progn
+  (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
+  (util.test:test (and (stringp (my-getenv "USER"))
+                       (< 0 (length (my-getenv "USER"))))
+                  t :fail-info "Error retrieving getenv")
+)
+

Added: branches/trunk-reorg/thirdparty/uffi/src/functions.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/functions.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,239 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          function.lisp
+;;;; Purpose:       UFFI source to C function definitions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defun process-function-args (args)
+  (if (null args)
+      #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
+      #+allegro '(:void)
+      #+openmcl (values nil nil)
+
+      ;; args not null
+      #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
+      (let (processed)
+        (dolist (arg args)
+          (push (process-one-function-arg arg) processed))
+        (nreverse processed))
+      #+openmcl
+      (let ((processed nil)
+            (params nil))
+        (dolist (arg args)
+          (let ((name (car arg))
+                (type (convert-from-uffi-type (cadr arg) :routine)))
+            ;;(when (and (listp type) (eq (car type) :address))
+            ;;(setf type :address))
+            (push name params)
+            (push type processed)
+            (push name processed)))
+        (values (nreverse params) (nreverse processed)))
+    ))
+
+(defun process-one-function-arg (arg)
+  (let ((name (car arg))
+        (type (convert-from-uffi-type (cadr arg) :routine)))
+    #+(or cmu sbcl scl)
+    ;(list name type :in)
+    `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
+    #+(or allegro lispworks digitool)
+    (if (and (listp type) (listp (car type)))
+        (append (list name) type)
+      (list name type))
+    #+openmcl
+    (declare (ignore name type))
+    ))
+
+
+(defun allegro-convert-return-type (type)
+  (if (and (listp type) (not (listp (car type))))
+      (list type)
+    type))
+
+(defun funcallable-lambda-list (args)
+  (let ((ll nil))
+    (dolist (arg args)
+      (push (car arg) ll))
+    (nreverse ll)))
+
+#|
+(defmacro def-funcallable (name args &key returning)
+  (let ((result-type (convert-from-uffi-type returning :return))
+        (function-args (process-function-args args)))
+    #+lispworks
+    `(fli:define-foreign-funcallable ,name ,function-args
+      :result-type ,result-type
+      :language :ansi-c
+      :calling-convention :cdecl)
+    #+(or cmu scl sbcl)
+    ;; requires the type of the function pointer be declared correctly!
+    (let* ((ptrsym (gensym))
+           (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+        (alien::alien-funcall ,ptrsym , at ll)))
+    #+openmcl
+    (multiple-value-bind (params args) (process-function-args args)
+      (let ((ptrsym (gensym)))
+        `(defun ,name ,(cons ptrsym params)
+          (ccl::ff-call ,ptrsym , at args ,result-type))))
+    #+allegro
+    ;; this is most definitely wrong
+    (let* ((ptrsym (gensym))
+           (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+        (system::ff-funcall ,ptrsym , at ll)))
+    ))
+|#
+
+(defun convert-lispworks-args (args)
+  (loop for arg in args
+        with processed = nil
+        do
+        (if (and (= (length arg) 3) (eq (third arg) :out))
+            (push (list (first arg)
+                        (list :reference-return (second arg))) processed)
+            (push (subseq arg 0 2) processed))
+        finally (return (nreverse processed))))
+
+(defun preprocess-names (names)
+  (let ((fname (gensym)))
+    (if (atom names)
+        (values (list names fname) fname (uffi::make-lisp-name names))
+        (values (list (first names) fname) fname (second names)))))
+
+(defun preprocess-args (args)
+  (loop for arg in args
+        with lisp-args = nil and out = nil and processed = nil
+        do
+        (if (= (length arg) 3)
+            (ecase (third arg)
+              (:in
+               (progn
+                 (push (first arg) lisp-args)
+                 (push (list (first arg) (second arg)) processed)))
+              (:out
+               (progn
+                 (push (list (first arg) (second arg)) out)
+                 (push (list (first arg) (list '* (second arg))) processed))))
+            (progn
+              (push (first arg) lisp-args)
+              (push arg processed)))
+        finally (return (values (nreverse lisp-args)
+                                (nreverse out)
+                                (nreverse processed)))))
+
+
+(defmacro def-function (names args &key module returning)
+  (multiple-value-bind (lisp-args out processed)
+      (preprocess-args args)
+    (declare (ignorable lisp-args processed))
+    (if (= (length out) 0)
+        `(%def-function ,names ,args
+          ,@(if module (list :module module) (values))
+          ,@(if returning (list :returning returning) (values)))
+
+        #+(or cmu scl sbcl)
+        `(%def-function ,names ,args
+          ,@(if returning (list :returning returning) (values)))
+        #+(and lispworks lispworks5)
+        (multiple-value-bind (name-pair fname lisp-name)
+            (preprocess-names names)
+          `(progn
+               (%def-function ,name-pair ,(convert-lispworks-args args)
+                              ,@(if module (list :module module) (values))
+                              ,@(if returning (list :returning returning) (values)))
+               (defun ,lisp-name ,lisp-args
+                 (,fname ,@(mapcar
+                            #'(lambda (arg)
+                                (cond ((member (first arg) lisp-args)
+                                       (first arg))
+                                      ((member (first arg) out :key #'first)
+                                       t)))
+                          args)))))
+        #+(and lispworks (not lispworks5))
+        `(%def-function ,names ,(convert-lispworks-args args)
+          ,@(if module (list :module module) (values))
+          ,@(if returning (list :returning returning) (values)))
+        #-(or cmu scl sbcl lispworks)
+        (multiple-value-bind (name-pair fname lisp-name)
+            (preprocess-names names)
+          `(progn
+            (%def-function ,name-pair ,processed
+             :module ,module :returning ,returning)
+            ;(declaim (inline ,fname))
+            (defun ,lisp-name ,lisp-args
+              (with-foreign-objects ,out
+                (values (,fname ,@(mapcar #'first args))
+                        ,@(mapcar #'(lambda (arg)
+                                      (list 'deref-pointer
+                                            (first arg)
+                                            (second arg))) out))))))
+        )))
+
+
+;; name is either a string representing foreign name, or a list
+;; of foreign-name as a string and lisp name as a symbol
+(defmacro %def-function (names args &key module returning)
+  #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
+
+  (let* ((result-type (convert-from-uffi-type returning :return))
+         (function-args (process-function-args args))
+         (foreign-name (if (atom names) names (car names)))
+         (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+    ;; todo: calling-convention :stdcall for cormanlisp
+    #+allegro
+    `(ff:def-foreign-call (,lisp-name ,foreign-name)
+         ,function-args
+       :returning ,(allegro-convert-return-type result-type)
+       :call-direct t
+       :strings-convert nil)
+    #+(or cmu scl)
+    `(alien:def-alien-routine (,foreign-name ,lisp-name)
+         ,result-type
+       , at function-args)
+    #+sbcl
+    `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
+         ,result-type
+       , at function-args)
+    #+lispworks
+    `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
+         ,function-args
+       ,@(if module (list :module module) (values))
+       :result-type ,result-type
+      :language :ansi-c
+       #+:win32 :calling-convention #+:win32 :cdecl)
+    #+digitool
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (ccl:define-entry-point (,lisp-name ,foreign-name)
+         ,function-args
+         ,result-type))
+    #+openmcl
+    (declare (ignore function-args))
+    #+(and openmcl darwinppc-target)
+    (setf foreign-name (concatenate 'string "_" foreign-name))
+    #+openmcl
+    (multiple-value-bind (params args) (process-function-args args)
+      `(defun ,lisp-name ,params
+         (ccl::external-call ,foreign-name , at args ,result-type)))
+    #+cormanlisp
+    `(ct:defun-dll ,lisp-name (,function-args)
+       :return-type ,result-type
+       ,@(if module (list :library-name module) (values))
+       :entry-name ,foreign-name
+       :linkage-type ,calling-convention) ; we need :pascal
+    ))
+
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/libraries.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,134 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          libraries.lisp
+;;;; Purpose:       UFFI source to load foreign libraries
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defvar *loaded-libraries* nil
+  "List of foreign libraries loaded. Used to prevent reloading a library")
+
+(defun default-foreign-library-type ()
+  "Returns string naming default library type for platform"
+  #+(or win32 cygwin mswindows) "dll"
+  #+(or macosx darwin ccl-5.0) "dylib"
+  #-(or win32 cygwin mswindows macosx darwin ccl-5.0) "so"
+)
+
+(defun foreign-library-types ()
+  "Returns list of string naming possible library types for platform, sorted by preference"
+  #+(or win32 mswindows) '("dll" "lib")
+  #+(or macosx darwin ccl-5.0) '("dylib" "bundle")
+  #-(or win32 mswindows macosx darwin ccl-5.0) '("so" "a" "o")
+)
+
+(defun find-foreign-library (names directories &key types drive-letters)
+  "Looks for a foreign library. directories can be a single
+string or a list of strings of candidate directories. Use default
+library type if type is not specified."
+  (unless types
+    (setq types (foreign-library-types)))
+  (unless (listp types)
+    (setq types (list types)))
+  (unless (listp names)
+    (setq names (list names)))
+  (unless (listp directories)
+    (setq directories (list directories)))
+  #+(or win32 mswindows)
+  (unless (listp drive-letters)
+    (setq drive-letters (list drive-letters)))
+  #-(or win32 mswindows)
+  (setq drive-letters '(nil))
+  (dolist (drive-letter drive-letters)
+    (dolist (name names)
+      (dolist (dir directories)
+        (dolist (type types)
+          (let ((path (make-pathname
+                       #+lispworks :host
+                       #+lispworks (when drive-letter drive-letter)
+                       #-lispworks :device
+                       #-lispworks (when drive-letter drive-letter)
+                       :name name
+                       :type type
+                       :directory
+                       (etypecase dir
+                         (pathname
+                          (pathname-directory dir))
+                         (list
+                          dir)
+                         (string
+                          (pathname-directory
+                           (parse-namestring dir)))))))
+            (when (probe-file path)
+              (return-from find-foreign-library path)))))))
+   nil)
+
+
+(defun load-foreign-library (filename &key module supporting-libraries
+                                           force-load)
+  #+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries))
+  #+(or cmu scl) (declare (ignore module))
+  #+lispworks (declare (ignore supporting-libraries))
+
+  (flet ((load-failure ()
+           (error "Unable to load foreign library \"~A\"." filename)))
+    (when (and filename (or (null (pathname-directory filename))
+                            (probe-file filename)))
+      (if (pathnamep filename)    ;; ensure filename is a string to check if already loaded
+          (setq filename (namestring (if (null (pathname-directory filename))
+                                         filename
+                                         ;; lispworks treats as UNC, so use truename
+                                         #+(and lispworks win32) (truename filename)
+                                         #-(and lispworks win32) filename))))
+
+      (if (and (not force-load)
+               (find filename *loaded-libraries* :test #'string-equal))
+          t ;; return T, but don't reload library
+      (progn
+        #+cmu
+        (let ((type (pathname-type (parse-namestring filename))))
+          (if (string-equal type "so")
+              (unless
+                  (sys::load-object-file filename)
+                (load-failure))
+              (alien:load-foreign filename
+                                  :libraries
+                                  (convert-supporting-libraries-to-string
+                                   supporting-libraries))))
+        #+scl
+        (let ((type (pathname-type (parse-namestring filename))))
+          (alien:load-foreign filename
+                              :libraries
+                              (convert-supporting-libraries-to-string
+                               supporting-libraries)))
+        #+sbcl
+        (handler-case (sb-alien::load-1-foreign filename)
+          (sb-int:unsupported-operator (c)
+            (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
+                (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
+                (error c))))
+
+        #+lispworks (fli:register-module module :real-name filename
+                                         :connection-style :immediate)
+        #+allegro (load filename)
+        #+openmcl (ccl:open-shared-library filename)
+        #+digitool (ccl:add-to-shared-library-search-path filename t)
+
+        (push filename *loaded-libraries*)
+        t)))))
+
+(defun convert-supporting-libraries-to-string (libs)
+  (let (lib-load-list)
+    (dolist (lib libs)
+      (push (format nil "-l~A" lib) lib-load-list))
+    (nreverse lib-load-list)))

Added: branches/trunk-reorg/thirdparty/uffi/src/objects.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/objects.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,291 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          objects.lisp
+;;;; Purpose:       UFFI source to handle objects and pointers
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun size-of-foreign-type (type)
+    #+lispworks (fli:size-of type)
+    #+allegro (ff:sizeof-fobject type)
+    #+(or cmu scl)  (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
+    #+sbcl  (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes
+    #+clisp (values (ffi:size-of type))
+    #+digitool
+    (let ((mcl-type (ccl:find-mactype type nil t)))
+      (if mcl-type
+          (ccl::mactype-record-size mcl-type)
+          (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
+    #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
+    ))
+
+(defmacro allocate-foreign-object (type &optional (size :unspecified))
+  "Allocates an instance of TYPE. If size is specified, then allocate
+an array of TYPE with size SIZE. The TYPE parameter is evaluated."
+  (if (eq size :unspecified)
+      (progn
+        #+(or cmu scl)
+        `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+        #+sbcl
+        `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+        #+lispworks
+        `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
+        #+allegro
+        `(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c)
+        #+(or openmcl digitool)
+        `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+        )
+      (progn
+        #+(or cmu scl)
+        `(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+        #+sbcl
+        `(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+        #+lispworks
+        `(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
+        #+allegro
+        `(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c)
+        #+(or openmcl digitool)
+        `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
+        )))
+
+(defmacro free-foreign-object (obj)
+  #+(or cmu scl)
+  `(alien:free-alien ,obj)
+  #+sbcl
+  `(sb-alien:free-alien ,obj)
+  #+lispworks
+  `(fli:free-foreign-object ,obj)
+  #+allegro
+  `(ff:free-fobject ,obj)
+  #+(or openmcl digitool)
+  `(dispose-ptr ,obj)
+  )
+
+(defmacro null-pointer-p (obj)
+  #+lispworks `(fli:null-pointer-p ,obj)
+  #+allegro `(zerop ,obj)
+  #+(or cmu scl)   `(alien:null-alien ,obj)
+  #+sbcl   `(sb-alien:null-alien ,obj)
+  #+(or openmcl digitool)   `(ccl:%null-ptr-p ,obj)
+  )
+
+(defmacro make-null-pointer (type)
+  #+(or allegro openmcl digitool) (declare (ignore type))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type)))
+  #+allegro 0
+  #+(or openmcl digitool) `(ccl:%null-ptr)
+  )
+
+(defmacro make-pointer (addr type)
+  #+(or allegro openmcl digitool) (declare (ignore type))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type)))
+  #+allegro addr
+  #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr)
+  )
+
+
+(defmacro char-array-to-pointer (obj)
+  #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
+  #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
+  #+lispworks `(fli:make-pointer :type '(:unsigned :char)
+                                :address (fli:pointer-address ,obj))
+  #+allegro obj
+  #+(or openmcl digitool) obj
+  )
+
+(defmacro deref-pointer (ptr type)
+  "Returns a object pointed"
+  #+(or cmu sbcl lispworks scl) (declare (ignore type))
+  #+(or cmu scl)  `(alien:deref ,ptr)
+  #+sbcl  `(sb-alien:deref ,ptr)
+  #+lispworks `(fli:dereference ,ptr)
+  #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr)
+  #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
+  )
+
+#+digitool
+(defmacro deref-pointer-set (ptr type value)
+  `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
+
+#+digitool
+(defsetf deref-pointer deref-pointer-set)
+
+(defmacro ensure-char-character (obj)
+  #+(or digitool) obj
+  #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj)
+  ;; lispworks varies whether deref'ing array vs. slot access of a char
+  #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj)))
+
+(defmacro ensure-char-integer (obj)
+  #+(or digitool) `(char-code ,obj)
+  #+(or allegro cmu sbcl scl openmcl) obj
+  ;; lispworks varies whether deref'ing array vs. slot access of a char
+  #+lispworks
+  `(if (integerp ,obj) ,obj (char-code ,obj)))
+
+(defmacro ensure-char-storable (obj)
+  #+(or digitool (and lispworks (not lispworks5))) obj
+  #+(or allegro cmu lispworks5 openmcl sbcl scl)
+  `(char-code ,obj))
+
+(defmacro pointer-address (obj)
+  #+(or cmu scl)
+  `(system:sap-int (alien:alien-sap ,obj))
+  #+sbcl
+  `(sb-sys:sap-int (sb-alien:alien-sap ,obj))
+  #+lispworks
+  `(fli:pointer-address ,obj)
+  #+allegro
+  obj
+  #+(or openmcl digitool)
+  `(ccl:%ptr-to-int ,obj)
+  )
+
+;; TYPE is evaluated.
+#-(or openmcl digitool)
+(defmacro with-foreign-object ((var type) &rest body)
+  #-(or cmu sbcl lispworks scl) ; default version
+  `(let ((,var (allocate-foreign-object ,type)))
+    (unwind-protect
+         (progn , at body)
+      (free-foreign-object ,var)))
+  #+(or cmu scl)
+  (let ((obj (gensym))
+        (ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+        `(alien:with-alien ((,obj ,ctype))
+          (let* ((,var ,obj))
+            , at body))
+        `(alien:with-alien ((,obj ,ctype))
+          (let* ((,var (alien:addr ,obj)))
+            , at body))))
+  #+sbcl
+  (let ((obj (gensym))
+        (ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+        `(sb-alien:with-alien ((,obj ,ctype))
+          (let* ((,var ,obj))
+            , at body))
+        `(sb-alien:with-alien ((,obj ,ctype))
+          (let* ((,var (sb-alien:addr ,obj)))
+            , at body))))
+  #+lispworks
+  `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
+                                              (eval type) :allocate)))
+    , at body)
+  )
+
+#-(or openmcl digitool)
+(defmacro with-foreign-objects (bindings &rest body)
+  (if bindings
+      `(with-foreign-object ,(car bindings)
+        (with-foreign-objects ,(cdr bindings)
+          , at body))
+      `(progn , at body)))
+
+#+(or openmcl digitool)
+(defmacro with-foreign-objects (bindings &rest body)
+  (let ((params nil) type count)
+    (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
+      (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
+      (setf count 1)
+      (when (and (listp type) (eq (first type) :array))
+        (setf count (nth 2 type))
+        (unless (integerp count) (error "Invalid size for array: ~a" type))
+        (setf type (nth 1 type)))
+      (push (list (first spec) (* count (size-of-foreign-type type))) params))
+    `(ccl:%stack-block ,params , at body)))
+
+#+(or openmcl digitool)
+(defmacro with-foreign-object ((var type) &rest body)
+  `(with-foreign-objects ((,var ,type))
+     , at body))
+
+#+lispworks
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  `(fli:with-coerced-pointer (,binding-name
+                          :type ',(convert-from-uffi-type (eval type) :type))
+      ,pointer
+    , at body))
+
+#+(or cmu scl sbcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  `(let ((,binding-name
+          (#+(or cmu scl) alien:cast
+           #+sbcl sb-alien:cast
+           ,pointer (* ,(convert-from-uffi-type (eval type) :type)))))
+    , at body))
+
+#+(or allegro openmcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  (declare (ignore type))
+  `(let ((,binding-name ,pointer))
+    , at body))
+
+#-(or lispworks cmu scl sbcl allegro openmcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  (declare (ignore binding-name pointer type body))
+  '(error "WITH-CAST-POINTER not (yet) implemented for ~A"
+          (lisp-implementation-type)))
+
+#+(or allegro openmcl)
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  #+(or macosx darwinppc-target) (concatenate 'string "_" name)
+  #-(or macosx darwinppc-target) name)
+
+(defmacro def-foreign-var (names type module)
+  #-lispworks (declare (ignore module))
+  (let ((foreign-name (if (atom names) names (first names)))
+        (lisp-name (if (atom names) (make-lisp-name names) (second names)))
+        #-allegro
+        (var-type (convert-from-uffi-type type :type)))
+    #+(or cmu scl)
+    `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type)
+    #+sbcl
+    `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type)
+    #+allegro
+    `(define-symbol-macro ,lisp-name
+      (ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref))
+                            :c (ff:get-entry-point ,(convert-external-name foreign-name))))
+    #+lispworks
+    `(progn
+      (fli:define-foreign-variable (,lisp-name ,foreign-name)
+                                    :accessor :address-of
+                                    :type ,var-type
+                                    :module ,module)
+      (define-symbol-macro ,lisp-name (fli:dereference (,lisp-name)
+                                                        :copy-foreign-object nil)))
+    #+openmcl
+    `(define-symbol-macro ,lisp-name
+       (deref-pointer (ccl:foreign-symbol-address
+                       ,(convert-external-name foreign-name)) ,var-type))
+    #-(or allegro cmu scl sbcl lispworks openmcl)
+    `(define-symbol-macro ,lisp-name
+      '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
+        (lisp-implementation-type)))))
+
+
+;;; Define a special variable, like DEFVAR, that will be initialized
+;;; to a pointer which may need to be reset when a saved image is
+;;; loaded.  This is needed for OpenMCL, which sets pointers to "dead
+;;; macptrs" when a saved image is loaded.
+;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE
+(defmacro def-pointer-var (name value &optional doc)
+  #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
+  #+openmcl `(ccl::defloadvar ,name ,value ,doc))

Added: branches/trunk-reorg/thirdparty/uffi/src/os.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/os.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,79 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          os.lisp
+;;;; Purpose:       Operating system interface for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Sep 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg.
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+(defun getenv (var)
+  "Return the value of the environment variable."
+  #+allegro (sys::getenv (string var))
+  #+clisp (sys::getenv (string var))
+  #+cmu (cdr (assoc (string var) ext:*environment-list* :test #'equalp
+                    :key #'string))
+  #+gcl (si:getenv (string var))
+  #+lispworks (lw:environment-variable (string var))
+  #+lucid (lcl:environment-variable (string var))
+  #+(or openmcl digitool) (ccl::getenv var)
+  #+sbcl (sb-ext:posix-getenv var)
+  #-(or allegro clisp cmu gcl lispworks lucid openmcl digitool sbcl)
+  (error 'not-implemented :proc (list 'getenv var)))
+
+
+;; modified from function ASDF -- Copyright Dan Barlow and Contributors
+
+(defun run-shell-command (control-string  &rest args &key output)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*.  Returns the shell's exit code."
+  (unless output
+    (setq output *trace-output*))
+
+  (let ((command (apply #'format nil control-string args)))
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program
+      "/bin/sh"
+      (list "-c" command)
+      :input nil :output output))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list "-c" command)
+      :input nil :output output))
+
+    #+allegro
+    (excl:run-shell-command command :input nil :output output)
+
+    #+lispworks
+    (system:call-system-showing-output
+     command
+     :shell-type "/bin/sh"
+     :output-stream output)
+
+    #+clisp                             ;XXX not exactly *trace-output*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+
+    #+openmcl
+    (nth-value 1
+               (ccl:external-process-status
+                (ccl:run-program "/bin/sh" (list "-c" command)
+                                 :input nil :output output
+                                 :wait t)))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp.")
+    ))

Added: branches/trunk-reorg/thirdparty/uffi/src/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/package.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,84 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Defines UFFI package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:uffi
+  (:use #:cl)
+  (:export
+
+   ;; immediate types
+   #:def-constant
+   #:def-foreign-type
+   #:def-type
+   #:null-char-p
+
+   ;; aggregate types
+   #:def-enum
+   #:def-struct
+   #:get-slot-value
+   #:get-slot-pointer
+   #:def-array-pointer
+   #:deref-array
+   #:def-union
+
+   ;; objects
+   #:allocate-foreign-object
+   #:free-foreign-object
+   #:with-foreign-object
+   #:with-foreign-objects
+   #:size-of-foreign-type
+   #:pointer-address
+   #:deref-pointer
+   #:ensure-char-character
+   #:ensure-char-integer
+   #:ensure-char-storable
+   #:null-pointer-p
+   #:make-null-pointer
+   #:make-pointer
+   #:pointer-address
+   #:+null-cstring-pointer+
+   #:char-array-to-pointer
+   #:with-cast-pointer
+   #:def-foreign-var
+   #:convert-from-foreign-usb8
+   #:def-pointer-var
+
+   ;; string functions
+   #:convert-from-cstring
+   #:convert-to-cstring
+   #:free-cstring
+   #:with-cstring
+   #:with-cstrings
+   #:convert-from-foreign-string
+   #:convert-to-foreign-string
+   #:allocate-foreign-string
+   #:with-foreign-string
+   #:with-foreign-strings
+   #:foreign-string-length
+
+   ;; function call
+   #:def-function
+
+   ;; Libraries
+   #:find-foreign-library
+   #:load-foreign-library
+   #:default-foreign-library-type
+   #:foreign-library-types
+
+   ;; OS
+   #:run-shell-command
+   #:getenv
+   ))
+
+

Added: branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/primitives.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,311 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          primitives.lisp
+;;;; Purpose:       UFFI source to handle immediate types
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+#+(or openmcl digitool)
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+#+(or openmcl digitool)
+; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
+; So this provides a function to convert any quoted symbols to keywords.
+(defun keyword (obj)
+  (cond ((keywordp obj)
+         obj)
+        ((null obj)
+         nil)
+        ((symbolp obj)
+         (intern (symbol-name obj) *keyword-package*))
+        ((and (listp obj) (eq (car obj) 'cl:quote))
+         (keyword (cadr obj)))
+        ((stringp obj)
+         (intern obj *keyword-package*))
+        (t
+         obj)))
+
+; Wrapper for unexported function we have to use
+#+digitool
+(defmacro def-mcl-type (name type)
+  `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
+
+(defmacro def-constant (name value &key (export nil))
+  "Macro to define a constant and to export it"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defconstant ,name ,value)
+     ,(when export (list 'export `(quote ,name)))
+    ',name))
+
+(defmacro def-type (name type)
+  "Generates a (deftype) statement for CL. Currently, only CMUCL
+supports takes advantage of this optimization."
+  #+(or lispworks allegro openmcl digitool cormanlisp)  (declare (ignore type))
+  #+(or lispworks allegro openmcl digitool cormanlisp) `(deftype ,name () t)
+  #+(or cmu scl)
+  `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+  #+sbcl
+  `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
+  )
+
+(defmacro null-char-p (val)
+  "Returns T if character is NULL"
+  `(zerop ,val))
+
+(defmacro def-foreign-type (name type)
+  #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
+  #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
+  #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+  #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
+  #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
+  #+(or openmcl digitool)
+  (let ((mcl-type (convert-from-uffi-type type :type)))
+    (unless (or (keywordp mcl-type) (consp mcl-type))
+      (setf mcl-type `(quote ,mcl-type)))
+    #+digitool
+    `(def-mcl-type ,(keyword name) ,mcl-type)
+    #+openmcl
+    `(ccl::def-foreign-type ,(keyword name) ,mcl-type))
+  )
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
+  #+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
+                        (make-hash-table :size 20 :test #'eq))
+  )
+
+#+(or cmu scl)
+(defvar *cmu-sbcl-def-type-list*
+    '((:char . (alien:signed 8))
+      (:unsigned-char . (alien:unsigned 8))
+      (:byte . (alien:signed 8))
+      (:unsigned-byte . (alien:unsigned 8))
+      (:short . (alien:signed 16))
+      (:unsigned-short . (alien:unsigned 16))
+      (:int . (alien:signed 32))
+      (:unsigned-int . (alien:unsigned 32))
+      #-x86-64 (:long . (alien:signed 32))
+      #-x86-64 (:unsigned-long . (alien:unsigned 32))
+      #+x86-64 (:long . (alien:signed 64))
+      #+x86-64 (:unsigned-long . (alien:unsigned 64))
+      (:float . alien:single-float)
+      (:double . alien:double-float)
+      (:void . t)
+      )
+  "Conversions in CMUCL for def-foreign-type are different than in def-function")
+
+#+sbcl
+(defvar *cmu-sbcl-def-type-list*
+    '((:char . (sb-alien:signed 8))
+      (:unsigned-char . (sb-alien:unsigned 8))
+      (:byte . (sb-alien:signed 8))
+      (:unsigned-byte . (sb-alien:unsigned 8))
+      (:short . (sb-alien:signed 16))
+      (:unsigned-short . (sb-alien:unsigned 16))
+      (:int . (sb-alien:signed 32))
+      (:unsigned-int . (sb-alien:unsigned 32))
+      #-x86-64 (:long . (sb-alien:signed 32))
+      #-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
+      #+x86-64 (:long . (sb-alien:signed 64))
+      #+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
+      (:float . sb-alien:single-float)
+      (:double . sb-alien:double-float)
+      (:void . t)
+      )
+  "Conversions in SBCL for def-foreign-type are different than in def-function")
+
+(defvar *type-conversion-list* nil)
+
+#+(or cmu scl)
+(setq *type-conversion-list*
+    '((* . *) (:void . c-call:void)
+      (:pointer-void . (* t))
+      (:cstring . c-call:c-string)
+      (:char . c-call:char)
+      (:unsigned-char . (alien:unsigned 8))
+      (:byte . (alien:signed 8))
+      (:unsigned-byte . (alien:unsigned 8))
+      (:short . c-call:short)
+      (:unsigned-short . c-call:unsigned-short)
+      (:int . alien:integer) (:unsigned-int . c-call:unsigned-int)
+      (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+      (:float . c-call:float) (:double . c-call:double)
+      (:array . alien:array)))
+
+#+sbcl
+(setq *type-conversion-list*
+    '((* . *) (:void . sb-alien:void)
+      (:pointer-void . (* t))
+      #-sb-unicode(:cstring . sb-alien:c-string)
+      #+sb-unicode(:cstring . sb-alien:utf8-string)
+      (:char . sb-alien:char)
+      (:unsigned-char . (sb-alien:unsigned 8))
+      (:byte . (sb-alien:signed 8))
+      (:unsigned-byte . (sb-alien:unsigned 8))
+      (:short . sb-alien:short)
+      (:unsigned-short . sb-alien:unsigned-short)
+      (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int)
+      (:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
+      (:float . sb-alien:float) (:double . sb-alien:double)
+      (:array . sb-alien:array)))
+
+#+(or allegro cormanlisp)
+(setq *type-conversion-list*
+    '((* . *) (:void . :void)
+      (:short . :short)
+      (:pointer-void . (* :void))
+      (:cstring . (* :unsigned-char))
+      (:byte . :char)
+      (:unsigned-byte . :unsigned-char)
+      (:char . :char)
+      (:unsigned-char . :unsigned-char)
+      (:int . :int) (:unsigned-int . :unsigned-int)
+      (:long . :long) (:unsigned-long . :unsigned-long)
+      (:float . :float) (:double . :double)
+      (:array . :array)))
+
+#+lispworks
+(setq *type-conversion-list*
+    '((* . :pointer) (:void . :void)
+      (:short . :short)
+      (:pointer-void . (:pointer :void))
+      (:cstring . (:reference-pass (:ef-mb-string :external-format
+                                    (:latin-1 :eol-style :lf))
+                   :allow-null t))
+      (:cstring-returning . (:reference (:ef-mb-string :external-format
+                                         (:latin-1 :eol-style :lf))
+                             :allow-null t))
+      (:byte . :byte)
+      (:unsigned-byte . (:unsigned :byte))
+      (:char . :char)
+      (:unsigned-char . (:unsigned :char))
+      (:int . :int) (:unsigned-int . (:unsigned :int))
+      (:long . :long) (:unsigned-long . (:unsigned :long))
+      (:float . :float) (:double . :double)
+      (:array . :c-array)))
+
+#+digitool
+(setq *type-conversion-list*
+     '((* . :pointer) (:void . :void)
+       (:short . :short) (:unsigned-short . :unsigned-short)
+       (:pointer-void . :pointer)
+       (:cstring . :string)
+       (:char . :character)
+       (:unsigned-char . :unsigned-byte)
+       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+       (:int . :long) (:unsigned-int . :unsigned-long)
+       (:long . :long) (:unsigned-long . :unsigned-long)
+       (:float . :single-float) (:double . :double-float)
+       (:array . :array)))
+
+#+openmcl
+(setq *type-conversion-list*
+     '((* . :address) (:void . :void)
+       (:short . :short) (:unsigned-short . :unsigned-short)
+       (:pointer-void . :address)
+       (:cstring . :address)
+       (:char . :signed-char)
+       (:unsigned-char . :unsigned-char)
+       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+       (:int . :int) (:unsigned-int . :unsigned-int)
+       (:long . :long) (:unsigned-long . :unsigned-long)
+       (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
+       (:float . :single-float) (:double . :double-float)
+       (:array . :array)))
+
+(dolist (type *type-conversion-list*)
+  (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
+
+#+(or cmu sbcl scl)
+(dolist (type *cmu-sbcl-def-type-list*)
+  (setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
+
+(defun basic-convert-from-uffi-type (type)
+  (let ((found-type (gethash type +type-conversion-hash+)))
+    (if found-type
+        found-type
+      #-(or openmcl digitool) type
+      #+(or openmcl digitool) (keyword type))))
+
+(defun %convert-from-uffi-type (type context)
+  "Converts from a uffi type to an implementation specific type"
+  (if (atom type)
+      (cond
+       #+(or allegro cormanlisp)
+       ((and (or (eq context :routine) (eq context :return))
+             (eq type :cstring))
+        (setq type '((* :char) integer)))
+       #+(or cmu sbcl scl)
+       ((eq context :type)
+        (let ((cmu-type (gethash type *cmu-def-type-hash*)))
+          (if cmu-type
+              cmu-type
+              (basic-convert-from-uffi-type type))))
+       #+lispworks
+       ((and (eq context :return)
+             (eq type :cstring))
+        (basic-convert-from-uffi-type :cstring-returning))
+       #+digitool
+       ((and (eq type :void) (eq context :return)) nil)
+       (t
+        (basic-convert-from-uffi-type type)))
+    (let ((sub-type (car type)))
+      (case sub-type
+        (cl:quote
+         (convert-from-uffi-type (cadr type) context))
+        (:struct-pointer
+         #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+         #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
+         )
+        (:struct
+         #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+         #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
+         )
+       (:union
+        #+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+        #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
+        )
+       (t
+        (cons (%convert-from-uffi-type (first type) context)
+              (%convert-from-uffi-type (rest type) context)))))))
+
+(defun convert-from-uffi-type (type context)
+  (let ((result (%convert-from-uffi-type type context)))
+    (cond
+     ((atom result) result)
+     #+openmcl
+     ((eq (car result) :address)
+      (if (eq context :struct)
+          (append '(:*) (cdr result))
+        :address))
+     #+digitool
+     ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
+     (t result))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (char= #\a (schar (symbol-name '#:a) 0))
+    (pushnew :uffi-lowercase-reader *features*))
+  (when (not (string= (symbol-name '#:a)
+                      (symbol-name '#:A)))
+    (pushnew :uffi-case-sensitive *features*)))
+
+(defun make-lisp-name (name)
+  (let ((converted (substitute #\- #\_ name)))
+     (intern
+      #+uffi-case-sensitive converted
+      #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
+      #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :uffi-lowercase-reader *features*))
+  (setq cl:*features* (delete :uffi-case-sensitive *features*)))

Added: branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/readmacros-mcl.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,35 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          readmacros-mcl.lisp
+;;;; Purpose:       This file holds functions using read macros for MCL
+;;;; Programmer:    Kevin M. Rosenberg/John Desoi
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+;; trap macros don't work right directly in the macros
+#+digitool
+(defun new-ptr (size)
+  (#_NewPtr size))
+
+#+digitool
+(defun dispose-ptr (ptr)
+  (#_DisposePtr ptr))
+
+#+openmcl
+(defmacro new-ptr (size)
+  `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+  `(ccl::free ,ptr))
+

Added: branches/trunk-reorg/thirdparty/uffi/src/strings.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/src/strings.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,412 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       UFFI source to handle strings, cstring and foreigns
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+(def-pointer-var +null-cstring-pointer+
+    #+(or cmu sbcl scl) nil
+    #+allegro 0
+    #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
+    #+(or openmcl digitool) (ccl:%null-ptr)
+)
+
+(defmacro convert-from-cstring (obj)
+  "Converts a string from a c-call. Same as convert-from-foreign-string, except
+that LW/CMU automatically converts strings from c-calls."
+  #+(or cmu sbcl lispworks scl) obj
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (zerop ,stored)
+           nil
+           (values (excl:native-to-string ,stored)))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (ccl:%null-ptr-p ,stored)
+           nil
+         (values (ccl:%get-cstring ,stored)))))
+  )
+
+(defmacro convert-to-cstring (obj)
+  #+(or cmu sbcl scl lispworks) obj
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+           0
+           (values (excl:string-to-native ,stored)))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+           +null-cstring-pointer+
+           (let ((ptr (new-ptr (1+ (length ,stored)))))
+             (ccl::%put-cstring ptr ,stored)
+             ptr))))
+  )
+
+(defmacro free-cstring (obj)
+  #+(or cmu sbcl scl lispworks) (declare (ignore obj))
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (zerop ,stored)
+         (ff:free-fobject ,stored))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (ccl:%null-ptr-p ,stored)
+         (dispose-ptr ,stored))))
+  )
+
+(defmacro with-cstring ((cstring lisp-string) &body body)
+  #+(or cmu sbcl scl lispworks)
+  `(let ((,cstring ,lisp-string)) , at body)
+  #+allegro
+  (let ((acl-native (gensym))
+        (stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (excl:with-native-string (,acl-native ,stored-lisp-string)
+         (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
+           , at body))))
+  #+(or openmcl digitool)
+  (let ((stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (if (stringp ,stored-lisp-string)
+           (ccl:with-cstrs ((,cstring ,stored-lisp-string))
+             , at body)
+           (let ((,cstring +null-cstring-pointer+))
+             , at body))))
+  )
+
+(defmacro with-cstrings (bindings &rest body)
+  (if bindings
+      `(with-cstring ,(car bindings)
+        (with-cstrings ,(cdr bindings)
+          , at body))
+      `(progn , at body)))
+
+;;; Foreign string functions
+
+(defmacro convert-to-foreign-string (obj)
+  #+lispworks
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+           +null-cstring-pointer+
+           (fli:convert-to-foreign-string
+            ,stored
+            :external-format '(:latin-1 :eol-style :lf)))))
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+           0
+           (values (excl:string-to-native ,stored)))))
+  #+(or cmu scl)
+  (let ((size (gensym))
+        (storage (gensym))
+        (stored-obj (gensym))
+        (i (gensym)))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+         (null
+          (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+         (string
+          (let* ((,size (length ,stored-obj))
+                 (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+            (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+            (locally
+                (declare (optimize (speed 3) (safety 0)))
+              (dotimes (,i ,size)
+                (declare (fixnum ,i))
+                (setf (alien:deref ,storage ,i)
+                      (char-code (char ,stored-obj ,i))))
+           (setf (alien:deref ,storage ,size) 0))
+         ,storage)))))
+  #+sbcl
+  (let ((size (gensym))
+        (storage (gensym))
+        (stored-obj (gensym))
+        (i (gensym)))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+         (null
+          (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+         (string
+          (let* ((,size (length ,stored-obj))
+                 (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+            (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+            (locally
+                (declare (optimize (speed 3) (safety 0)))
+              (dotimes (,i ,size)
+                (declare (fixnum ,i))
+                (setf (sb-alien:deref ,storage ,i)
+                      (char-code (char ,stored-obj ,i))))
+              (setf (sb-alien:deref ,storage ,size) 0))
+            ,storage)))))
+  #+(or openmcl digitool)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null ,stored-obj)
+           +null-cstring-pointer+
+           (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
+             (ccl::%put-cstring ptr ,stored-obj)
+             ptr))))
+  )
+
+;; Either length or null-terminated-p must be non-nil
+(defmacro convert-from-foreign-string (obj &key
+                                           length
+                                           (locale :default)
+                                           (null-terminated-p t))
+  #+allegro
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (zerop ,stored-obj)
+           nil
+           (if (eq ,locale :none)
+               (fast-native-to-string ,stored-obj ,length)
+               (values
+                (excl:native-to-string
+                 ,stored-obj
+                 ,@(when length (list :length length))
+                 :truncate (not ,null-terminated-p)))))))
+  #+lispworks
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (fli:null-pointer-p ,stored-obj)
+           nil
+           (if (eq ,locale :none)
+               (fast-native-to-string ,stored-obj ,length)
+               (fli:convert-from-foreign-string
+                ,stored-obj
+                ,@(when length (list :length length))
+                :null-terminated-p ,null-terminated-p
+                :external-format '(:latin-1 :eol-style :lf))))))
+  #+(or cmu scl)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+           nil
+           (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
+                                     :length ,length
+                                     :null-terminated-p ,null-terminated-p))))
+
+  #+sbcl
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+            nil
+            (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
+                                     :length ,length
+                                     :null-terminated-p ,null-terminated-p))))
+  #+(or openmcl digitool)
+  (declare (ignore null-terminated-p))
+  #+(or openmcl digitool)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (ccl:%null-ptr-p ,stored-obj)
+           nil
+           #+digitool (ccl:%get-cstring
+                                      ,stored-obj 0
+                                      ,@(if length (list length) nil))
+           #+openmcl ,@(if length
+                           `((ccl:%str-from-ptr ,stored-obj ,length))
+                           `((ccl:%get-cstring ,stored-obj))))))
+  )
+
+
+(defmacro allocate-foreign-string (size &key (unsigned t))
+  #+ignore
+  (let ((array-def (gensym)))
+    `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
+       (eval `(alien:cast (alien:make-alien ,,array-def)
+                          ,(if ,unsigned
+                               '(* (alien:unsigned 8))
+                             '(* (alien:signed 8)))))))
+
+  #+(or cmu scl)
+  `(alien:make-alien ,(if unsigned
+                             '(alien:unsigned 8)
+                             '(alien:signed 8))
+    ,size)
+
+  #+sbcl
+  `(sb-alien:make-alien ,(if unsigned
+                             '(sb-alien:unsigned 8)
+                             '(sb-alien:signed 8))
+    ,size)
+
+  #+lispworks
+  `(fli:allocate-foreign-object :type
+                                ,(if unsigned
+                                     ''(:unsigned :char)
+                                   :char)
+                                :nelems ,size)
+  #+allegro
+  (declare (ignore unsigned))
+  #+allegro
+  `(ff:allocate-fobject :char :c ,size)
+  #+(or openmcl digitool)
+  (declare (ignore unsigned))
+  #+(or openmcl digitool)
+  `(new-ptr ,size)
+  )
+
+(defun foreign-string-length (foreign-string)
+  #+allegro `(ff:foreign-strlen ,foreign-string)
+  #-allegro
+  `(loop with size = 0
+    until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
+    do (incf size)
+    finally return size))
+
+
+(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
+  (let ((result (gensym)))
+    `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
+            (,result (progn , at body)))
+      (declare (dynamic-extent ,foreign-string))
+      (free-foreign-object ,foreign-string)
+      ,result)))
+
+(defmacro with-foreign-strings (bindings &body body)
+  `(with-foreign-string ,(car bindings)
+    ,@(if (cdr bindings)
+          `((with-foreign-strings ,(cdr bindings) , at body))
+          body)))
+
+;; Modified from CMUCL's source to handle non-null terminated strings
+#+cmu
+(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((null-terminated-length
+           (when null-terminated-p
+             (loop
+                 for offset of-type fixnum upfrom 0
+                 until (zerop (system:sap-ref-8 sap offset))
+                 finally (return offset)))))
+      (if length
+          (if (and null-terminated-length
+                   (> (the fixnum length) (the fixnum null-terminated-length)))
+              (setq length null-terminated-length))
+        (setq length null-terminated-length)))
+    (let ((result (make-string length)))
+      (kernel:copy-from-system-area sap 0
+                                    result (* vm:vector-data-offset
+                                              vm:word-bits)
+                                    (* length vm:byte-bits))
+      result)))
+
+#+scl
+;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL,
+;; so have to iteratively copy from sap
+(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((null-terminated-length
+           (when null-terminated-p
+             (loop
+                 for offset of-type fixnum upfrom 0
+                 until (zerop (system:sap-ref-8 sap offset))
+                 finally (return offset)))))
+      (if length
+          (if (and null-terminated-length
+                   (> (the fixnum length) (the fixnum null-terminated-length)))
+              (setq length null-terminated-length))
+        (setq length null-terminated-length)))
+    (let ((result (make-string length)))
+      (dotimes (i length)
+        (declare (type fixnum i))
+        (setf (char result i) (code-char (system:sap-ref-8 sap i))))
+      result)))
+
+#+(and sbcl (not sb-unicode))
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type sb-sys:system-area-pointer sap)
+           (type (or null fixnum) length))
+  (locally
+   (declare (optimize (speed 3) (safety 0)))
+   (let ((null-terminated-length
+          (when null-terminated-p
+            (loop
+             for offset of-type fixnum upfrom 0
+             until (zerop (sb-sys:sap-ref-8 sap offset))
+             finally (return offset)))))
+     (if length
+         (if (and null-terminated-length
+                  (> (the fixnum length) (the fixnum null-terminated-length)))
+             (setq length null-terminated-length))
+       (setq length null-terminated-length)))
+   (let ((result (make-string length)))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+                (* length +system-copy-multiplier+))
+       result)))
+
+#+(and sbcl sb-unicode)
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type sb-sys:system-area-pointer sap)
+           (type (or null fixnum) length))
+  (locally
+   (declare (optimize (speed 3) (safety 0)))
+   (cond
+    (null-terminated-p
+     (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+                                  #+sb-unicode sb-alien:utf8-string
+                                  #-sb-unicode sb-alien:c-string)))
+       (if length
+           (copy-seq (subseq casted 0 length))
+         (copy-seq casted))))
+    (t
+     (let ((result (make-string length)))
+       ;; this will not work in sb-unicode
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+                (* length +system-copy-multiplier+))
+       result)))))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+   (def-function "strlen"
+     ((str (* :unsigned-char)))
+     :returning :unsigned-int))
+
+(def-type char-ptr-def (* :unsigned-char))
+
+#+(or (and allegro (not ics)) (and lispworks (not lispworks5)))
+(defun fast-native-to-string (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+           (type char-ptr-def s))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
+    (declare (fixnum len)
+             (type (simple-array #+lispworks base-char
+                                 #-lispworks (signed-byte 8) (*)) str))
+    (dotimes (i len str)
+      (setf (aref str i)
+        (uffi:deref-array s '(:array :char) i)))))
+
+#+(or (and allegro ics) lispworks5)
+(defun fast-native-to-string (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+           (type char-ptr-def s))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
+      (dotimes (i len str)
+        (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))

Added: branches/trunk-reorg/thirdparty/uffi/tests/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/Makefile	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,30 @@
+# FILE IDENTIFICATION
+#
+#  Name:         Makefile
+#  Purpose:      Makefile for UFFI examples
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id$
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+SUBDIRS=
+
+include ../Makefile.common
+
+base=uffi-c-test
+source=$(base).c
+object=$(base).o
+shared_lib=$(base).so
+
+.PHONY: all
+all: $(shared_lib)
+
+$(shared_lib): $(source) Makefile
+	BASE=$(base) OBJECT=$(object) SOURCE=$(source) SHARED_LIB=$(shared_lib) sh make.sh
+	rm $(object)
+
+.PHONY: distclean
+distclean: clean
+	rm -f $(base).dylib $(base).dylib $(base).so $(base).o

Added: branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/Makefile.msvc	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,28 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile.msvc
+#  Purpose:      Makefile for the CLSQL UFFI helper package (MSVC)
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $
+#
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+#
+
+BASE=c-test-fns
+
+# Nothing to configure beyond here
+
+SRC=$(BASE).c
+OBJ=$(BASE).obj
+DLL=$(BASE).dll
+
+$(DLL): $(SRC)
+	cl /MD /LD -D_MT /DWIN32=1 $(SRC)
+        del $(OBJ) $(BASE).exp
+
+clean:
+        del /q $(DLL)
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/arrays.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,57 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          arrays.lisp
+;;;; Purpose:       UFFI test arrays
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(uffi:def-foreign-type long-ptr (* :long))
+
+(deftest :array.1
+    (let ((a (uffi:allocate-foreign-object :long +column-length+))
+          (results nil))
+      (dotimes (i +column-length+)
+        (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+      (dotimes (i +column-length+)
+        (push (uffi:deref-array a '(:array :long) i) results))
+      (uffi:free-foreign-object a)
+      (nreverse results))
+  (0 1 4 9 16 25 36 49 64 81))
+
+
+(deftest :array.2
+    (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+))
+          (results nil))
+      (dotimes (r +row-length+)
+        (declare (fixnum r))
+        (setf (uffi:deref-array a '(:array (* :long)) r)
+              (uffi:allocate-foreign-object :long +column-length+))
+        (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+          (dotimes (c +column-length+)
+            (declare (fixnum c))
+            (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+
+      (dotimes (r +row-length+)
+        (declare (fixnum r))
+        (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+          (dotimes (c +column-length+)
+            (declare (fixnum c))
+            (push (uffi:deref-array col '(:array :long) c) results))))
+      (uffi:free-foreign-object a)
+      (nreverse results))
+  (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99))
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/atoifl.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,42 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          atoifl.lisp
+;;;; Purpose:       UFFI Example file to atoi/atof/atol
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("atoi" c-atoi)
+    ((str :cstring))
+  :returning :int)
+
+(uffi:def-function ("atol" c-atol)
+    ((str :cstring))
+  :returning :long)
+
+(uffi:def-function ("atof" c-atof)
+    ((str :cstring))
+  :returning :double)
+
+(defun atoi (str)
+  "Returns a int from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atoi str-cstring)))
+
+(defun atof (str)
+  "Returns a double float from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atof str-cstring)))
+
+(deftest :atoi.1 (atoi "123") 123)
+(deftest :atoi.2 (atoi "") 0)
+(deftest :atof.3 (atof "2.23") 2.23d0)

Added: branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/casts.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,51 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICAION
+;;;;
+;;;; Name:          casts.lisp
+;;;; Purpose:       Tests of with-cast-pointer
+;;;; Programmer:    Kevin M. Rosenberg / Edi Weitz
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("cast_test_int" cast-test-int)
+    ()
+  :module "uffi_tests"
+  :returning :pointer-void)
+
+(uffi:def-function ("cast_test_float" cast-test-float)
+    ()
+  :module "uffi_tests"
+  :returning :pointer-void)
+
+(deftest :cast.1
+  (progn
+    (uffi:with-cast-pointer (temp (cast-test-int) :int)
+      (assert (= (uffi:deref-pointer temp :int) 23)))
+    (let ((result (cast-test-int)))
+      (uffi:with-cast-pointer (result2 result :int)
+        (assert (= (uffi:deref-pointer result2 :int) 23)))
+      (uffi:with-cast-pointer (temp result :int)
+        (assert (= (uffi:deref-pointer temp :int) 23))))
+    t)
+  t)
+
+(deftest :cast.2
+    (progn
+      (uffi:with-cast-pointer (temp (cast-test-float) :double)
+        (assert (= (uffi:deref-pointer temp :double) 3.21d0)))
+      (let ((result (cast-test-float)))
+        (uffi:with-cast-pointer (result2 result :double)
+          (assert (= (uffi:deref-pointer result2 :double) 3.21d0)))
+        (uffi:with-cast-pointer (temp result :double)
+          (assert (= (uffi:deref-pointer temp :double) 3.21d0))))
+      t)
+  t)
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/compress.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,92 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          compress.lisp
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("compress" c-compress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun compress (source)
+  "Returns two values: array of bytes containing the compressed data
+ and the numbe of compressed bytes"
+  (let* ((sourcelen (length source))
+         (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+         (dest (uffi:allocate-foreign-string destsize :unsigned t))
+         (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-compress dest destlen source-native sourcelen))
+            (newdestlen (uffi:deref-pointer destlen :long)))
+        (unwind-protect
+            (if (zerop result)
+                (values (uffi:convert-from-foreign-usb8
+                         dest newdestlen)
+                        newdestlen)
+              (error "zlib error, code ~D" result))
+          (progn
+            (uffi:free-foreign-object destlen)
+            (uffi:free-foreign-object dest)))))))
+
+(uffi:def-function ("uncompress" c-uncompress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun uncompress (source)
+  (let* ((sourcelen (length source))
+         (destsize 200000)  ;adjust as needed
+         (dest (uffi:allocate-foreign-string destsize :unsigned t))
+         (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-uncompress dest destlen source-native sourcelen))
+            (newdestlen (uffi:deref-pointer destlen :long)))
+        (unwind-protect
+             (if (zerop result)
+                 (uffi:convert-from-foreign-string
+                  dest
+                  :length newdestlen
+                  :null-terminated-p nil)
+                 (error "zlib error, code ~D" result))
+          (progn
+            (uffi:free-foreign-object destlen)
+            (uffi:free-foreign-object dest)))))))
+
+(deftest :compress.1 (compress "")
+  #(120 156 3 0 0 0 0 1) 8)
+(deftest :compress.2  (compress "test")
+  #(120 156 43 73 45 46 1 0 4 93 1 193) 12)
+(deftest :compress.3 (compress "test2")
+  #(120 156 43 73 45 46 49 2 0 6 80 1 243) 13)
+
+(defun compress-uncompress (str)
+  (multiple-value-bind (compressed len) (compress str)
+    (declare (ignore len))
+    (multiple-value-bind (uncompressed len2) (uncompress compressed)
+      (declare (ignore len2))
+      uncompressed)))
+
+
+(deftest :uncompress.1 "" "")
+(deftest :uncompress.2 "test" "test")
+(deftest :uncompress.3 "test2" "test2")

Added: branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/foreign-loader.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,47 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          foreign-loader.lisp
+;;;; Purpose:       Loads foreign libraries
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+;;; For CMUCL, it's necessary to load foreign files separate from their
+;;; usage
+
+(in-package uffi-tests)
+
+#+clisp (uffi:load-foreign-library "/usr/lib/libz.so" :module "z")
+#-clisp
+(unless (uffi:load-foreign-library
+         (uffi:find-foreign-library
+          #-(or macosx darwin)
+          "libz"
+          #+(or macosx darwin)
+          "z"
+          (list (pathname-directory *load-pathname*)
+                "/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/"
+                "/usr/lib/" "/zlib/"))
+         :module "zlib"
+         :supporting-libraries '("c"))
+  (warn "Unable to load zlib"))
+
+#+clisp (uffi:load-foreign-library "/home/kevin/debian/src/uffi/tests/uffi-c-test.so" :module "uffi_tests")
+#-clisp
+(unless (uffi:load-foreign-library
+         (uffi:find-foreign-library
+          '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test")
+          (list (pathname-directory *load-truename*)
+                "/usr/lib/uffi/"
+                "/home/kevin/debian/src/uffi/tests/"))
+         :supporting-libraries '("c")
+         :module "uffi_tests")
+  (warn "Unable to load uffi-c-test library"))
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/foreign-var.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,88 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          foreign-var
+;;;; Purpose:       Tests of foreign variables
+;;;; Authors:       Kevin M. Rosenberg and Edi Weitz
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(def-foreign-var "uchar_13" :unsigned-byte "uffi_tests")
+(def-foreign-var "schar_neg_120" :byte "uffi_tests")
+(def-foreign-var "uword_257" :unsigned-short "uffi_tests")
+(def-foreign-var "sword_neg_321" :short "uffi_tests")
+(def-foreign-var "uint_1234567" :int "uffi_tests")
+(def-foreign-var "sint_neg_123456" :int "uffi_tests")
+(def-foreign-var "float_neg_4_5" :float "uffi_tests")
+(def-foreign-var "double_3_1" :double "uffi_tests")
+
+(deftest :fvar.1 uchar-13 13)
+(deftest :fvar.2 schar-neg-120 -120)
+(deftest :fvar.3 uword-257 257)
+(deftest :fvar.4 sword-neg-321 -321)
+(deftest :fvar.5 uint-1234567 1234567)
+(deftest :fvar.6 sint-neg-123456 -123456)
+(deftest :fvar.7 float-neg-4-5 -4.5f0)
+(deftest :fvar.8 double-3-1 3.1d0)
+
+(uffi:def-foreign-var ("fvar_addend" *fvar-addend*) :int "uffi_tests")
+
+(uffi:def-struct fvar-struct
+    (i :int)
+  (d :double))
+
+(uffi:def-foreign-var ("fvar_struct" *fvar-struct*) fvar-struct
+  "uffi_tests")
+
+(uffi:def-function ("fvar_struct_int" fvar-struct-int)
+    ()
+  :returning :int
+  :module "uffi_tests")
+
+  (uffi:def-function ("fvar_struct_double" fvar-struct-double)
+      ()
+    :returning :double
+    :module "uffi_tests")
+
+(deftest :fvarst.1 *fvar-addend* 3)
+(deftest :fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42)
+(deftest :fvarst.3 (= (+ *fvar-addend*
+                        (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))
+                     (fvar-struct-int))
+  t)
+(deftest :fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0)
+(deftest :fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd)
+                     (fvar-struct-double))
+  t)
+
+(deftest fvarst.6
+    (let ((orig *fvar-addend*))
+      (incf *fvar-addend* 3)
+      (prog1
+          *fvar-addend*
+        (setf *fvar-addend* orig)))
+  6)
+
+(deftest fvarst.7
+    (let ((orig *fvar-addend*))
+      (incf *fvar-addend* 3)
+      (prog1
+          (fvar-struct-int)
+        (setf *fvar-addend* orig)))
+  48)
+
+(deftest fvarst.8
+    (let ((orig (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i)))
+      (decf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 10)
+      (prog1
+          (fvar-struct-int)
+        (setf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) orig)))
+  35)

Added: branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/getenv.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,64 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv.lisp
+;;;; Purpose:       UFFI Example file to get environment variable
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+(uffi:def-function ("getenv" c-getenv)
+    ((name :cstring))
+  :returning :cstring)
+
+(uffi:def-function ("setenv" c-setenv)
+    ((name :cstring)
+     (value :cstring)
+     (overwrite :int))
+  :returning :int)
+
+(uffi:def-function ("unsetenv" c-unsetenv)
+    ((name :cstring))
+  :returning :void)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+
+(defun my-setenv (key name &optional (overwrite t))
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (check-type name string)
+  (setq overwrite (if overwrite 1 0))
+  (uffi:with-cstrings ((key-native key)
+                       (name-native name))
+    (c-setenv key-native name-native (if overwrite 1 0))))
+
+(defun my-unsetenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstrings ((key-native key))
+    (c-unsetenv key-native)))
+
+(deftest :getenv.1 (progn
+                    (my-unsetenv "__UFFI_FOO1__")
+                    (my-getenv "__UFFI_FOO1__"))
+  nil)
+(deftest :getenv.2 (progn
+                    (my-setenv "__UFFI_FOO1__" "UFFI-TEST")
+                    (my-getenv "__UFFI_FOO1__"))
+  "UFFI-TEST")
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/gethostname.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,52 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gethostname.lisp
+;;;; Purpose:       UFFI Example file to get hostname of system
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (uffi:def-function ("gethostname" c-gethostname)
+      ((name (* :unsigned-char))
+       (len :int))
+    :returning :int)
+
+  (defun gethostname ()
+    "Returns the hostname"
+    (let* ((name (uffi:allocate-foreign-string 256))
+           (result-code (c-gethostname name 256))
+           (hostname (when (zerop result-code)
+                       (uffi:convert-from-foreign-string name))))
+      (uffi:free-foreign-object name)
+      (unless (zerop result-code)
+        (error "gethostname() failed."))
+      hostname))
+
+  (defun gethostname2 ()
+    "Returns the hostname"
+    (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+      (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+          (uffi:convert-from-foreign-string name)
+          (error "gethostname() failed.")))))
+
+(deftest :gethostname.1 (stringp (gethostname)) t)
+(deftest :gethostname.2 (stringp (gethostname2)) t)
+(deftest :gethostname.3 (plusp (length (gethostname))) t)
+(deftest :gethostname.4 (plusp (length (gethostname2))) t)
+(deftest :gethostname.5 (string= (gethostname) (gethostname2)) t)
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/make.sh
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/make.sh	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,45 @@
+#!/bin/sh
+
+case "`uname`" in
+    Linux) os_linux=1 ;;
+    FreeBSD) os_freebsd=1 ;;
+    GNU/kFreeBSD) os_gnukfreebsd=1;;
+    Darwin) os_darwin=1 ;;
+    SunOS) os_sunos=1 ;;
+    AIX) os_aix=1 ;;
+    GNU) os_gnu=1 ;;
+    *) echo "Unable to identify uname " `uname`
+       exit 1 ;;
+esac
+
+if [ "$os_linux" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_gnu" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_freebsd" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_gnukfreebsd" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_darwin" ]; then
+    cc -dynamic -c $SOURCE -o $OBJECT
+    ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT
+    ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib
+
+elif [ "$os_sunos" ]; then
+    cc -KPIC -c $SOURCE -o $OBJECT
+    cc -G $OBJECT -o $SHARED_LIB
+
+elif [ "$os_aix" ]; then
+    gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $SOURCE
+    make_shared -o $SHARED_LIB $OBJECT
+fi
+
+exit 0

Added: branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/objects.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,70 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          pointers.lisp
+;;;; Purpose:       Test file for UFFI pointers
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(deftest :chptr.1
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+        (ensure-char-character
+         (deref-pointer fs :char))))
+  #\t)
+
+(deftest :chptr.2
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+        (ensure-char-character
+         (deref-pointer fs :unsigned-char))))
+  #\t)
+
+(deftest :chptr.3
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+        (ensure-char-integer
+         (deref-pointer fs :unsigned-char))))
+  116)
+
+(deftest :chptr.4
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+        (integerp
+         (ensure-char-integer
+          (deref-pointer fs :unsigned-char)))))
+  t)
+
+(deftest :chptr.5
+    (let ((fs (uffi:allocate-foreign-object :unsigned-char 128)))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+            (uffi:ensure-char-storable #\a))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+            (uffi:ensure-char-storable (code-char 0)))
+      (uffi:convert-from-foreign-string fs))
+  "a")
+
+;; This produces an array which needs fli:foreign-aref to access
+;; rather than fli:dereference
+
+#-lispworks
+(deftest :chptr.6
+    (uffi:with-foreign-object (fs '(:array :unsigned-char 128))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+            (uffi:ensure-char-storable #\a))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+            (uffi:ensure-char-storable (code-char 0)))
+      (uffi:convert-from-foreign-string fs))
+  "a")
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/package.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,20 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Package file uffi testing suite
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(defpackage #:uffi-tests
+  (:use #:asdf #:cl #:uffi #:rtest)
+  (:shadowing-import-from #:uffi #:run-shell-command))
+
+(in-package #:uffi-tests)
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/rt.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,254 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ |                                                                            |
+ | Permission  to  use,  copy, modify, and distribute this software  and  its |
+ | documentation for any purpose  and without fee is hereby granted, provided |
+ | that this copyright  and  permission  notice  appear  in  all  copies  and |
+ | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
+ | advertising or  publicity  pertaining  to  distribution  of  the  software |
+ | without   specific,   written   prior   permission.      M.I.T.  makes  no |
+ | representations  about  the  suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty.                |
+ |                                                                            |
+ |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
+ |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
+ |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
+ |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
+ |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
+ |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
+ |  SOFTWARE.                                                                 |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+  (:nicknames #:rtest #-lispworks #:rt)
+  (:use #:cl)
+  (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+           #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+           #:rem-all-tests #:rem-test)
+  (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+  "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+  "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+  "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+                  (:type list))
+  pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+  (do ((l (cdr *entries*) (cdr l))
+       (r nil))
+      ((null l) (nreverse r))
+    (when (pend (car l))
+      (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+  (setq *entries* (list nil))
+  nil)
+
+(defun rem-test (&optional (name *test*))
+  (do ((l *entries* (cdr l)))
+      ((null (cdr l)) nil)
+    (when (equal (name (cadr l)) name)
+      (setf (cdr l) (cddr l))
+      (return name))))
+
+(defun get-test (&optional (name *test*))
+  (defn (get-entry name)))
+
+(defun get-entry (name)
+  (let ((entry (find name (cdr *entries*)
+                     :key #'name
+                     :test #'equal)))
+    (when (null entry)
+      (report-error t
+        "~%No test with name ~:@(~S~)."
+        name))
+    entry))
+
+(defmacro deftest (name form &rest values)
+  `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+  (setq entry (copy-list entry))
+  (do ((l *entries* (cdr l))) (nil)
+    (when (null (cdr l))
+      (setf (cdr l) (list entry))
+      (return nil))
+    (when (equal (name (cadr l))
+                 (name entry))
+      (setf (cadr l) entry)
+      (report-error nil
+        "Redefining test ~:@(~S~)"
+        (name entry))
+      (return nil)))
+  (when *do-tests-when-defined*
+    (do-entry entry))
+  (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+  (cond (*debug*
+         (apply #'format t args)
+         (if error? (throw '*debug* nil)))
+        (error? (apply #'error args))
+        (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+  (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+  "Like EQUALP, but doesn't do case conversion of characters."
+  (cond
+   ((eq x y) t)
+   ((consp x)
+    (and (consp y)
+         (equalp-with-case (car x) (car y))
+         (equalp-with-case (cdr x) (cdr y))))
+   ((and (typep x 'array)
+         (= (array-rank x) 0))
+    (equalp-with-case (aref x) (aref y)))
+   ((typep x 'vector)
+    (and (typep y 'vector)
+         (let ((x-len (length x))
+               (y-len (length y)))
+           (and (eql x-len y-len)
+                (loop
+                 for e1 across x
+                 for e2 across y
+                 always (equalp-with-case e1 e2))))))
+   ((and (typep x 'array)
+         (typep y 'array)
+         (not (equal (array-dimensions x)
+                     (array-dimensions y))))
+    nil)
+   ((typep x 'array)
+    (and (typep y 'array)
+         (let ((size (array-total-size x)))
+           (loop for i from 0 below size
+                 always (equalp-with-case (row-major-aref x i)
+                                          (row-major-aref y i))))))
+   (t (eql x y))))
+
+(defun do-entry (entry &optional
+                       (s *standard-output*))
+  (catch '*in-test*
+    (setq *test* (name entry))
+    (setf (pend entry) t)
+    (let* ((*in-test* t)
+           ;; (*break-on-warnings* t)
+           (aborted nil)
+           r)
+      ;; (declare (special *break-on-warnings*))
+
+      (block aborted
+        (setf r
+              (flet ((%do
+                      ()
+                      (if *compile-tests*
+                          (multiple-value-list
+                           (funcall (compile
+                                     nil
+                                     `(lambda ()
+                                        (declare
+                                         (optimize ,@*optimization-settings*))
+                                        ,(form entry)))))
+                        (multiple-value-list
+                         (eval (form entry))))))
+                (if *catch-errors*
+                    (handler-bind
+                        ((style-warning #'muffle-warning)
+                         (error #'(lambda (c)
+                                    (setf aborted t)
+                                    (setf r (list c))
+                                    (return-from aborted nil))))
+                      (%do))
+                  (%do)))))
+
+      (setf (pend entry)
+            (or aborted
+                (not (equalp-with-case r (vals entry)))))
+
+      (when (pend entry)
+        (let ((*print-circle* *print-circle-on-failure*))
+          (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+                  *test* (form entry)
+                  (length (vals entry))
+                  (vals entry))
+          (format s "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+                  (length r) r)))))
+  (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+  (if *in-test*
+      (throw '*in-test* nil)
+      (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+                 (out *standard-output*))
+  (dolist (entry (cdr *entries*))
+    (setf (pend entry) t))
+  (if (streamp out)
+      (do-entries out)
+      (with-open-file
+          (stream out :direction :output)
+        (do-entries stream))))
+
+(defun do-entries (s)
+  (format s "~&Doing ~A pending test~:P ~
+             of ~A tests total.~%"
+          (count t (cdr *entries*)
+                 :key #'pend)
+          (length (cdr *entries*)))
+  (dolist (entry (cdr *entries*))
+    (when (pend entry)
+      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+              (do-entry entry s))))
+  (let ((pending (pending-tests))
+        (expected-table (make-hash-table :test #'equal)))
+    (dolist (ex *expected-failures*)
+      (setf (gethash ex expected-table) t))
+    (let ((new-failures
+           (loop for pend in pending
+                 unless (gethash pend expected-table)
+                 collect pend)))
+      (if (null pending)
+          (format s "~&No tests failed.")
+        (progn
+          (format s "~&~A out of ~A ~
+                   total tests failed: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+                  (length pending)
+                  (length (cdr *entries*))
+                  pending)
+          (if (null new-failures)
+              (format s "~&No unexpected failures.")
+            (when *expected-failures*
+              (format s "~&~A unexpected failures: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+                    (length new-failures)
+                    new-failures)))
+          ))
+      (null pending))))

Added: branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/strtol.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,64 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strtol.lisp
+;;;; Purpose:       UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-foreign-type char-ptr (* :unsigned-char))
+
+;; This example does not use :cstring to pass the input string since
+;; the routine needs to do pointer arithmetic to see how many characters
+;; were parsed
+
+(uffi:def-function ("strtol" c-strtol)
+    ((nptr char-ptr)
+     (endptr (* char-ptr))
+     (base :int))
+  :returning :long)
+
+(defun strtol (str &optional (base 10))
+  "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+their was no string at all, or an integer indicating position in string
+of first non-valid character"
+  (let* ((str-native (uffi:convert-to-foreign-string str))
+         (endptr (uffi:allocate-foreign-object 'char-ptr))
+         (value (c-strtol str-native endptr base))
+         (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+
+    (unwind-protect
+         (if (uffi:null-pointer-p endptr-value)
+             (values value t)
+             (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+                   (chars-parsed (- (uffi:pointer-address endptr-value)
+                                    (uffi:pointer-address str-native))))
+               (cond
+                 ((zerop chars-parsed)
+                  (values nil nil))
+                 ((uffi:null-char-p next-char-value)
+                  (values value t))
+                 (t
+                  (values value chars-parsed)))))
+      (progn
+        (uffi:free-foreign-object str-native)
+        (uffi:free-foreign-object endptr)))))
+
+(deftest :strtol.1 (strtol "123") 123 t)
+(deftest :strtol.2 (strtol "0") 0 t)
+(deftest :strtol.3 (strtol "55a") 55 2)
+(deftest :strtol.4 (strtol "a") nil nil)
+
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/structs.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,36 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          structs.lisp
+;;;; Purpose:       Test file for UFFI structures
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+;; Compilation failure as reported by Edi Weitz
+
+
+(uffi:def-struct foo
+    (bar :pointer-self))
+
+(uffi:def-foreign-type foo-ptr (* foo))
+
+;; tests that compilation worked
+(deftest :structs.1
+  (with-foreign-object (p 'foo)
+    t)
+  t)
+
+(deftest :structs.2
+    (progn
+      (uffi:def-foreign-type foo-struct (:struct foo))
+      t)
+  t)

Added: branches/trunk-reorg/thirdparty/uffi/tests/time.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/time.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,110 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          time.lisp
+;;;; Purpose:       UFFI test file, time, use C structures
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+    (sec :int)
+  (min :int)
+  (hour :int)
+  (mday :int)
+  (mon :int)
+  (year :int)
+  (wday :int)
+  (yday :int)
+  (isdst :int)
+  ;; gmoffset present on SusE SLES9
+  (gmoffset :long))
+
+(uffi:def-function ("time" c-time)
+    ((time (* time-t)))
+  :returning time-t)
+
+(uffi:def-function "gmtime"
+    ((time (* time-t)))
+  :returning (:struct-pointer tm))
+
+(uffi:def-function "asctime"
+    ((time (:struct-pointer tm)))
+  :returning :cstring)
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (:struct-pointer tm))
+
+(deftest :time.1
+   (uffi:with-foreign-object (time 'time-t)
+     (setf (uffi:deref-pointer time :unsigned-long) 7381)
+     (uffi:deref-pointer time :unsigned-long))
+  7381)
+
+(deftest :time.2
+  (uffi:with-foreign-object (time 'time-t)
+    (setf (uffi:deref-pointer time :unsigned-long) 7381)
+    (let ((tm-ptr (the tm-pointer (gmtime time))))
+      (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+              (uffi:get-slot-value tm-ptr 'tm 'mday)
+              (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+              (uffi:get-slot-value tm-ptr 'tm 'hour)
+              (uffi:get-slot-value tm-ptr 'tm 'min)
+              (uffi:get-slot-value tm-ptr 'tm 'sec)
+              )))
+  1 1 1970 2 3 1)
+
+
+(uffi:def-struct timeval
+    (secs :long)
+  (usecs :long))
+
+(uffi:def-struct timezone
+    (minutes-west :int)
+  (dsttime :int))
+
+(uffi:def-function ("gettimeofday" c-gettimeofday)
+    ((tv (* timeval))
+     (tz (* timezone)))
+  :returning :int)
+
+(defun get-utime ()
+  (uffi:with-foreign-object (tv 'timeval)
+    (let ((res (c-gettimeofday tv (uffi:make-null-pointer 'timezone))))
+      (values
+       (+ (* 1000000 (uffi:get-slot-value tv 'timeval 'secs))
+          (uffi:get-slot-value tv 'timeval 'usecs))
+       res))))
+
+(deftest :timeofday.1
+    (multiple-value-bind (t1 res1) (get-utime)
+      (multiple-value-bind (t2 res2) (get-utime)
+        (and (or (= t2 t1) (> t2 t1))
+             (> t1 1000000000)
+             (> t2 1000000000)
+             (zerop res1)
+             (zerop res2))))
+  t)
+
+(defun posix-time-to-asctime (secs)
+  "Converts number of seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal Time (UTC)"
+  (string-right-trim
+   '(#\newline #\return)
+   (uffi:convert-from-cstring
+    (uffi:with-foreign-object (time 'time-t)
+      (setf (uffi:deref-pointer time :unsigned-long) secs)
+      (asctime (gmtime time))))))
+
+(deftest :time.3
+    (posix-time-to-asctime 0)
+  "Thu Jan  1 00:00:00 1970")

Added: branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test-lib.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,98 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi-c-test-lib.lisp
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+  ((input (* :unsigned-char)))
+  :returning :void
+  :module "uffi_tests")
+
+(defun string-to-upper (str)
+  (uffi:with-foreign-string (str-foreign str)
+    (cs-to-upper str-foreign)
+    (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+  ((input :cstring))
+  :returning :int
+  :module "uffi_tests")
+
+(defun string-count-upper (str)
+  (uffi:with-cstring (str-cstring str)
+    (cs-count-upper str-cstring)))
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+    ((size :int)
+     (vec (* :double)))
+  :returning :void
+  :module "uffi_tests")
+
+(uffi:def-function ("return_long_negative_one" return-long-negative-one)
+    ()
+  :returning :long
+  :module "uffi_tests")
+
+(uffi:def-function ("return_int_negative_one" return-int-negative-one)
+    ()
+  :returning :int
+  :module "uffi_tests")
+
+(uffi:def-function ("return_short_negative_one" return-short-negative-one)
+    ()
+  :returning :short
+  :module "uffi_tests")
+
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+  (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+        results)
+    (dotimes (i +double-vec-length+)
+      (setf (uffi:deref-array vec '(:array :double) i)
+            (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    (dotimes (i +double-vec-length+)
+      (push (uffi:deref-array vec '(:array :double) i) results))
+    (uffi:free-foreign-object vec)
+    (nreverse results)))
+
+(defun t2 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    vec))
+
+#+(or cmu scl)
+(defun t3 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (system:without-gcing
+     (half-double-vector +double-vec-length+ (system:vector-sap vec)))
+    vec))
+
+(deftest :c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
+(deftest :c-test.2 (string-to-upper nil) nil)
+(deftest :c-test.3 (string-count-upper "This is a Test") 2)
+(deftest :c-test.4 (string-count-upper nil) -1)
+(deftest :c-test.5 (test-half-double-vector)
+  (0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0))
+(deftest :c-test.6 (return-long-negative-one) -1)
+(deftest :c-test.7 (return-int-negative-one) -1)
+(deftest :c-test.8 (return-short-negative-one) -1)
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/uffi-c-test.c	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,158 @@
+/***************************************************************************
+ * FILE IDENTIFICATION
+ *
+ *  Name:         c-test-fns.c
+ *  Purpose:      Test functions in C for UFFI library
+ *  Programer:    Kevin M. Rosenberg
+ *  Date Started: Mar 2002
+ *
+ *  CVS Id:   $Id$
+ *
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+ *
+ * These variables are correct for GCC
+ * you'll need to modify these for other compilers
+ ***************************************************************************/
+
+#ifdef WIN32
+#include <windows.h>
+
+BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll,
+                          DWORD fdwReason,
+                          LPVOID lpvReserved)
+{
+        return 1;
+}
+
+#define DLLEXPORT __declspec(dllexport)
+
+#else
+#define DLLEXPORT
+#endif
+
+#include <ctype.h>
+#include <stdlib.h>
+#include <math.h>
+
+
+DLLEXPORT unsigned char uchar_13 = 13;
+DLLEXPORT signed char schar_neg_120 = -120;
+DLLEXPORT unsigned short uword_257 = 257;
+DLLEXPORT signed short sword_neg_321 = -321;
+DLLEXPORT unsigned int uint_1234567 = 1234567;
+DLLEXPORT signed int sint_neg_123456 = -123456;
+DLLEXPORT double double_3_1 = 3.1;
+DLLEXPORT float float_neg_4_5 = -4.5;
+
+/* Test of constant input string */
+DLLEXPORT
+int
+cs_count_upper (char* psz)
+{
+  int count = 0;
+
+  if (psz) {
+    while (*psz) {
+      if (isupper (*psz))
+        ++count;
+      ++psz;
+    }
+    return count;
+  } else
+    return -1;
+}
+
+/* Test of input and output of a string */
+DLLEXPORT
+void
+cs_to_upper (char* psz)
+{
+  if (psz) {
+    while (*psz) {
+      *psz = toupper (*psz);
+      ++psz;
+    }
+  }
+}
+
+/* Test of an output only string */
+DLLEXPORT
+void
+cs_make_random (int size, char* buffer)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    buffer[i] = 'A' + (rand() % 26);
+}
+
+
+/* Test of input/output vector */
+DLLEXPORT
+void
+half_double_vector (int size, double* vec)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    vec[i] /= 2.;
+}
+
+
+
+DLLEXPORT
+void *
+cast_test_int () {
+  int *x = (int *) malloc(sizeof(int));
+  *x = 23;
+  return x;
+}
+
+DLLEXPORT
+void *
+cast_test_float ()
+{
+  double *y = (double *) malloc(sizeof(double));
+  *y = 3.21;
+  return y;
+}
+
+DLLEXPORT
+long
+return_long_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT
+int
+return_int_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT
+short
+return_short_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT int fvar_addend = 3;
+
+typedef struct {
+  int i;
+  double d;
+} fvar_struct_type;
+
+fvar_struct_type fvar_struct = {42, 3.2};
+
+DLLEXPORT
+int fvar_struct_int () {
+  return (fvar_addend + fvar_struct.i);
+}
+
+DLLEXPORT
+double fvar_struct_double () {
+  return fvar_struct.d;
+}
+
+

Added: branches/trunk-reorg/thirdparty/uffi/tests/union.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/tests/union.lisp	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,71 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          union.lisp
+;;;; Purpose:       UFFI Example file to test unions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-union tunion1
+    (char :char)
+  (int :int)
+  (uint :unsigned-int)
+  (sf :float)
+  (df :double))
+
+(defvar *u* (uffi:allocate-foreign-object 'tunion1))
+(setf (uffi:get-slot-value *u* 'tunion1 'uint)
+      #-(or sparc sparc-v9 powerpc ppc)
+      (+ (* 1 (char-code #\A))
+         (* 256 (char-code #\B))
+         (* 65536 (char-code #\C))
+         (* 16777216 128))
+      #+(or sparc sparc-v9 powerpc ppc)
+      (+ (* 16777216 (char-code #\A))
+         (* 65536 (char-code #\B))
+         (* 256 (char-code #\C))
+         (* 1 128)))
+
+(deftest :union.1
+    (uffi:ensure-char-character
+     (uffi:get-slot-value *u* 'tunion1 'char))
+  #\A)
+
+(deftest :union.2
+    (uffi:ensure-char-integer
+     (uffi:get-slot-value *u* 'tunion1 'char))
+  65)
+
+#-(or sparc sparc-v9 openmcl digitool)
+(deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
+
+
+(uffi:def-union foo-u
+    (bar :pointer-self))
+
+(uffi:def-foreign-type foo-u-ptr (* foo-u))
+
+;; tests that compilation worked
+(deftest :unions.4
+  (with-foreign-object (p 'foo-u)
+    t)
+  t)
+
+(deftest :unions.5
+    (progn
+      (uffi:def-foreign-type foo-union (:union foo-u))
+      t)
+  t)
+
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/uffi-tests.asd	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,95 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi-tests.asd
+;;;; Purpose:       ASDF system definitionf for uffi testing package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(defpackage #:uffi-tests-system
+  (:use #:asdf #:cl))
+(in-package #:uffi-tests-system)
+
+(operate 'load-op 'uffi)
+
+(defvar *library-file-dir* (append (pathname-directory *load-truename*)
+				   (list "tests")))
+
+(defclass uffi-test-source-file (c-source-file)
+  ())
+
+(defmethod output-files ((o compile-op) (c uffi-test-source-file))
+  (let* ((library-file-type
+	  (funcall (intern (symbol-name'#:default-foreign-library-type)
+			   (symbol-name '#:uffi))))
+	 (found
+	  (some #'(lambda (dir)
+		    (probe-file (make-pathname
+				 :directory dir
+				 :name (component-name c)
+				 :type library-file-type)))
+		'((:absolute "usr" "lib" "uffi")))))
+    (list (if found
+	      found
+	      (make-pathname :name (component-name c)
+			     :type library-file-type
+			     :directory *library-file-dir*)))))
+
+(defmethod perform ((o load-op) (c uffi-test-source-file))
+  nil) ;;; library will be loaded by a loader file
+
+(defmethod operation-done-p ((o load-op) (c uffi-test-source-file))
+  (and (symbol-function (intern (symbol-name '#:cs-count-upper)
+				(find-package '#:uffi-tests)))
+       t))
+
+(defmethod perform ((o compile-op) (c uffi-test-source-file))
+  (unless (operation-done-p o c)
+    #-(or win32 mswindows)
+    (unless (zerop (run-shell-command
+		    #-freebsd "cd ~A; make"
+		    #+freebsd "cd ~A; gmake"
+		    (namestring (make-pathname :name nil
+					       :type nil
+					       :directory *library-file-dir*))))
+      (error 'operation-error :component c :operation o))))
+
+(defmethod operation-done-p ((o compile-op) (c uffi-test-source-file))
+  (or (and (probe-file #p"/usr/lib/uffi/uffi-c-test.so") t)
+      (let ((lib (make-pathname :defaults (component-pathname c)
+				:type (uffi:default-foreign-library-type))))
+	(and (probe-file lib)
+	     (> (file-write-date lib) (file-write-date (component-pathname c)))))))
+
+(defsystem uffi-tests
+    :depends-on (:uffi)
+    :components
+    ((:module tests
+	      :components
+	      ((:file "rt")
+	       (:file "package" :depends-on ("rt"))
+	       (:uffi-test-source-file "uffi-c-test" :depends-on ("package"))
+	       (:file "strtol" :depends-on ("package"))
+	       (:file "atoifl" :depends-on ("package"))
+	       (:file "getenv" :depends-on ("package"))
+	       (:file "gethostname" :depends-on ("package"))
+	       (:file "union" :depends-on ("package"))
+	       (:file "arrays" :depends-on ("package"))
+	       (:file "structs" :depends-on ("package"))
+	       (:file "objects" :depends-on ("package"))
+	       (:file "time" :depends-on ("package"))
+	       (:file "foreign-loader" :depends-on ("package" "uffi-c-test"))
+	       (:file "uffi-c-test-lib" :depends-on ("foreign-loader"))
+	       (:file "compress" :depends-on ("foreign-loader"))
+	       (:file "casts" :depends-on ("foreign-loader"))
+	       (:file "foreign-var" :depends-on ("foreign-loader"))
+	       ))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :uffi-tests))))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package '#:regression-test)))
+      (error "test-op failed")))

Added: branches/trunk-reorg/thirdparty/uffi/uffi.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi/uffi.asd	Mon Feb 11 09:06:27 2008
@@ -0,0 +1,48 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi.asd
+;;;; Purpose:       ASDF system definition file for UFFI package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Aug 2002
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(defpackage #:uffi-system (:use #:asdf #:cl))
+(in-package #:uffi-system)
+
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
+(defsystem uffi
+  :name "uffi"
+  :author "Kevin Rosenberg <kevin at rosenberg.net>"
+  :version "1.2.x"
+  :maintainer "Kevin M. Rosenberg <kmr at debian.org>"
+  :licence "Lessor Lisp General Public License"
+  :description "Universal Foreign Function Library for Common Lisp"
+  :long-description "UFFI provides a universal foreign function interface (FFI) for Common Lisp. UFFI supports CMUCL, Lispworks, and AllegroCL."
+
+  :components
+  ((:module :src
+	    :components
+	    ((:file "package")
+	     (:file "primitives" :depends-on ("package"))
+	     #+(or openmcl digitool) (:file "readmacros-mcl" :depends-on ("package"))
+	     (:file "objects" :depends-on ("primitives"))
+	     (:file "aggregates" :depends-on ("primitives"))
+	     (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))
+	     (:file "functions" :depends-on ("primitives"))
+	     (:file "libraries" :depends-on ("package"))
+	     (:file "os" :depends-on ("package"))))
+   ))
+
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
+(defmethod perform ((o test-op) (c (eql (find-system 'uffi))))
+  (oos 'load-op 'uffi-tests)
+  (oos 'test-op 'uffi-tests :force t))
+
+


From ksprotte at common-lisp.net  Mon Feb 11 14:07:36 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 09:07:36 -0500 (EST)
Subject: [bknr-cvs] r2471 - branches/trunk-reorg/thirdparty/cl-gd-0.5.6
Message-ID: <20080211140736.5973A5C000@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 09:07:36 2008
New Revision: 2471

Modified:
   branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
Log:
cl-gd now always depends on uffi


Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	(original)
+++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	Mon Feb 11 09:07:36 2008
@@ -54,5 +54,4 @@
                (:file "drawing")
                (:file "strings")
                (:file "misc"))
-  :depends-on (#-(or :clisp :openmcl) :uffi
-               #+(or :clisp :openmcl) :cffi-uffi-compat))
+  :depends-on (:uffi))


From ksprotte at common-lisp.net  Mon Feb 11 14:08:27 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 09:08:27 -0500 (EST)
Subject: [bknr-cvs] r2472 -
	branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat
Message-ID: <20080211140827.2CD1B5F058@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 09:08:26 2008
New Revision: 2472

Added:
   branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.noasd
      - copied unchanged from r2469, branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.asd
Removed:
   branches/trunk-reorg/thirdparty/cffi-070901/uffi-compat/uffi.asd
Log:
renamed uffi-compat/uffi.asd to uffi-compat/uffi.noasd



From ksprotte at common-lisp.net  Mon Feb 11 14:10:28 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 09:10:28 -0500 (EST)
Subject: [bknr-cvs] r2473 - in branches/trunk-reorg/projects/bos: m2 web
Message-ID: <20080211141028.C6F3C5F058@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 09:10:28 2008
New Revision: 2473

Modified:
   branches/trunk-reorg/projects/bos/m2/bos.m2.asd
   branches/trunk-reorg/projects/bos/web/bos.web.asd
Log:
changed bos dependencies (:bknr does not exist anymore)

bos.m2: :bknr-datastore :bknr-modules
bos.web: :bknr-web :bknr-modules


Modified: branches/trunk-reorg/projects/bos/m2/bos.m2.asd
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/bos.m2.asd	(original)
+++ branches/trunk-reorg/projects/bos/m2/bos.m2.asd	Mon Feb 11 09:10:28 2008
@@ -1,7 +1,7 @@
 (in-package :cl-user)
 
 (asdf:defsystem :bos.m2
-  :depends-on (:bknr :bknr-modules :net.post-office :cl-mime :iconv :kmrcl :iterate :arnesi)
+  :depends-on (:bknr-datastore :bknr-modules :cl-smtp :cl-mime :iconv :kmrcl :iterate :arnesi)
   :components ((:file "packages")
 	       (:file "geo-utm" :depends-on ("packages"))
 	       (:file "geometry" :depends-on ("packages"))

Modified: branches/trunk-reorg/projects/bos/web/bos.web.asd
==============================================================================
--- branches/trunk-reorg/projects/bos/web/bos.web.asd	(original)
+++ branches/trunk-reorg/projects/bos/web/bos.web.asd	Mon Feb 11 09:10:28 2008
@@ -16,7 +16,7 @@
   :description "worldpay test web server"
   :long-description ""
 
-  :depends-on (:bknr :bknr-modules :bos.m2 :cxml)
+  :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml)
 
   :components ((:file "packages")
 	       (:file "utf-8" :depends-on ("packages"))


From hhubner at common-lisp.net  Mon Feb 11 14:23:20 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 09:23:20 -0500 (EST)
Subject: [bknr-cvs] r2474 - in branches/trunk-reorg/thirdparty: cl-gd-0.5.6
	uffi uffi-1.6.0 uffi-1.6.0/benchmarks uffi-1.6.0/doc
	uffi-1.6.0/examples uffi-1.6.0/src uffi-1.6.0/src/corman
	uffi-1.6.0/tests
Message-ID: <20080211142320.7B15B601A8@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 09:23:05 2008
New Revision: 2474

Added:
   branches/trunk-reorg/thirdparty/uffi-1.6.0/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/AUTHORS
   branches/trunk-reorg/thirdparty/uffi-1.6.0/ChangeLog
   branches/trunk-reorg/thirdparty/uffi-1.6.0/INSTALL
   branches/trunk-reorg/thirdparty/uffi-1.6.0/LICENSE
   branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile.common
   branches/trunk-reorg/thirdparty/uffi-1.6.0/NEWS
   branches/trunk-reorg/thirdparty/uffi-1.6.0/README
   branches/trunk-reorg/thirdparty/uffi-1.6.0/TODO
   branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/allocation.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/COPYING.GFDL
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/appendix.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/bookinfo.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-darwin.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-debian.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-mandrake.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse90.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse91.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-ubuntu.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/entities.inc
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/fo.xsl
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/glossary.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html.tar.gz   (contents, props changed)
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html.xsl
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html_chunk.xsl
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/intro.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/notes.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/preface.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_aggregate.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_declare.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_func_libr.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_object.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_primitive.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_string.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/schemas.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.pdf
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.xml
   branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/xinclude.mod
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile.msvc
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/acl-compat-tester.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/arrays.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/atoifl.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.c
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/compress.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/file-socket.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getenv.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gethostname.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getshells.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gettime.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/run-examples.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/strtol.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/test-examples.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/union.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/corman-notes.txt
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/getenv-ccl.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/functions.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/libraries.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/objects.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/os.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/package.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/readmacros-mcl.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/strings.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile.msvc
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/arrays.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/atoifl.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/casts.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/compress.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-loader.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-var.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/getenv.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/gethostname.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/make.sh
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/objects.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/package.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/rt.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/strtol.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/time.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test-lib.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test.c
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/union.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi-tests.asd
   branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi.asd
Removed:
   branches/trunk-reorg/thirdparty/uffi/
Modified:
   branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
Log:
switch to release uffi

Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	(original)
+++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	Mon Feb 11 09:23:05 2008
@@ -54,4 +54,9 @@
                (:file "drawing")
                (:file "strings")
                (:file "misc"))
+<<<<<<< .mine
+  :depends-on (#-clisp :uffi
+               #+clisp :cffi-uffi-compat))
+=======
   :depends-on (:uffi))
+>>>>>>> .r2473

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/AUTHORS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/AUTHORS	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,12 @@
+Kevin M. Rosenberg <kevin at rosenberg.net>
+  Primary author
+
+John Desoi <desoi at mac.com>
+  Contributed MCL & OpenMCL support
+
+Reini Urban <rurban at x-ray.at>
+  Contributed initial Corman support
+
+Edi Weitz <edi at weitz.de>
+  Contributed with-cast-pointer and def-foreign-var along with
+  documentation

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/ChangeLog
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/ChangeLog	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,350 @@
+2007-07-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.6.0 (SPECIFICATION CHANGE)
+	* doc/ref_func_libr.xml: Change the specification of
+	load-foreign-library to better match the actual action of the
+	function. Rather than returning NIL for failure to load library,
+	signal an error.
+	* src/libraries.lisp: Rework load-foreign-library to ensure errors
+	are signaled on failure to load library. This was the case for
+	some implementations, change the other implementations to
+	match. (Inconsistency found due to Mark Wooding's remarks)
+	
+2007-04-12 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.18
+	* src/functions.lisp: Patch from Ian Eslick for Lispworks 5
+
+2006-10-10 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.17
+	* src/functions.lisp: Patch from Edi Weitz for Lispworks 5/Linux
+
+2006-09-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.16
+	* src/libraries.lisp: Add cygwin support
+	
+2006-08-13 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.15
+	* src/{objects,strings}.lisp: Add support for Lispworks 5 
+	thanks to patches from Bill Atkins 
+
+2006-07-04 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.14
+	* src/{objects,strings}.lisp: Apply patch from Edi Weitz
+
+2006-05-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.13 
+	* src/libraries.lisp: Revert buggy patch from Yaroslav Kavenchuk.
+
+2006-05-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.12 
+	* src/libraries.lisp: Patch from Yaroslav Kavenchuk to set
+	default drive letters on MS Windows.
+
+2006-05-11 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.11: Export new macro DEF-POINTER-VAR based on patch from
+	James Bielman to support defining variables on platforms which
+	support saving objects, such as openmcl
+
+2006-04-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.10: Commit patch from Gary King for openmcl's
+	feature list change
+
+2005-11-14 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.7
+	* src/strings.lisp: Add with-foreign-strings by James Biel
+	
+2005-11-14 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.6
+	* src/os.lisp: Remove getenv setter
+
+2005-11-07 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.5
+	* src/os.lisp: Add support for getenv getter and setter
+	
+2005-09-17 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.4
+	* src/objects.lisp: prepend _ character for entry
+	point on Allegro macosx, patch by Luis Oliveira
+	
+2005-07-05 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.5.0
+	* Remove vestigial LLGPL license notices as UFFI as been
+	BSD-licensed for several years.
+	
+2005-06-09 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.39
+	* tests/objects.lisp: Rename from pointers.lisp. 
+	Fix test CHPTR.4 as noted by Jorg Hohle
+	* src/objects.lisp: Remove default from ensure-char-integer
+	
+2005-06-09 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.38
+	* src/libraries.lisp: Commit patch from Edi Weitz to
+	allow plain filename library names to allow underlying
+	lisp implementation to find foreign libraries in the
+	locations known to the operating system.
+	* tests/cast.lisp: Add :module keyword as noted by Jorg Hohle.
+	* src/strings.lisp: Avoid multiple evaluation of input
+	parameters for macros as noted by Jorg Hohle.
+	
+2005-04-12 Kevin Rosenberg (kevin at rosenberg.net)
+	* Version 1.4.37
+	* src/strings.lisp: Fix variable name
+	
+2005-04-04 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.lisp, src/aggregates.lisp: Support change in SBCL copy
+	function [Thanks for Nathan Froyd and Zach Beane]
+	
+2005-04-03 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Commit patch from James Bielman to add
+	def-foreign-var support for OpenMCL
+	
+2005-03-03 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp: Add support for :union types
+	[patch from Cyrus Harmon]
+	* tests/union.lisp, tests/structs.lisp: Tests for
+	union and structure types [from Cyrus Harmon]
+	
+2005-02-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp, src/strings.lisp: Better support 
+	for sb-unicode [from Yoshinori Tahara and R. Mattes]
+
+2005-01-22 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/primitives.lisp: Better support SBCL-AMD64
+	
+2004-11-08 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.lisp: Better support sb-unicode
+	* tests/compress.lisp: Support sb-unicode
+	
+2004-10-07 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Add new function:
+	convert-from-foreign-usb8
+	
+2004-04-15 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.lisp: Add new functions:
+	MAKE-POINTER and POINTER-ADDRESS
+
+2004-04-13 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/string.lisp: Add new FOREIGN-STRING-LENGTH
+
+2003-08-15 Kevin Rosenberg (kevin at rosenberg.net)
+	* Added with-cast-pointer and def-foreign-var (patches submitted
+	by Edi Weitz). 
+	* Added many new tests
+	
+2002-10-16 Kevin Rosenberg (kevin at rosenberg.net)
+        * Added support for SBCL and SCL
+	
+2002-09-29 Kevin Rosenberg (kevin at rosenberg.net)
+	* Numerous changes in openmcl support (uffi now supports
+	clsql on openmcl)
+	
+2002-09-19 Kevin Rosenberg (kevin at rosenberg.net)
+        - Integrate John Desoi's OpenMCL support into src-mcl
+	* examples/Makefile: add section for building on MacOS X (John Desoi)
+	* examples/test-examples: changed from mk: to asdf: package loading (KMR)
+	* examples/run-examples: changed from mk: to asdf: package loading (KMR), 
+	add conditional loading if UFFI not loaded (John Desoi)
+	* examples/compress.cl: Add dylib to library types for MacOSX (John Desoi),
+	converted compressed output to hexidecimal display (KMR)
+	* examples/union.cl: Rework the tests (KMR)
+	* src-main/libraries.cl: add dylib as default library type on MacOSX (John Desoi)
+	* src-main/aggregates.cl: convert from uffi type in deref-array (John Desoi)
+	
+2002-09-16 Kevin Rosenberg (kevin at rosenberg.net)
+	- Restructure directories to move to a asdf definition file
+	without pathnames.
+	
+2002-08-25 Kevin Rosenberg (kevin at rosenberg.net)
+       - Restructure directories to attempt to properly handle both
+	Common Lisp Controller and non-CLC systems
+	
+2002-08-17 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- add uffi.asd for ASDF users
+
+2002-08-01 Kevin Rosenberg (kevin at rosenberg.net)
+	- Restructure directories to improve Common Lisp Controller v3
+	compatibility
+	
+2002-07-25 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Rework handling of logical pathnames.
+	- Move run-examples.cl to examples directory.
+	
+2002-06-28 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Added size-of-foreign-type function.
+	
+2002-06-26 Kevin Rosenberg (kevin at rosenberg.net)
+
+	- Fix bug in Lispworks allocate-foreign-object
+	- Added new :unsigned-byte type. Made :byte signed. 
+	
+2002-04-27 Kevin Rosenberg (kevin at rosenberg.net)
+	- misc files
+	First debian version
+	
+2002-04-23 Kevin Rosenberg (kevin at rosenberg.net)
+	- doc/*
+	Updated to debian docbook catalog
+	
+2002-04-23 John DeSoi (desoi at mac.com)
+	* src/mcl/*
+	Improved MCL support
+
+2002-04-06 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/mcl/libraries.cl:
+	Removed unnecessary function and added find-foreign-library
+	* src/mcl/*.cl:
+	Added authorship for John DeSoi
+	* doc/ref.sgml:
+	Added documentation for find-foreign-library
+	* uffi.system:
+	Simplied logical pathnames and MCL loading
+	
+2002-04-04 John DeSoi (desoi at mac.com)
+	* src/mcl/*.cl
+	Added initial support for MCL
+
+2002-04-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/libraries.cl:
+	Added test for .so libraries on CMUCL and use sys::load-object-file instead
+	of alien:load-library-file
+	* examples/Makefile:
+	Updated defaults so library is created correctly on Linux, FreeBSD, and Solaris
+
+2002-04-02 Kevin Rosenberg (kevin at rosenberg.net)
+	* examples/compress.cl:
+	Fixed missing '/'
+	* examples/union.cl:
+	Added support for SPARC big-endian
+	* test-examples.cl:
+	Automated testing suite
+	
+2002-04-01 Kevin Rosenberg (kevin at rosenberg.net)
+	* src/libraries.cl:
+	* examples/Makefile:
+	Changed default type for FreeBSD and updated Makefile for
+	FreeBSD and Solaris. Enhanced find-foreign-library to
+	take a list of types to search.
+	* examples/compress.cl:
+	Add support to use find-foreign-library
+
+2002-03-31  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/strings.cl:
+	Fixed bug in with-foreign-string (Thanks Harald Hanche-Olsen)
+	* examples/Makefile:
+	Create a .a library file for FreeBSD
+	* src/libraries.cl:
+	Added default type and find-foreign-library functions
+	
+2002-03-29  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/objects.cl: 
+	Fixed bug in deref-pointer (Thanks John Desoi!)
+
+2002-03-22  Kevin Rosenberg (kevin at rosenberg.net)
+	* src/aggregates.cl: 
+	Changed name and implementation of def-array to more appropriate
+	def-array-pointer
+	* src/ref.sgml:
+	Updated def-array-pointer documentation
+	* src/primitives.cl:
+	Made results of def-constant equal those of cl:defconstant
+	* src/objects.cl:
+	Made type be evaluated for with-foreign-object and allocate-foreign-object
+	* VERSION:
+	Increase to 0.3.0 to coincide with the release of CLSQL.
+	
+21 Mar 2002
+	* Fixed problem with NULL foreign-strings with CMUCL
+	* Added c-test-fns to examples for allow more specific testing
+	of UFFI. Builds on UNIX and Win32 platforms.
+	* Added def-union function, added union.cl example
+	* Fixed error with ensure-char-[character|integer]
+	* Added 2-d array example to examples/arrays.cl	
+	* Fixed documentation error on gethostname
+	* Added ensure-char-* and def-union to documentation
+	* Added double-float vector example to c-test-fns
+	* Reworked cstring on Lispworks to have LW handle string conversion
+	* First pass at with-foreign-object -- unoptimized
+	* Added gethostname2 example which uses with-foreign-object
+	* Added char-array-to-pointer function to encapsulate
+	converting a char array	to a char pointer
+	* Converted with-foreign-object to use stack allocation on CMUCL and LW
+	* Added benchmark code, first file is for allocation
+	
+20 Mar 2002
+	* Updated strings.cl so that foreign-strings are always unsigned.
+	Fixes a problem with strtol example.
+	* Added ensure-char-character and ensure-char-integer to handle
+	differences in implementations dereferencing of (* :char).
+	* Added section on design priorities for UFFI
+	* Added section in TODO on splitting implementation-dependent code
+	
+19 Mar 2002
+	* Added size parameter to allocate-foreign-object. Creates an array
+	of dimensions size.
+	* Got array-2d example working with a 1-d array.
+	* Cleaned strtol example
+	* Added TODO file
+	
+18 Mar 2002
+	* Documentation fixes (Erik Winkels)
+	* Fixed missing '.' in CMUCL type declarations (Erik Winkels)
+	
+17 Mar 2002
+	* Changed deref-pointer so it always returns a character when
+	called with a :char or :unsigned-char type
+	* Removed function ensure-char as no longer needed
+	* Added missing :byte specifier to Lispworks
+	* Changed default string type in Lispworks to :unsigned-char
+	which is the native type for Lispworks foreign-strings.
+	* Reworked strtol to handle new character pointing method
+	
+16 Mar 2002
+	* Fixed return value in load-foreign-library (Thanks Erik Winkels),
+	modified routine to accept pathnames as well as strings.
+	* Fix documention with :pointer-void (Again, Erik Winkels)
+	* Added missing type specifiers for CMUCL (Thanks a bunch, Erik!)
+	
+15 Mar 2002
+	* Finished basic skeleton of documentation.
+	
+14 Mar 2002
+	* Changed license to more liberal Lisp Lessor GNU Public License
+	* Fixed problem with uffi.system absent from in distribution 
+	(Thanks John DeSoi)
+	* Fixed compiler warnings
+	
+
+11 Mar 2002
+	* Changed def-type to def-foreign-type
+	* Created new macro def-type to generate cl:deftype forms. Removed
+	uffi-declare and uffi-slot-type as they are no longer necessary.
+	 
+10 Mar 2002
+	* Modified input parameters to load-foreign-library
+	* Added to documention
+	* Changed parameter order in get-slot-value and deref-array 
+	
+9 Mar 2002
+	* Added to documentation
+	* Made Allegro CL array access more efficient
+	* Changed def-routine name to def-function
+	* Fixed bug in def-function for Lispworks]
+	* Fixed error in +null-c-string-pointer+ name
+	* Fixed error in (make-null-pointer) for Lispworks
+	* Reworked Lispwork c-strings to be (* :char) rather than the
+	implementation default of (* (:unsigned :char)) to be consistent
+	with CMUCL. Bumped version to 0.2.0 because of change this change.
+	* Renamed c-string to cstring to emphasize it as a basic type
+	* Modified getenv.cl example to avoid name collison with LW
+	* Modified compress.cl to setup output buffer as :unsigned*char
+	* Added test-all-examples function. All routines tested okay with
+	ACL, LW, and CMUCL
+	
+8 Mar 2002
+	* Added ZIP file output with LF->CRLF translations to distribution
+	* Modified def-enum to use uffi:def-constant rather than
+	cl:defconstant
+	

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/INSTALL
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/INSTALL	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,3 @@
+Detailed installation instructions are supplied in PDF format
+in the file ./doc/uffi.pdf.
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/LICENSE
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/LICENSE	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,26 @@
+Copyright (c) 2001-2003 Kevin M. Rosenberg and contributors.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of the contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,45 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile
+#  Purpose:      Makefile for the uffi package
+#  Programer:    Kevin M. Rosenberg, M.D.
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile 10614 2005-07-06 01:05:14Z kevin $
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+PKG:=uffi
+DEBPKG=cl-uffi
+SUBDIRS:= examples src benchmarks
+DOCSUBDIRS:=doc
+
+include Makefile.common
+
+
+.PHONY: all
+all: 
+
+
+.PHONY: distclean
+distclean: clean
+	@$(MAKE) -C doc $@
+#	./debian/rules clean
+
+
+SOURCE_FILES=src doc examples Makefile uffi.system uffi.debian.system \
+	benchmarks COPYRIGHT README TODO INSTALL ChangeLog NEWS \
+	test-examples.cl set-logical.cl 
+
+.PHONY: doc
+doc:
+	$(MAKE) -C doc
+
+.PHONY: dist
+dist: clean
+	$(MAKE) -C doc $@
+
+.PHONY: TAGS
+TAGS:
+	if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
+	find . -name \*.lisp -exec /usr/bin/etags -a \{\} \;

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile.common
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/Makefile.common	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,17 @@
+all:
+	
+
+.PHONY: clean
+clean:
+	@rm -rf .bin
+	@rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl 
+	@rm -f *.fasla8 *.fasla16 *.faslm8 *.faslm16 *.faslmt
+	@rm -f *~ *.bak *.orig *.err \#*\# .#*
+	@rm -f *.so *.a
+	@rm -rf debian/cl-uffi
+ifneq ($(SUBDIRS)$(DOCSUBDIRS),)
+	@set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \
+		$(MAKE) -C $$i $@; done
+endif
+
+.SUFFIXES:            # No default suffixes

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/NEWS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/NEWS	Mon Feb 11 09:23:05 2008
@@ -0,0 +1 @@
+UFFI now supports AllegroCL AMD64

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/README	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,20 @@
+Package:  UFFI (Universal Foreign Language Interface)
+Web site: http://uffi.b9.com
+Author:   Kevin M. Rosenberg
+
+
+BRIEF DESCRIPTION
+-----------------
+uffi is a Common Lisp package for interfacing C-language compatible
+libraries. Every Common Lisp implementation has a method for
+interfacing to such libraries. Unfortunately, these method vary widely
+amongst implementations. uffi gathers a common subset of functionality
+between Common Lisp implementations. uffi wraps this common subset of
+functionality into it's own syntax and provides macro translation of
+uffi features into the specific syntax of supported Common Lisp
+implementations.
+
+Currently, AllegroCL (Linux and Microsoft Windows), Lispworks (Linux
+and Microsoft Windows), CMUCL, SBCL, and OpenMCL are supported.
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/TODO
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/TODO	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,7 @@
+- Run test-suite on MCL port
+
+- Add OpenMCL support for with-cast-pointer and def-foreign-var
+
+- Add support for direct vector passing to and from foreign functions
+   to avoid copying elements in and out of vector.
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,6 @@
+SUBDIRS		:= 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/allocation.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/benchmarks/allocation.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,126 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          allocation.cl
+;;;; Purpose:       Benchmark allocation and slot-access speed
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: allocation.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+
+(defun stk-int ()
+  #+allegro
+  (ff:with-stack-fobject (ptr :int) 
+    (setf (ff:fslot-value ptr) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr :int))
+    (setf (fli:dereference ptr) 0))
+  #+cmu
+  (alien:with-alien ((ptr alien:signed))
+    (let ((p (alien:addr ptr)))
+      (setf (alien:deref p) 0)))
+  #+sbcl
+  (sb-alien:with-alien ((ptr sb-alien:signed))
+    (let ((p (sb-alien:addr ptr)))
+      (setf (sb-alien:deref p) 0)))
+  )
+
+(defun stk-vector ()
+  #+allegro
+  (ff:with-stack-fobject (ptr '(:array :int 10) )
+    (setf (ff:fslot-value ptr 5) 0))
+  #+lispworks
+  (fli:with-dynamic-foreign-objects ((ptr (:c-array :int 10)))
+    (setf (fli:dereference ptr 5) 0))
+  #+cmu
+  (alien:with-alien ((ptr (alien:array alien:signed 10)))
+    (setf (alien:deref ptr 5) 0))
+  #+sbcl
+  (sb-alien:with-alien ((ptr (sb-alien:array sb-alien:signed 10)))
+    (setf (sb-alien:deref ptr 5) 0))
+  )
+
+(defun stat-int ()
+  #+allegro
+  (let ((ptr (ff:allocate-fobject :int :c)))
+    (declare (dynamic-extent ptr))
+    (setf (ff:fslot-value-typed :int :c ptr) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type :int)))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:signed 32))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+	     (dynamic-extent ptr))
+    (setf (alien:deref ptr) 0)
+    (alien:free-alien ptr))
+  #+sbcl
+  (let ((ptr (sb-alien:make-alien (sb-alien:signed 32))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+     (dynamic-extent ptr))
+    (setf (sb-alien:deref ptr) 0)
+    (sb-alien:free-alien ptr))
+  )
+
+(defun stat-vector ()
+  #+allegro
+  (let ((ptr (ff:allocate-fobject '(:array :int 10) :c)))
+    (declare (dynamic-extent ptr))
+    (setf (ff:fslot-value-typed '(:array :int 10) :c ptr 5) 0)
+    (ff:free-fobject ptr))
+  #+lispworks
+  (let ((ptr (fli:allocate-foreign-object :type '(:c-array :int 10))))
+    (declare (dynamic-extent ptr))
+    (setf (fli:dereference ptr 5) 0)
+    (fli:free-foreign-object ptr))
+  #+cmu
+  (let ((ptr (alien:make-alien (alien:array (alien:signed 32) 10))))
+    (declare ;;(type (alien (* (alien:unsigned 32))) ptr)
+	     (dynamic-extent ptr))
+    (setf (alien:deref ptr 5) 0)
+    (alien:free-alien ptr))
+  #+sbcl
+  (let ((ptr (sb-alien:make-alien (sb-alien:array (sb-alien:signed 32) 10))))
+    (declare ;;(type (sb-alien (* (sb-alien:unsigned 32))) ptr)
+	     (dynamic-extent ptr))
+    (setf (sb-alien:deref ptr 5) 0)
+    (sb-alien:free-alien ptr))
+  )
+
+
+(defun stk-vs-stat ()
+  (format t "~&Stack allocation, Integer")
+  (time (dotimes (i 1000) 
+	  (dotimes (j 1000)
+	    (stk-int))))
+  (format t "~&Static allocation, Integer")
+  (time (dotimes (i 1000) 
+	  (dotimes (j 1000)
+	    (stat-int))))
+  (format t "~&Stack allocation, Vector")
+  (time (dotimes (i 1000) 
+	  (dotimes (j 1000)
+	    (stk-int))))
+  (format t "~&Static allocation, Vector")
+  (time (dotimes (i 1000) 
+	  (dotimes (j 1000)
+	    (stat-int))))
+)
+
+
+(stk-vs-stat)
+
+			    
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/COPYING.GFDL
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/COPYING.GFDL	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,330 @@
+		GNU Free Documentation License
+		   Version 1.1, March 2000
+
+ Copyright (C) 2000  Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+0. PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+written document "free" in the sense of freedom: to assure everyone
+the effective freedom to copy and redistribute it, with or without
+modifying it, either commercially or noncommercially.  Secondarily,
+this License preserves for the author and publisher a way to get
+credit for their work, while not being considered responsible for
+modifications made by others.
+
+This License is a kind of "copyleft", which means that derivative
+works of the document must themselves be free in the same sense.  It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does.  But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book.  We recommend this License
+principally for works whose purpose is instruction or reference.
+
+
+1. APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work that contains a
+notice placed by the copyright holder saying it can be distributed
+under the terms of this License.  The "Document", below, refers to any
+such manual or work.  Any member of the public is a licensee, and is
+addressed as "you".
+
+A "Modified Version" of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A "Secondary Section" is a named appendix or a front-matter section of
+the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall subject
+(or to related matters) and contains nothing that could fall directly
+within that overall subject.  (For example, if the Document is in part a
+textbook of mathematics, a Secondary Section may not explain any
+mathematics.)  The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The "Invariant Sections" are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License.
+
+The "Cover Texts" are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License.
+
+A "Transparent" copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, whose contents can be viewed and edited directly and
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters.  A copy made in an otherwise Transparent file
+format whose markup has been designed to thwart or discourage
+subsequent modification by readers is not Transparent.  A copy that is
+not "Transparent" is called "Opaque".
+
+Examples of suitable formats for Transparent copies include plain
+ASCII without markup, Texinfo input format, LaTeX input format, SGML
+or XML using a publicly available DTD, and standard-conforming simple
+HTML designed for human modification.  Opaque formats include
+PostScript, PDF, proprietary formats that can be read and edited only
+by proprietary word processors, SGML or XML for which the DTD and/or
+processing tools are not generally available, and the
+machine-generated HTML produced by some word processors for output
+purposes only.
+
+The "Title Page" means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page.  For works in
+formats which do not have any title page as such, "Title Page" means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+
+2. VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License.  You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute.  However, you may accept
+compensation in exchange for copies.  If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+
+3. COPYING IN QUANTITY
+
+If you publish printed copies of the Document numbering more than 100,
+and the Document's license notice requires Cover Texts, you must enclose
+the copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover.  Both covers must also clearly and legibly identify
+you as the publisher of these copies.  The front cover must present
+the full title with all words of the title equally prominent and
+visible.  You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a publicly-accessible computer-network location containing a complete
+Transparent copy of the Document, free of added material, which the
+general network-using public has access to download anonymously at no
+charge using public-standard network protocols.  If you use the latter
+option, you must take reasonably prudent steps, when you begin
+distribution of Opaque copies in quantity, to ensure that this
+Transparent copy will remain thus accessible at the stated location
+until at least one year after the last time you distribute an Opaque
+copy (directly or through your agents or retailers) of that edition to
+the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+
+4. MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it.  In addition, you must do these things in the Modified Version:
+
+A. Use in the Title Page (and on the covers, if any) a title distinct
+   from that of the Document, and from those of previous versions
+   (which should, if there were any, be listed in the History section
+   of the Document).  You may use the same title as a previous version
+   if the original publisher of that version gives permission.
+B. List on the Title Page, as authors, one or more persons or entities
+   responsible for authorship of the modifications in the Modified
+   Version, together with at least five of the principal authors of the
+   Document (all of its principal authors, if it has less than five).
+C. State on the Title page the name of the publisher of the
+   Modified Version, as the publisher.
+D. Preserve all the copyright notices of the Document.
+E. Add an appropriate copyright notice for your modifications
+   adjacent to the other copyright notices.
+F. Include, immediately after the copyright notices, a license notice
+   giving the public permission to use the Modified Version under the
+   terms of this License, in the form shown in the Addendum below.
+G. Preserve in that license notice the full lists of Invariant Sections
+   and required Cover Texts given in the Document's license notice.
+H. Include an unaltered copy of this License.
+I. Preserve the section entitled "History", and its title, and add to
+   it an item stating at least the title, year, new authors, and
+   publisher of the Modified Version as given on the Title Page.  If
+   there is no section entitled "History" in the Document, create one
+   stating the title, year, authors, and publisher of the Document as
+   given on its Title Page, then add an item describing the Modified
+   Version as stated in the previous sentence.
+J. Preserve the network location, if any, given in the Document for
+   public access to a Transparent copy of the Document, and likewise
+   the network locations given in the Document for previous versions
+   it was based on.  These may be placed in the "History" section.
+   You may omit a network location for a work that was published at
+   least four years before the Document itself, or if the original
+   publisher of the version it refers to gives permission.
+K. In any section entitled "Acknowledgements" or "Dedications",
+   preserve the section's title, and preserve in the section all the
+   substance and tone of each of the contributor acknowledgements
+   and/or dedications given therein.
+L. Preserve all the Invariant Sections of the Document,
+   unaltered in their text and in their titles.  Section numbers
+   or the equivalent are not considered part of the section titles.
+M. Delete any section entitled "Endorsements".  Such a section
+   may not be included in the Modified Version.
+N. Do not retitle any existing section as "Endorsements"
+   or to conflict in title with any Invariant Section.
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant.  To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section entitled "Endorsements", provided it contains
+nothing but endorsements of your Modified Version by various
+parties--for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version.  Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity.  If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+
+5. COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy.  If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections entitled "History"
+in the various original documents, forming one section entitled
+"History"; likewise combine any sections entitled "Acknowledgements",
+and any sections entitled "Dedications".  You must delete all sections
+entitled "Endorsements."
+
+
+6. COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+
+7. AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, does not as a whole count as a Modified Version
+of the Document, provided no compilation copyright is claimed for the
+compilation.  Such a compilation is called an "aggregate", and this
+License does not apply to the other self-contained works thus compiled
+with the Document, on account of their being thus compiled, if they
+are not themselves derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one quarter
+of the entire aggregate, the Document's Cover Texts may be placed on
+covers that surround only the Document within the aggregate.
+Otherwise they must appear on covers around the whole aggregate.
+
+
+8. TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections.  You may include a
+translation of this License provided that you also include the
+original English version of this License.  In case of a disagreement
+between the translation and the original English version of this
+License, the original English version will prevail.
+
+
+9. TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License.  Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License.  However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+
+10. FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time.  Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.  See
+http://www.gnu.org/copyleft/.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License "or any later version" applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation.  If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,144 @@
+##############################################################################
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile
+#  Purpose:      Makefile for the uffi documentation
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile 11021 2006-08-14 04:22:28Z kevin $
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+##############################################################################
+
+DOCFILE_BASE_DEFAULT:=uffi
+DOCFILE_EXT_DEFAULT:=xml
+
+
+# Standard docfile processing
+
+DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*')
+UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*')
+SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*')
+SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*')
+REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*')
+MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*')
+DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*')
+
+ifneq (${DEBIAN},0)
+OS:=debian
+else
+  ifneq (${SUSE91},0)
+    OS=suse91
+  else
+    ifneq (${SUSE},0)
+      OS=suse
+    else   
+      ifneq (${REDHAT},0)
+        OS=redhat
+      else   
+        ifneq (${MANDRAKE},0)
+          OS=mandrake
+        else   
+          ifneq (${DARWIN},0)
+            OS=darwin
+          else  
+            ifneq (${UBUNTU},0)
+              OS=ubuntu
+            endif 
+          endif 
+        endif
+      endif
+    endif
+  endif
+endif
+
+ifndef DOCFILE_BASE
+DOCFILE_BASE=${DOCFILE_BASE_DEFAULT}
+endif
+
+ifndef DOCFILE_EXT
+DOCFILE_EXT=${DOCFILE_EXT_DEFAULT}
+endif
+
+DOCFILE:=${DOCFILE_BASE}.${DOCFILE_EXT}
+FOFILE:=${DOCFILE_BASE}.fo
+PDFFILE:=${DOCFILE_BASE}.pdf
+PSFILE:=${DOCFILE_BASE}.ps
+DVIFILE:=${DOCFILE_BASE}.dvi
+TXTFILE:=${DOCFILE_BASE}.txt
+HTMLFILE:=${DOCFILE_BASE}.html
+TMPFILES:=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log
+DOCFILES:=$(shell echo *.xml *.xsl)
+
+ifeq ($(XSLTPROC),)
+  XSLTPROC:=xsltproc
+endif
+
+CATALOG:=`pwd`/catalog-${OS}.xml
+CHECK:=XML_CATALOG_FILES="$(CATALOG)" xmllint --noout --xinclude --postvalid $(DOCFILE) || exit 1
+
+.PHONY: all
+all: html pdf 
+
+.PHONY: dist
+dist: html pdf
+
+.PHONY: doc
+doc: html pdf
+
+.PHONY: check
+check:
+	@echo "Operating System Detected: ${OS}"
+	@$(CHECK)
+
+.PHONY: html
+html: html.tar.gz
+
+html.tar.gz: $(DOCFILES) Makefile 
+	@rm -rf html
+	@mkdir html
+	@XML_CATALOG_FILES="$(CATALOG)" $(XSLTPROC) --stringparam chunker.output.encoding ISO-8859-1 \
+		 --xinclude --output html/ html_chunk.xsl $(DOCFILE)
+	@GZIP='-9' tar czf html.tar.gz html 
+
+.PHONY: fo
+fo: ${FOFILE}
+
+${FOFILE}: $(DOCFILES) Makefile 
+	@XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output $(FOFILE) fo.xsl $(DOCFILE)
+
+.PHONY: pdf
+pdf: ${PDFFILE}
+
+${PDFFILE}: ${DOCFILES} Makefile
+	@$(MAKE) fo
+	@fop $(FOFILE) -pdf $(PDFFILE) > /dev/null
+
+.PHONY: dvi
+dvi: ${DVIFILE}
+
+.PHONY: ps
+ps: ${PSFILE}
+
+${PSFILE}: ${DOCFILES} Makefile
+	@$(MAKE) fo
+	@fop $(FOFILE) -ps $(PSFILE) > /dev/null
+
+
+.PHONY: txt
+txt: ${TXTFILE}
+
+${TXTFILE}: ${FOFILE}
+	@XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output ${HTMLFILE} html.xsl $(DOCFILE)
+	lynx -dump ${HTMLFILE} > ${TXTFILE}
+
+.PHONY: clean
+clean: 
+	@rm -f *~ *.bak *.orig \#*\# .\#* texput.log
+	@rm -rf html ${PSFILE} ${HTMLFILE}
+	@rm -f ${TMPFILES} ${FOFILE}
+	@rm -f  ${DVIFILE} ${TXTFILE}
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/appendix.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/appendix.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,35 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<appendix id="installation">
+  <title>Installation</title>
+  <sect1 id="download">
+    <title>Download &uffi;</title>
+    <para>
+You need to download the &uffi; package from its web
+<ulink url="http://uffi.b9.com"><citetitle>home</citetitle></ulink>.
+You also need to have a copy of &asdf;. If you need a copy of
+&asdf;, it is included in the 
+  <ulink
+      url="http://www.sourceforge.net/projects/cclan">
+      <citetitle>CCLAN</citetitle></ulink> package. You can download
+the file <filename>defsystem.lisp</filename> from the CVS 
+<ulink url="http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp"><citetitle>tree</citetitle></ulink>.
+    </para>
+  </sect1>
+  <sect1 id="loading">
+    <title>Loading</title>
+    <para>
+      After downloading and installing &asdf;, simply
+      <function>push</function> the
+      directory containing &uffi; into
+      <varname>asdf:*central-registry*</varname> variable. Whenever you
+want to load the &uffi; package, use the form
+      <computeroutput>(asdf:operate 'asdf:load-op :uffi)</computeroutput>.
+    </para>
+  </sect1>
+</appendix>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/bookinfo.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/bookinfo.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,77 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<bookinfo>
+  <title>&uffi; Reference Guide</title>
+  <author>
+    <firstname>Kevin</firstname>
+    <othername>M.</othername>
+    <surname>Rosenberg</surname>
+    <affiliation>
+      <orgname>Heart Hospital of New Mexico</orgname>
+      <address>
+	<email>kevin at rosenberg.net</email>
+	<street>504 Elm Street N.E.</street>
+	<city>Albuquerque</city>
+	<state>New Mexico</state>
+	<postcode>87102</postcode>
+      </address>
+    </affiliation>
+  </author>
+  
+  <printhistory>
+    <simpara>$Id: bookinfo.xml 8263 2003-11-21 05:44:46Z kevin $</simpara>
+    <simpara>File $Date: 2003-11-20 22:44:46 -0700 (Thu, 20 Nov 2003) $</simpara>
+  </printhistory>
+  <copyright>
+    <year>2002-2003</year>
+    <holder>Kevin M. Rosenberg</holder>
+  </copyright>
+  <legalnotice>
+    <itemizedlist>
+      <listitem>
+	<para>The &uffi; package was designed and
+	  written by Kevin M. Rosenberg.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  Permission is granted to copy, distribute and/or modify this document
+	  under the terms of the GNU Free Documentation License, Version 1.1
+	  or any later version published by the Free Software Foundation;
+	  with no Invariant Sections, with the no
+	  Front-Cover Texts, and with no Back-Cover Texts.
+	  A copy of the license is included in the &uffi; distribution.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Allegro CL</application>&reg; is a registered
+	  trademark of Franz Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Lispworks</application>&reg; is a registered
+	  trademark of Xanalys Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  <application>Microsoft Windows</application>&reg; is a
+	  registered trademark of Microsoft Inc.
+	</para>
+      </listitem>
+      <listitem>
+	<para>
+	  Other brand or product names are the registered trademarks
+	  or trademarks of their respective holders.
+	</para>
+      </listitem>
+    </itemizedlist>
+  </legalnotice>
+</bookinfo>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-darwin.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-darwin.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///sw/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/docbookx/4.2.0/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="xsl/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2.0/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="xsl/docbook-xsl/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="xsl/docbook-xsl/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="xsl/docbook-xsl/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-debian.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-debian.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/xml/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="stylesheet/xsl/nwalsh/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-mandrake.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-mandrake.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="xml-dtd-4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="xsl-stylesheets/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="xml-dtd-4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="xml-dtd-4.2/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="xsl-stylesheets/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="xsl-stylesheets/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="xsl-stylesheets/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="db42xml/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="db42xml/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="db42xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse90.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse90.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="db42xml/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/docbook-xsl/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="db42xml/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="db42xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="docbook/docbook-xsl/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/docbook-xsl/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/docbook-xsl/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse91.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-suse91.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,48 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/xml/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="docbook/schema/dtd/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="docbook/stylesheet/nwalsh/current/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="docbook/schema/dtd/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+          uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <uri
+        name="docbookx.dtd"
+         uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <system
+         systemId="docbookx.dtd"
+          uri="docbook/schema/dtd/4.2/docbookx.dtd" />
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+         uri="docbook/stylesheet/nwalsh/current/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="docbook/stylesheet/nwalsh/current/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="docbook/stylesheet/nwalsh/current/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-ubuntu.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/catalog-ubuntu.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,43 @@
+<?xml version="1.0" ?>
+<!DOCTYPE catalog
+   PUBLIC "-//OASIS/DTD Entity Resolution XML Catalog V1.0//EN"
+   "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
+
+<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">
+
+  <!-- The directory DTD and stylesheet files are installed under -->
+  <group  xml:base="file:///usr/share/sgml/docbook/" >
+
+    <!-- Resolve DTD URL system ID to local file -->
+    <rewriteSystem
+        systemIdStartString="http://www.oasis-open.org/docbook/xml/4.2/"
+        rewritePrefix="dtd/xml/4.2/" />
+    <!-- Resolve stylesheet URL to local file -->
+    <rewriteURI
+        uriStartString="http://docbook.sourceforge.net/release/xsl/current/"
+        rewritePrefix="stylesheet/xsl/nwalsh/" />
+
+    <!-- Resolve DTD PUBLIC identifiers -->
+    <nextCatalog  catalog="dtd/xml/4.2/catalog.xml" />
+
+    <!-- To resolve simple DTD SYSTEM identifiers. -->
+    <!-- Note: this does not work with Java resolver -->
+    <!--   classes in Saxon or Xalan -->
+    <system
+         systemId="docbook.dtd"
+         uri="dtd/xml/4.2/xml/docbookx.dtd" />
+
+    <!-- To resolve short stylesheet references -->
+    <uri
+        name="docbook_html.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/docbook.xsl" />
+    <uri 
+        name="docbook_chunk.xsl"
+        uri="stylesheet/xsl/nwalsh/xhtml/chunk.xsl" />
+    <uri
+        name="docbook_fo.xsl"
+        uri="stylesheet/xsl/nwalsh/fo/docbook.xsl" />
+
+  </group>
+
+</catalog>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/entities.inc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/entities.inc	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,16 @@
+<!ENTITY uffi "<application><emphasis>UFFI</emphasis></application>">
+<!ENTITY ffi "<acronym>FFI</acronym>">
+<!ENTITY cmucl "<application>CMUCL</application>">
+<!ENTITY scl "<application>SCL</application>">
+<!ENTITY lw "<application>Lispworks</application>">
+<!ENTITY sbcl "<application>SBCL</application>">
+<!ENTITY openmcl "<application>OpenMCL</application>">
+<!ENTITY mcl "<application>MCL</application>">
+<!ENTITY acl "<application>AllegroCL</application>">
+<!ENTITY cl "<application>ANSI Common Lisp</application>">
+<!ENTITY t "<constant>T</constant>">
+<!ENTITY nil "<constant>NIL</constant>">
+<!ENTITY null "<constant>NULL</constant>">
+<!ENTITY c "<computeroutput>C</computeroutput>">
+<!ENTITY defsystem "<application>defsystem</application>">
+<!ENTITY asdf "<application>ASDF</application>">

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/fo.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/fo.xsl	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,8 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_fo.xsl"/>
+<xsl:param name="fop.extensions" select="1"/>
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/glossary.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/glossary.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,21 @@
+<?xml version="1.0" ?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<glossary id="glossary">
+  <glossentry id="gloss-ffi">
+    <glossterm>Foreign Function Interface
+      <acronym>FFI</acronym>)
+    </glossterm>
+    <glossdef>
+      <para>
+        An interface to a C-compatible library.
+      </para>
+    </glossdef>
+  </glossentry>
+</glossary>
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html.tar.gz
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html.xsl	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,10 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_html.xsl"/>
+<xsl:param name="use.id.as.filename" select="1"/>
+<xsl:output encoding="ISO-8859-1" method="html" />
+
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html_chunk.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/html_chunk.xsl	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,9 @@
+<?xml version='1.0'?>
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+                version="1.0">
+
+<xsl:import href="docbook_chunk.xsl"/>
+<xsl:param name="use.id.as.filename" select="1"/>
+
+</xsl:stylesheet>
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/intro.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/intro.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,113 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<chapter id="introduction">
+  <title>Introduction</title>
+  <sect1 id="purpose">
+    <title>Purpose</title>
+    <para>
+      This reference guide describes &uffi;, a package that provides a
+      cross-implementation interface from Common Lisp to C-language
+      compatible libraries.
+    </para>
+  </sect1>
+  
+  <sect1 id="background">
+    <title>Background
+    </title>
+    <para>
+      Every Common Lisp implementation has a method for interfacing to
+      C-language compatible libraries. These methods are often termed
+      a <emphasis>Foreign Function Library Interface</emphasis>
+      (&ffi;). Unfortunately, these methods vary widely amongst
+      implementations, thus preventing the writing of a portable FFI
+      to a particular C-library.
+    </para>
+    <para>
+      &uffi; gathers a common subset of functionality between Common
+      Lisp implementations. &uffi; wraps this common subset of
+      functionality with it's own syntax and provides macro
+      translation of uffi functions into the specific syntax of
+      supported Common Lisp implementations.
+    </para>
+    <para>
+      Developers who use &uffi; to interface with C libraries will
+      automatically have their code function in each of uffi's supported
+      implementations.
+    </para>
+  </sect1>
+
+  <sect1 id="supported-impl">
+    <title>Supported Implementations</title> 
+    <para>The primary tested and supported platforms for &uffi; are: 
+    </para>
+    <itemizedlist mark="opencircle">
+      <listitem><para>&acl; v6.2 on Debian GNU/Linux
+      FreeBSD 4.5, Solaris v2.8, and Microsoft Windows XP.</para></listitem>
+      <listitem><para>&lw; v4.2 on Debian GNU/Linux and Microsoft Windows XP.</para></listitem>
+      <listitem><para>&cmucl; 18d on Debian GNU/Linux, FreeBSD 4.5, and Solaris 2.8</para></listitem>
+      <listitem><para>&sbcl; 0.7.8 on Debian GNU/Linux</para></listitem>
+      <listitem><para>&scl; 1.1.1 on Debian GNU/Linux</para></listitem>
+      <listitem><para>&openmcl; 0.13 on Debian GNU/Linux for PowerPC</para></listitem>
+    </itemizedlist>
+    <para>Beta code is included with &uffi; for
+    </para>
+    <itemizedlist mark="opencircle">
+      <listitem><para>&openmcl; and &mcl; with MacOSX</para></listitem>
+    </itemizedlist>
+  </sect1>
+
+  <sect1 id="design">
+    <title>Design</title>
+    <sect2>
+      <title>Overview</title>
+      <para>
+	&uffi; was designed as a cross-implementation 
+	compatible <emphasis>Foreign Function Interface</emphasis>.
+	Necessarily,
+	only a common subset of functionality can be
+	provided. Likewise, not every optimization for that a specific
+	implementation provides can be supported. Wherever possible,
+	though, implementation-specific optimizations are invoked.
+      </para> 
+    </sect2>
+
+    <sect2>
+      <title>Priorities</title>
+      <para>
+	The design of &uffi; is dictated by the order of these priorities:
+      </para>
+      <itemizedlist>
+	<listitem>
+	  <para>
+	    Code using &uffi; must operate correctly on all
+	    supported implementations.
+	  </para>
+	</listitem>
+	<listitem>
+	  <para>
+	    Take advantage of implementation-specific optimizations. Ideally, 
+	    there will not a situation where an implementation-specific
+	    &ffi; will be chosen due to lack of optimizations in &uffi;.
+	  </para>
+	</listitem>
+	<listitem>
+	  <para>Provide a simple interface to developers using
+	  &uffi;.  This priority is quite a bit lower than the above priorities.
+	  This lower priority is manifest by programmers having to pass types in
+	  pointer and array dereferencing, needing to use
+	  <constant>cstring</constant> wrapper functions, and the use of
+	  ensure-char-character and ensure-char-integer functions. My hope is
+	  that the developer inconvenience will be outweighed by the generation
+	  of optimized code that is cross-implementation compatible.
+	  </para>
+	</listitem>
+      </itemizedlist>
+    </sect2>
+  </sect1>
+
+</chapter>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/notes.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/notes.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,94 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<chapter id="notes">
+  <title>Programming Notes</title>
+
+  <sect1 id="impl-specific">
+    <title>Implementation Specific Notes</title> 
+    <para>
+    </para>
+      <sect2>
+	<title>&acl;</title>
+	<para>
+	</para>
+      </sect2>
+      <sect2>
+	<title>&lw;</title>
+	<para>
+	</para>
+      </sect2>
+      <sect2>
+	<title>&cmucl;</title>
+	<para>
+	</para>
+      </sect2>
+  </sect1>
+
+  <sect1 id="object-represen">
+    <title>Foreign Object Representation and Access</title>
+    <para> There are two main approaches used to represent foreign
+    objects: an integer that represents an address in memory, and a
+    object that also includes run-time typing. The advantage of
+    run-time typing is the system can dereference pointers and perform
+    array access without those functions requiring a type at the cost
+    of additional overhead to generate and store the run-time
+    typing. The advantage of integer representation, at least for
+    &acl;, is that the compiler can generate inline code to
+    dereference pointers. Further, the overhead of the run-time type
+    information is eliminated. The disadvantage is the program must
+    then supply
+    the type to the functions to dereference objects and array.
+    </para>
+  </sect1>
+
+  <sect1 id="optimizing">
+    <title>Optimizing Code Using UFFI</title>
+    <sect2>
+      <title>Background</title>
+      <para> 
+	Two implementions have different techniques to optimize
+	(open-code) foreign objects. &acl; can open-code foreign
+	object
+	access if pointers are integers and the type of object is
+    specified in the access function.  Thus, &uffi; represents objects
+    in &acl; as integers which don't have type information.
+    </para> <para> 
+      &cmucl; works best when keeping objects as typed
+    objects. However, it's compiler can open-code object access when
+    the object type is specified in <function>declare</function>
+    commands and in <varname>:type</varname> specifiers in
+    <function>defstruct</function> and <function>defclass</function>.
+    </para> <para> &lw;, in converse to &acl; and &cmucl; does not do
+    any open coding of object access. &lw;, by default, maintains
+    objects with run-time typing.  </para>
+    </sect2>
+    <sect2>
+      <title>Cross-Implementation Optimization</title>
+      <para>
+	To fully optimize across platforms, both explicit type
+	information must be passed to dereferencing of pointers and
+	arrays. Though this optimization only helps with &acl;, &uffi;
+	is designed to require this type information be passed the
+	dereference functions. Second, declarations of type should be
+	made in functions, structures, and classes where foreign
+	objects will be help. This will optimize access for &lw;
+      </para>
+      <para>
+	Here is an example that should both methods being used for
+	maximum cross-implementation optimization:
+	<screen>
+(uffi:def-type the-struct-type-def the-struct-type)
+(let ((a-foreign-struct (allocate-foreign-object 'the-struct-type)))
+  (declare 'the-struct-type-def a-foreign-struct)
+  (get-slot-value a-foreign-struct 'the-struct-type 'field-name))
+	</screen>
+      </para>
+    </sect2>
+  </sect1>
+
+</chapter>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/preface.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/preface.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,16 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<preface id="preface">
+  <title>Preface</title>
+  <para>This reference guide describes the usage and features of
+  &uffi;.  The first chapter provides an overview to the design of
+  &uffi;.  Following that chapter is the reference section for all
+  user accessible functions of &uffi;. The appendix covers the
+  installation and implementation-specifc features of &uffi;.
+  </para>
+</preface>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_aggregate.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_aggregate.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,524 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="aggregates">
+    <title>Aggregate Types</title>
+    <partintro>
+      <title>Overview</title>
+      <para>
+	Aggregate types are comprised of one or more primitive types.
+      </para>
+    </partintro>
+
+    <refentry id="def-enum">
+      <refnamediv>
+	<refname>def-enum</refname>
+	<refpurpose>Defines a &c; enumeration.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-enum</function> <replaceable>name fields &amp;key separator-string</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A symbol that names the enumeration.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A list of field defintions. Each definition can be
+a symbol or a list of two elements. Symbols get assigned a value of the
+current counter which starts at <computeroutput>0</computeroutput> and
+increments by <computeroutput>1</computeroutput> for each subsequent symbol. It the field definition is a list, the first position is the symbol and the second
+position is the value to assign the the symbol. The current counter gets set
+to <computeroutput>1+</computeroutput> this value.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>separator-string</parameter></term>
+	    <listitem>
+	      <para>A string that governs the creation of constants. The
+default is <computeroutput>"#"</computeroutput>.</para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Declares a &c; enumeration. It generates constants with integer values for the elements of the enumeration. The symbols for the these constant
+values are created by the <function>concatenation</function> of the
+enumeration name, separator-string, and field symbol. Also creates
+a foreign type with the name <parameter>name</parameter> of type
+<constant>:int</constant>.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-enum abc (:a :b :c)) 
+;; Creates constants abc#a (1), abc#b (2), abc#c (3) and defines
+;; the foreign type "abc" to be :int
+
+(def-enum efoo (:e1 (:e2 10) :e3) :separator-string "-")
+;; Creates constants efoo-e1 (1), efoo-e2 (10), efoo-e3 (11) and defines
+;; the foreign type efoo to be :int
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Creates a :int foreign type, defines constants.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+      <refentry id="def-struct">
+	<refnamediv>
+	  <refname>def-struct</refname>
+	<refpurpose>Defines a &c; structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-struct</function> <replaceable>name &amp;rest fields</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A symbol that names the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A variable number of field defintions. Each definition is a list consisting of a symbol naming the field followed by its foreign type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Declares a structure. A special type is available as a slot
+in the field. It is a pointer that points to an instance of the parent
+structure. It's type is <constant>:pointer-self</constant>.
+
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-struct foo (a :unsigned-int) 
+                (b (* :char)) 
+                (c (:array :int 10)) 
+                (next :pointer-self))
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Creates a foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="get-slot-value">
+      <refnamediv>
+	<refname>get-slot-value</refname>
+	<refpurpose>Retrieves a value from a slot of a structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>get-slot-value</function> <replaceable>obj type field</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>obj</parameter></term>
+	    <listitem>
+	      <para>A pointer to foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A name of the foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>field</parameter></term>
+	    <listitem>
+	      <para>A name of the desired field in foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the field in the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Accesses a slot value from a structure. This is generalized
+	  and can be used with <function>setf</function>.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(get-slot-value foo-ptr 'foo-structure 'field-name)
+(setf (get-slot-value foo-ptr 'foo-structure 'field-name) 10)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="get-slot-pointer">
+      <refnamediv>
+	<refname>get-slot-pointer</refname>
+	<refpurpose>Retrieves a pointer from a slot of a structure.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>get-slot-pointer</function> <replaceable>obj type field</replaceable> => <returnvalue>pointer</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>obj</parameter></term>
+	    <listitem>
+	      <para>A pointer to foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A name of the foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>field</parameter></term>
+	    <listitem>
+	      <para>A name of the desired field in foreign structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>pointer</returnvalue></term>
+	    <listitem>
+	      <para>The value of the field in the structure.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  This is similar to <function>get-slot-value</function>. It
+	  is used when the value of a slot is a pointer type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(get-slot-pointer foo-ptr 'foo-structure 'my-char-ptr)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="def-array-pointer">
+      <refnamediv>
+	<refname>def-array-pointer</refname>
+	<refpurpose>Defines a pointer to a array of type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-array-pointer</function> <replaceable>name type</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A name of the new foreign type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The foreign type of the array elements.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Defines a type tat is a pointer to an array of type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-array-pointer byte-array-pointer :unsigned-char)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Defines a new foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="deref-array">
+      <refnamediv>
+	<refname>deref-array</refname>
+	<refpurpose>Deference an array.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>deref-array</function> <replaceable>array type position</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>array</parameter></term>
+	    <listitem>
+	      <para>A foreign array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The foreign type of the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>position</parameter></term>
+	    <listitem>
+	      <para>An integer specifying the position to retrieve from
+the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value stored in the position of the array.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Dereferences (retrieves) the value of an array element.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-array-pointer ca :char)
+(let ((fs (convert-to-foreign-string "ab")))
+   (values (null-char-p (deref-array fs 'ca 0))
+           (null-char-p (deref-array fs 'ca 2))))
+=> &nil;
+   &t;
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Notes</title>
+        <para>
+  The TYPE argument is ignored for CL implementations other than
+  AllegroCL. If you want to cast a pointer to another type use
+  WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY.
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="def-union">
+      <refnamediv>
+	<refname>def-union</refname>
+	<refpurpose>Defines a foreign union type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-union</function> <replaceable>name &amp;rest fields</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A name of the new union type.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>fields</parameter></term>
+	    <listitem>
+	      <para>A list of fields of the union.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Defines a foreign union type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-union test-union
+  (a-char :char)
+  (an-int :int))
+
+(let ((u (allocate-foreign-object 'test-union))
+  (setf (get-slot-value u 'test-union 'an-int) (+ 65 (* 66 256)))
+  (prog1 
+    (ensure-char-character (get-slot-value u 'test-union 'a-char))
+    (free-foreign-object u)))
+=> #\A
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Defines a new foreign type.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_declare.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_declare.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,82 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+  
+<reference id="ref_declarations">
+  <title>Declarations</title>
+  
+  <partintro>
+    <sect1>
+      <title>Overview</title>
+      <para>Declarations are used to give the compiler optimizing
+	information about foreign types. Currently, only &cmucl;
+	supports declarations. On &acl; and &lw;, these expressions 
+	declare the type generically as &t;
+      </para>
+    </sect1>
+  </partintro>
+
+  <refentry id="def-type">
+    <refnamediv>
+      <refname>def-type</refname>
+      <refpurpose>Defines a Common Lisp type. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-type</function> <replaceable>name type</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the type</para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>type</parameter></term>
+	  <listitem>
+	    <para>A form that specifies the &uffi; type. It is not evaluated.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>Defines a Common Lisp type based on a &uffi; type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-type char-ptr '(* :char))
+...
+(defun foo (ptr)
+(declare (type char-ptr ptr))
+...
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Defines a new &cl; type.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+</reference>
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_func_libr.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_func_libr.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,264 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="func_libr">
+      <title>Functions &amp; Libraries</title>
+
+      <refentry id="def-function">
+	<refnamediv>
+	  <refname>def-function</refname>
+	<refpurpose>Declares a function. 
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-function</function> <replaceable>name args &amp;key module returning</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>A string or list specificying the function name. If it is a string, that names the foreign function. A Lisp name is created by translating #\_ to #\- and by converting to upper-case in case-insensitive Lisp implementations. If it is a list, the first item is a string specifying the foreign function name and the second it is a symbol stating the Lisp name.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>args</parameter></term>
+	    <listitem>
+	      <para>A list of argument declarations. If &nil;, indicates that the function does not take any arguments.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>module</parameter></term>
+	    <listitem>
+	      <para>A string specifying which module (or library) that the foreign function resides. (Required by Lispworks)</para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>returning</returnvalue></term>
+	    <listitem>
+	      <para>A declaration specifying the result type of the
+foreign function. If <constant>:void</constant> indicates module does not return any value.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Declares a foreign function.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-function "gethostname" 
+  ((name (* :unsigned-char))
+   (len :int))
+  :returning :int)
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+      <refentry id="load-foreign-library">
+	<refnamediv>
+	  <refname>load-foreign-library</refname>
+	<refpurpose>Loads a foreign library. 
+	</refpurpose>
+	<refclass>Function</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Syntax</title>
+<synopsis>
+	  <function>load-foreign-library</function> <replaceable>filename &amp;key module supporting-libraries force-load</replaceable> => <returnvalue>success</returnvalue>
+</synopsis>
+      </refsect1>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>filename</parameter></term>
+	    <listitem>
+	      <para>A string or pathname specifying the library location
+in the filesystem. At least one implementation (&lw;) can not
+accept a logical pathname.  If this parameter denotes a pathname without a
+directory component then most of the supported Lisp implementations will be
+able to find the library themselves if it is located in one of the standard
+locations as defined by the underlying operating system.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>module</parameter></term>
+	    <listitem>
+	      <para>A string designating the name of the module to apply
+to functions in this library. (Required for Lispworks)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>supporting-libraries</parameter></term>
+	    <listitem>
+	      <para>A list of strings naming the libraries required to
+link the foreign library. (Required by CMUCL)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>force-load</parameter></term>
+	    <listitem>
+	      <para>Forces the loading of the library if it has been previously loaded. 
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>success</returnvalue></term>
+	    <listitem>
+	      <para>A boolean flag, &t; if the library was able to be
+loaded successfully or if the library has been previously loaded,
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Loads a foreign library. Applies a module name to functions
+within the library. Ensures that a library is only loaded once during
+a session. A library can be reloaded by using the <symbol>:force-load</symbol> key.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+  (load-foreign-library #p"/usr/lib/libmysqlclient.so" 
+                        :module "mysql" 
+                        :supporting-libraries '("c"))
+    => T
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>Loads the foreign code into the Lisp system.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>Ability to load the file.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>An error will be signaled if the library is unable to be loaded.</para>
+      </refsect1>
+    </refentry>
+
+      <refentry id="find-foreign-library">
+	<refnamediv>
+	  <refname>find-foreign-library</refname>
+	<refpurpose>Finds a foreign library file.
+	</refpurpose>
+	<refclass>Function</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Syntax</title>
+<synopsis>
+	  <function>find-foreign-library</function> <replaceable>names directories &amp; drive-letters types</replaceable> => <returnvalue>path</returnvalue>
+</synopsis>
+      </refsect1>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>names</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the base name of the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>directories</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the directory the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>drive-letters</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the drive letters for the library file.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>types</parameter></term>
+	    <listitem>
+	      <para>A string or list of strings containing the file type of the library file. Default
+is &nil;. If &nil;, will use a default type based on the currently running implementation.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>path</returnvalue></term>
+	    <listitem>
+	      <para>A path containing the path found, or &nil; if the library file was not found.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>Finds a foreign library by searching through a number of possible locations. Returns
+the path of the first found file.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(find-foreign-library '("libmysqlclient" "libmysql")
+    '("/opt/mysql/lib/mysql/" "/usr/local/lib/" "/usr/lib/" "/mysql/lib/opt/")
+    :types '("so" "dll")
+    :drive-letters '("C" "D" "E"))
+=> #P"D:\\mysql\\lib\\opt\\libmysql.dll"
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_object.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_object.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,859 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="objects">
+  <title>Objects</title>
+<partintro>
+<title>Overview</title>
+    <para>
+      Objects are entities that can allocated, referred to by pointers, and
+can be freed.
+    </para>
+</partintro>
+
+
+    <refentry id="allocate-foreign-object">
+      <refnamediv>
+	<refname>allocate-foreign-object</refname>
+	<refpurpose>Allocates an instance of a foreign object.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>allocate-foreign-object</function> <replaceable>type &amp;optional size</replaceable> => <returnvalue>ptr</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The type of foreign object to allocate. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>size</parameter></term>
+	    <listitem>
+	      <para>An optional size parameter that is evaluated. If specified, allocates and returns an
+array of <parameter>type</parameter> that is <parameter>size</parameter> members long. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>ptr</returnvalue></term>
+	    <listitem>
+	      <para>A pointer to the foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Allocates an instance of a foreign object. It returns a pointer to the object.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(def-struct ab (a :int) (b :double))
+(allocate-foreign-object 'ab)
+=> #&lt;ptr&gt;
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="free-foreign-object">
+      <refnamediv>
+	<refname>free-foreign-object</refname>
+	<refpurpose>Frees memory that was allocated for a foreign boject.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>free-foreign-object</function> <replaceable>ptr</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to the allocated foreign object to free.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Frees the memory used by the allocation of a foreign object.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="with-foreign-object">
+      <refnamediv>
+	<refname>with-foreign-object</refname>
+	<refpurpose>Wraps the allocation of a foreign object around a body of code.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>with-foreign-object</function> <replaceable>(var type) &amp;body body</replaceable> => <returnvalue>form-return</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>var</parameter></term>
+	    <listitem>
+	      <para>The variable name to bind.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>The type of foreign object to allocate. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>form-return</returnvalue></term>
+	    <listitem>
+	      <para>The result of evaluating the <parameter>body</parameter>.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+This function wraps the allocation, binding, and destruction of a foreign object.
+On &cmucl; and
+&lw; platforms the object is stack allocated for efficiency. Benchmarks show that &acl; performs
+much better with static allocation.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<screen>
+(defun gethostname2 ()
+  "Returns the hostname"
+  (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+    (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+	(uffi:convert-from-foreign-string name)
+	(error "gethostname() failed."))))
+	</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="size-of-foreign-type">
+      <refnamediv>
+	<refname>size-of-foreign-type</refname>
+	<refpurpose>Returns the number of data bytes used by a foreign object type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>size-of-foreign-type</function> <replaceable>ftype</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ftype</parameter></term>
+	    <listitem>
+	      <para>A foreign type specifier. This parameter is evaluated.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the number of data bytes used by a foreign object type. This does not include any Lisp storage overhead.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(size-of-foreign-object :unsigned-byte)
+=> 1
+(size-of-foreign-object 'my-100-byte-vector-type)
+=> 100
+</screen>
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="pointer-address">
+      <refnamediv>
+	<refname>pointer-address</refname>
+	<refpurpose>Returns the address of a pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>pointer-address</function> <replaceable>ptr</replaceable> => <returnvalue>address</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>address</parameter></term>
+	    <listitem>
+	      <para>An integer representing the pointer's address.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the address as an integer of a pointer.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="deref-pointer">
+      <refnamediv>
+	<refname>deref-pointer</refname>
+	<refpurpose>Deferences a pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>deref-pointer</function> <replaceable>ptr type</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the object being pointed to.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the object where the pointer points.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Returns the object to which a pointer points.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((intp (allocate-foreign-object :int)))
+  (setf (deref-pointer intp :int) 10)
+  (prog1
+    (deref-pointer intp :int)
+    (free-foreign-object intp)))
+=> 10
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Notes</title>
+        <para>
+  The TYPE argument is ignored for CL implementations other than
+  AllegroCL. If you want to cast a pointer to another type use
+  WITH-CAST-POINTER together with DEREF-POINTER/DEREF-ARRAY.
+        </para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="ensure-char-character">
+      <refnamediv>
+	<refname>ensure-char-character</refname>
+	<refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is
+a character.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>ensure-char-character</function> <replaceable>object</replaceable> => <returnvalue>char</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>object</parameter></term>
+	    <listitem>
+	      <para>Either a character or a integer specifying a character code.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>char</returnvalue></term>
+	    <listitem>
+	      <para>A character.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Ensures that an objects obtained by dereferencing  
+<constant>:char</constant> and <constant>:unsigned-char</constant>
+pointers are a lisp character.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((fs (convert-to-foreign-string "a")))
+  (prog1 
+    (ensure-char-character (deref-pointer fs :char))
+    (free-foreign-object fs)))
+=> #\a
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>Depending upon the implementation and what &uffi; expects, this
+macro may signal an error if the object is not a character or
+integer.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="ensure-char-integer">
+      <refnamediv>
+	<refname>ensure-char-integer</refname>
+	<refpurpose>Ensures that a dereferenced <constant>:char</constant> pointer is
+an integer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>ensure-char-integer</function> <replaceable>object</replaceable> => <returnvalue>int</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>object</parameter></term>
+	    <listitem>
+	      <para>Either a character or a integer specifying a character code.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>int</returnvalue></term>
+	    <listitem>
+	      <para>An integer.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Ensures that an object obtained by dereferencing a 
+<constant>:char</constant> pointer is an integer.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<para>
+<screen>
+(let ((fs (convert-to-foreign-string "a")))
+  (prog1 
+    (ensure-char-integer (deref-pointer fs :char))
+    (free-foreign-object fs)))
+=> 96
+</screen>
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>Depending upon the implementation and what &uffi; expects, this
+macro may signal an error if the object is not a character or
+integer.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="make-null-pointer">
+      <refnamediv>
+	<refname>make-null-pointer</refname>
+	<refpurpose>Create a &null; pointer.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>make-null-pointer</function> <replaceable>type</replaceable> => <returnvalue>ptr</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A type of object to which the pointer refers.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>The &null; pointer of type <parameter>type</parameter>.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Creates a &null; pointer of a specified type.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="null-pointer-p">
+      <refnamediv>
+	<refname>null-pointer-p</refname>
+	<refpurpose>Tests a pointer for &null; value.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>null-pointer-p</function> <replaceable>ptr</replaceable> => <returnvalue>is-null</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A foreign object pointer.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>is-null</returnvalue></term>
+	    <listitem>
+	      <para>The boolean flag.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  A predicate testing if a pointer is has a &null; value.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+
+    <refentry id="null-cstring-pointer">
+      <refnamediv>
+	<refname>+null-cstring-pointer+</refname>
+	<refpurpose>A constant &null; cstring pointer.
+	</refpurpose>
+	<refclass>Constant</refclass>
+      </refnamediv>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  A &null; cstring pointer. This can be used for testing
+if a cstring returned by a function is &null;.
+	</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="with-cast-pointer">
+      <refnamediv>
+	<refname>with-cast-pointer</refname>
+	<refpurpose>Wraps a body of code with a pointer cast to a new type.
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>with-cast-pointer</function> (<replaceable>binding-name ptr type) &amp; body body</replaceable> => <returnvalue>value</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>binding-name</parameter></term>
+	    <listitem>
+	      <para>A symbol which will be bound to the casted object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>ptr</parameter></term>
+	    <listitem>
+	      <para>A pointer to a foreign object.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the object being pointed to.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>value</returnvalue></term>
+	    <listitem>
+	      <para>The value of the object where the pointer points.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+  Executes BODY with POINTER cast to be a pointer to type TYPE.
+  BINDING-NAME is will be bound to this value during the execution of
+  BODY.
+
+  This is a no-op in AllegroCL but will wrap BODY in a LET form if
+  BINDING-NAME is provided.
+
+  This macro is meant to be used in conjunction with DEREF-POINTER or
+  DEREF-ARRAY. In Allegro CL the "cast" will actually take place in
+  DEREF-POINTER or DEREF-ARRAY.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+<screen>
+(with-foreign-object (size :int)
+   ;; FOO is a foreign function returning a :POINTER-VOID
+   (let ((memory (foo size)))
+      (when (mumble)
+         ;; at this point we know for some reason that MEMORY points
+         ;; to an array of unsigned bytes
+         (with-cast-pointer (memory :unsigned-byte)
+           (dotimes (i (deref-pointer size :int))
+            (do-something-with
+              (deref-array memory '(:array :unsigned-byte) i)))))))
+</screen>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+    <refentry id="def-foreign-var">
+      <refnamediv>
+	<refname>def-foreign-var</refname>
+	<refpurpose>
+Defines a symbol macro to access a variable in foreign code
+	</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>def-foreign-var</function> <replaceable>name type module</replaceable>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>name</parameter></term>
+	    <listitem>
+	      <para>     
+A string or list specificying the symbol macro's name. If it is a
+     string, that names the foreign variable. A Lisp name is created
+     by translating #\_ to #\- and by converting to upper-case in
+     case-insensitive Lisp implementations. If it is a list, the first
+     item is a string specifying the foreign variable name and the
+     second it is a symbol stating the Lisp name.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><parameter>type</parameter></term>
+	    <listitem>
+	      <para>A foreign type of the foreign variable.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>module</returnvalue></term>
+	    <listitem>
+	      <para>
+     A string specifying the module (or library) the foreign variable
+     resides in. (Required by Lispworks)
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+Defines a symbol macro which can be used to access (get and set) the
+value of a variable in foreign code.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Examples</title>
+	<refsect2>
+	<title>C code</title>
+<screen>
+  int baz = 3;
+
+  typedef struct {
+    int x;
+    double y;
+  } foo_struct;
+
+  foo_struct the_struct = { 42, 3.2 };
+
+  int foo () {
+    return baz;
+  }
+</screen>
+</refsect2>
+<refsect2>
+<title>Lisp code</title>
+<screen>
+  (uffi:def-struct foo-struct
+    (x :int)
+    (y :double))
+
+  (uffi:def-function ("foo" foo)
+      ()
+    :returning :int
+    :module "foo")
+
+  (uffi:def-foreign-var ("baz" *baz*) :int "foo")
+  (uffi:def-foreign-var ("the_struct" *the-struct*) foo-struct "foo")
+
+
+*baz*
+  => 3
+
+(incf *baz*)
+  => 4
+
+(foo)
+  => 4
+</screen>
+</refsect2>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+    </refentry>
+
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_primitive.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_primitive.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,279 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="primitives">
+  <title>Primitive Types</title>
+  <partintro>
+    <title>Overview</title>
+    <para>
+      Primitive types have a single value, these include
+      characters, numbers, and pointers. They are all symbols in
+      the keyword package.
+    </para>
+    <itemizedlist>
+      <listitem>
+	<para><constant>:char</constant> - Signed 8-bits. A
+	  dereferenced :char pointer returns an character.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-char</constant> - Unsigned 8-bits. A dereferenced :unsigned-char
+	  pointer returns an character.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:byte</constant> - Signed 8-bits. A
+	  dereferenced :byte pointer returns an integer.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-byte</constant> - Unsigned 8-bits. A
+	  dereferenced :unsigned-byte pointer returns an integer.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:short</constant> - Signed 16-bits.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-short</constant> - Unsigned 16-bits.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:int</constant> - Signed 32-bits.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-int</constant> - Unsigned 32-bits.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:long</constant> - Signed 32 or 64 bits, depending upon the platform.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:unsigned-long</constant> - Unsigned 32 or 64 bits, depending upon the platform.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:float</constant> - 32-bit floating point.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:double</constant> - 64-bit floating point.</para>
+      </listitem>
+      <listitem>
+	<para><constant>:cstring</constant> - 
+	  A &null; terminated string used for passing and returning characters strings with a &c; function.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:void</constant> - 
+	  The absence of a value. Used to indicate that a function does not return a value.
+	</para>
+      </listitem>
+      <listitem>
+	<para><constant>:pointer-void</constant> - Points to a generic object.</para>
+      </listitem>
+      <listitem>
+	<para><constant>*</constant> - Used to declare a pointer to an object</para>
+      </listitem>
+    </itemizedlist>
+  </partintro>
+  
+  <refentry id="def-constant">
+    <refnamediv>
+      <refname>def-constant</refname>
+      <refpurpose>Binds a symbol to a constant. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-constant</function> <replaceable>name value &amp;key export</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol that will be bound to the value.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>value</parameter></term>
+	  <listitem>
+	    <para>An evaluated form that is bound the the name.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>export</parameter></term>
+	  <listitem>
+	    <para>When &t;, the name is exported from the current package. The default is &nil;</para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>This is a thin wrapper around <function>defconstant</function>. It evaluates at
+	compile-time and optionally exports the symbol from the package.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-constant pi2 (* 2 pi))
+(def-constant exported-pi2 (* 2 pi) :export t)
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Creates a new special variable..</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="def-foreign-type">
+    <refnamediv>
+      <refname>def-foreign-type</refname>
+      <refpurpose>Defines a new foreign type. 
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsect1>
+      <title>Syntax</title>
+      <synopsis>
+	<function>def-foreign-type</function> <replaceable>name type</replaceable>
+      </synopsis>
+    </refsect1>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>name</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the new foreign type.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>value</parameter></term>
+	  <listitem>
+	    <para>A form that is not evaluated that defines the new
+	      foreign type.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>Defines a new foreign type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-foreign-type my-generic-pointer :pointer-void)
+(def-foreign-type a-double-float :double-float)
+(def-foreign-type char-ptr (* :char))
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>Defines a new foreign type.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="null-char-p">
+    <refnamediv>
+      <refname>null-char-p</refname>
+      <refpurpose>Tests a character for &null; value.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsect1>
+      <title>Syntax</title>
+      <synopsis>
+	<function>null-char-p</function> <replaceable>char</replaceable> => <returnvalue>is-null</returnvalue>
+      </synopsis>
+    </refsect1>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>char</parameter></term>
+	  <listitem>
+	    <para>A character or integer.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>is-null</parameter></term>
+	  <listitem>
+	    <para>A boolean flag indicating if char is a &null; value.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	A predicate testing if a character or integer is &null;. This
+	abstracts the difference in implementations where some return a 
+	<computeroutput>character</computeroutput>
+	and some return a 
+	<computeroutput>integer</computeroutput>
+	whence dereferencing a 
+	<computeroutput>C</computeroutput>
+	character pointer.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <screen>
+(def-array-pointer ca :unsigned-char)
+(let ((fs (convert-to-foreign-string "ab")))
+      (values (null-char-p (deref-array fs 'ca 0))
+      (null-char-p (deref-array fs 'ca 2))))
+=> &nil;
+   &t;
+      </screen>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_string.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/ref_string.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,514 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+%myents;
+]>
+
+<reference id="strings">
+  <title>Strings</title>
+  <partintro>
+    <title>Overview</title>
+    <para>
+      &uffi; has functions to two types of <varname>C</varname>-compatible
+      strings: <emphasis>cstring</emphasis> and <emphasis>foreign</emphasis>
+      strings.  cstrings are used <emphasis>only</emphasis> as parameters to
+      and from functions. In some implementations a cstring is not a foreign
+      type but rather the Lisp string itself. On other platforms a cstring
+      is a newly allocated foreign vector for storing characters. The
+      following is an example of using cstrings to both send and return a
+      value.
+    </para>
+    
+    <screen>
+(uffi:def-function ("getenv" c-getenv) 
+   ((name :cstring))
+   :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+    </screen>
+
+    <para>
+      In contrast, foreign strings are always a foreign vector of
+      characters which have memory allocated. Thus, if you need to
+      allocate memory to hold the return value of a string, you must
+      use a foreign string and not a cstring.  The following is an
+      example of using a foreign string for a return value.
+    </para>
+
+    <screen>
+(uffi:def-function ("gethostname" c-gethostname)
+    ((name (* :unsigned-char))
+     (len :int))
+  :returning :int)
+
+(defun gethostname ()
+  "Returns the hostname"
+  (let* ((name (uffi:allocate-foreign-string 256))
+         (result-code (c-gethostname name 256))
+         (hostname (when (zerop result-code)
+                     (uffi:convert-from-foreign-string name))))
+    ;; UFFI does not yet provide a universal way to free
+    ;; memory allocated by C's malloc. At this point, a program
+    ;; needs to call C's free function to free such memory.
+    (unless (zerop result-code)
+      (error "gethostname() failed."))))
+    </screen>
+
+    <para>
+      Foreign functions that return pointers to freshly allocated
+      strings should in general not return cstrings, but foreign
+      strings. (There is no portable way to release such cstrings from
+      Lisp.) The following is an example of handling such a function.
+    </para>
+
+    <screen>
+(uffi:def-function ("readline" c-readline)
+    ((prompt :cstring))
+  :returning (* :char))
+
+(defun readline (prompt)
+  "Reads a string from console with line-editing."
+  (with-cstring (c-prompt prompt)
+      (let* ((c-str (c-readline c-prompt))
+             (str (convert-from-foreign-string c-str)))
+        (uffi:free-foreign-object c-str)
+        str)))
+    </screen>
+    
+  </partintro>
+  
+    <refentry id="convert-from-cstring">
+      <refnamediv>
+	<refname>convert-from-cstring</refname>
+	<refpurpose>Converts a cstring to a Lisp string.</refpurpose>
+	<refclass>Macro</refclass>
+      </refnamediv>
+      <refsynopsisdiv>
+	<title>Syntax</title>
+	<synopsis>
+	  <function>convert-from-cstring</function>
+	  <replaceable>cstring</replaceable> 
+	  => 
+	  <returnvalue>string</returnvalue>
+	</synopsis>
+      </refsynopsisdiv>
+      <refsect1>
+	<title>Arguments and Values</title>
+	<variablelist>
+	  <varlistentry>
+	    <term><parameter>cstring</parameter></term>
+	    <listitem>
+	      <para>A cstring.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	  <varlistentry>
+	    <term><returnvalue>string</returnvalue></term>
+	    <listitem>
+	      <para>A Lisp string.
+	      </para>
+	    </listitem>
+	  </varlistentry>
+	</variablelist>
+      </refsect1>
+      <refsect1>
+	<title>Description</title>
+	<para>
+	  Converts a Lisp string to a <constant>cstring</constant>. This is
+	  most often used when processing the results of a foreign function
+	  that returns a cstring.
+	</para>
+      </refsect1>
+      <refsect1>
+	<title>Side Effects</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Affected by</title>
+	<para>None.</para>
+      </refsect1>
+      <refsect1>
+	<title>Exceptional Situations</title>
+	<para>None.</para>
+      </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-to-cstring">
+    <refnamediv>
+      <refname>convert-to-cstring</refname>
+      <refpurpose>Converts a Lisp string to a cstring.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-to-cstring</function> 
+	<replaceable>string</replaceable>
+	=>
+	<returnvalue>cstring</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>cstring</returnvalue></term>
+	  <listitem>
+	    <para>A cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Converts a Lisp string to a <varname>cstring</varname>. The
+	<varname>cstring</varname> should be freed with
+	<function>free-cstring</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>On some implementations, this function allocates memory.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="free-cstring">
+    <refnamediv>
+      <refname>free-cstring</refname>
+      <refpurpose>Free memory used by cstring.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>free-cstring</function> <replaceable>cstring</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>cstring</parameter></term>
+	  <listitem>
+	    <para>A cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Frees any memory possibly allocated by
+	<function>convert-to-cstring</function>. On some implementions, a cstring is just the Lisp string itself.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="with-cstring">
+    <refnamediv>
+      <refname>with-cstring</refname>
+      <refpurpose>Binds a newly created cstring.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>with-cstring</function>
+	<replaceable>(cstring string) {body}</replaceable>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>cstring</parameter></term>
+	  <listitem>
+	    <para>A symbol naming the cstring to be created.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string that will be translated to a cstring.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>body</parameter></term>
+	  <listitem>
+	    <para>The body of where the cstring will be bound.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Binds a symbol to a cstring created from conversion of a
+	string. Automatically frees the <varname>cstring</varname>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Examples</title>
+      <para>
+	<screen>
+(def-function ("getenv" c-getenv) 
+   ((name :cstring))
+   :returning :cstring)
+
+(defun getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (with-cstring (key-cstring key)
+    (convert-from-cstring (c-getenv key-cstring))))
+	</screen>
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-from-foreign-string">
+    <refnamediv>
+      <refname>convert-from-foreign-string</refname>
+      <refpurpose>Converts a foreign string into a Lisp string.</refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-from-foreign-string</function>
+	<replaceable>foreign-string &amp;key length null-terminated-p</replaceable>
+	=>
+	<returnvalue>string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>foreign-string</parameter></term>
+	  <listitem>
+	    <para>A foreign string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>length</parameter></term>
+	  <listitem>
+	    <para>The length of the foreign string to convert. The
+	    default is the length of the string until a &null;
+	    character is reached.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>null-terminated-p</parameter></term>
+	  <listitem>
+	    <para>A boolean flag with a default value of &t; When true,
+	    the string is converted until the first &null; character is reached.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>string</returnvalue></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Returns a Lisp string from a foreign string. 
+	Can translated ASCII and binary strings.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  
+  <refentry id="convert-to-foreign-string">
+    <refnamediv>
+      <refname>convert-to-foreign-string</refname>
+      <refpurpose>Converts a Lisp string to a foreign string.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>convert-to-foreign-string</function>
+	<replaceable>string</replaceable> =>
+	<returnvalue>foreign-string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>string</parameter></term>
+	  <listitem>
+	    <para>A Lisp string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>foreign-string</returnvalue></term>
+	  <listitem>
+	    <para>A foreign string.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Converts a Lisp string to a foreign string. Memory should be
+	freed with <function>free-foreign-object</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+  <refentry id="allocate-foreign-string">
+    <refnamediv>
+      <refname>allocate-foreign-string</refname>
+      <refpurpose>Allocates space for a foreign string.
+      </refpurpose>
+      <refclass>Macro</refclass>
+    </refnamediv>
+    <refsynopsisdiv>
+      <title>Syntax</title>
+      <synopsis>
+	<function>allocate-foreign-string</function> <replaceable>size
+	&amp;key unsigned</replaceable> =>
+	<returnvalue>foreign-string</returnvalue>
+      </synopsis>
+    </refsynopsisdiv>
+    <refsect1>
+      <title>Arguments and Values</title>
+      <variablelist>
+	<varlistentry>
+	  <term><parameter>size</parameter></term>
+	  <listitem>
+	    <para>The size of the space to be allocated in bytes.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><parameter>unsigned</parameter></term>
+	  <listitem>
+	    <para>A boolean flag with a default value of &t;. When true,
+	    marks the pointer as an <constant>:unsigned-char</constant>.
+	    </para>
+	  </listitem>
+	</varlistentry>
+	<varlistentry>
+	  <term><returnvalue>foreign-string</returnvalue></term>
+	  <listitem>
+	    <para>A foreign string which has undefined contents.
+	    </para>
+	  </listitem>
+	</varlistentry>
+      </variablelist>
+    </refsect1>
+    <refsect1>
+      <title>Description</title>
+      <para>
+	Allocates space for a foreign string. Memory should
+	be freed with <function>free-foreign-object</function>.
+      </para>
+    </refsect1>
+    <refsect1>
+      <title>Side Effects</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Affected by</title>
+      <para>None.</para>
+    </refsect1>
+    <refsect1>
+      <title>Exceptional Situations</title>
+      <para>None.</para>
+    </refsect1>
+  </refentry>
+  
+</reference>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/schemas.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/schemas.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<locatingRules xmlns="http://thaiopensource.com/ns/locating-rules/1.0">
+  <uri resource="appendix.xml" typeId="DocBook"/>
+  <uri resource="bookinfo.xml" typeId="DocBook"/>
+  <uri resource="glossary.xml" typeId="DocBook"/>
+  <uri resource="intro.xml" typeId="DocBook"/>
+  <uri resource="notes.xml" typeId="DocBook"/>
+  <uri resource="preface.xml" typeId="DocBook"/>
+  <uri resource="ref_aggregate.xml" typeId="DocBook"/>
+  <uri resource="ref_declare.xml" typeId="DocBook"/>
+  <uri resource="ref_func_libr.xml" typeId="DocBook"/>
+  <uri resource="ref_object.xml" typeId="DocBook"/>
+  <uri resource="ref_primitive.xml" typeId="DocBook"/>
+  <uri resource="ref_string.xml" typeId="DocBook"/>
+  <uri resource="uffi.xml" typeId="DocBook"/>
+</locatingRules>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.pdf
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.pdf	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,3005 @@
+%PDF-1.3
+%????
+4 0 obj
+<< /Type /Info
+/Producer (FOP 0.20.5) >>
+endobj
+5 0 obj
+<< /Length 201 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GaqdX]*cD?&;B(lTAl),iOH at 5G$De=MG72'Yq]!?$6qt2q-EJV_Gi>/s/i"t<YjDPpBIl;OsFK],W_VAdjSmtNX!d%$GJd<iKP@`C7F7B\4aN'o`*!Hd\`C527G^=cu>#!0$EmK_'.Pqq^YH!<Kd&3bW6*^_c]c9kmt5c=$QVU6<Rh(R]Z8]_8CuImRsaYGQS>T2*q~>
+endstream
+endobj
+6 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 5 0 R
+>>
+endobj
+7 0 obj
+<< /Length 965 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0B9lo#B&A at ZcFA-9Z`S\\a;j*G?g8#gidrqVQ6.j%f at O*E0./ih(NJo,:9QS9/_s"58Dg.h\CL?1UMbsWT#Y#r/$p7>qI,Lur&,a4q*_<sf$j%O31[t"sEAY6i"i!>%??q6/YH:;7_^lb<4qDmi3MlsD"m81?_JGV7i8eK99"_!XJ`"DOWS69%V?g*poDpTOD+NYulf9+Uo`GkpN\R^oiss6d1+_$n^?25[9&oja`4eNgk6:&60/TOB6uH`Wp6H>(0FlQ+&l1e).un/XO\^rLae!\j^aO6ZSR^<5QNT"!'A$fUMJ#msPP>Ik"%k+87<*#mLg"3*M3QXj@(^rV33`Ef<,$'],bHf`&KqG70S_>U at rObfN@Ksee2_<.A2Ype;4lNrOpK1OGTj>/<Ma"UDHg_S,a5W'4EY/#XB<\#Q*tNq9?^Zh-]V.`3@&E]jQW.pO#@ttltjGe#p?dRd2aYi(&2T at n`H,_ at 0j27nSae5"nl@;-taXu2Una?K]q-E23QVF?gdO1(ZUs?WBMSE*'5u_fc"boeG(P`a;*_&1JCBr(B2<3YDA_&QnfW:dO!lUkp,NHERE-hZXZ*Z)7m1"cDWk?B$3Z%5/i-kqOQV+rZcQeSgNd?[R`o&f2ntr]+CO8V6X:ldO^l'Dih\DmCK?o"nh#P(^%#I!hi&r..)RnpUE=DYekJfLX#V!.mH5&_CU=G)RqESAlT(X@",'+9\;Qo0'aEWgsY]g:/1P[^K>$4**4VkH='g?99)V,6i=K%e<(Y:Igs&e7=Vacjr\mMg^u8J1&`_1/&r`fU3\Ej-d+>-1m at B"_3n-uBP>*n>-c\ZV;2gTE8kkP7[onB-ZrdueerP,n!LL?kH%o&<]GtKfIhq`rShqJdHX,L[,-5?>m[u-Lj:e[Q<)WeX49j5FHX;[#JW4TE1:c)ofX(CW*Oab`A*_g^'q18h$9,LL52At#8'F<d/~>
+endstream
+endobj
+8 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 7 0 R
+>>
+endobj
+9 0 obj
+<< /Length 71 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garg^iGoCd.c`?]8EV`b1=.gR0K1l>1K?+0ZOMGdU/Zh'Y!=Te%#&:?HH*JE!<<-b&VU~>
+endstream
+endobj
+10 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 9 0 R
+>>
+endobj
+11 0 obj
+<< /Length 1932 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gb"/l95iQS'SZ;X'jS`aUiKdh/8_9h>bk(t/):nF0_C00,E_8Q;NUhQE(E\_P"#M9etsu?(be-:3$JCZ_`Mqc>[:&o5M\#SKG,8Le(Mh:Z4ZX)k)Xa1SbQM&`06PrDn>H;H8/.NcfKj>VI;H@"l\<rEjkZ1\h%T!eCB9I[l=8^)-V:'DanG12PUnbT*TZu+X-*)IB2E[8bKmCf:VkJd\-(q+:r3g,!hlASSp?%8&n`alPS%<Vqn&U7BO`0<EeQsTnQ2D6XL*)"F=fN37g]EeYdgVTRi at sXjjYXg+4_4L-BGc#kW6'\EjdSbKa+NI`td%.dls0"S4P`kaBn>p$d71*d=[HZ;e6]iaHFoMre1rA5O_#mSl%s0G4kD73KrUV5)Ed at b+'0.p:t:d2^"*6lZI8H9hE8oI>QNBWjX=el&Vkq<:3n"&L*OkY16N-A9;i%d0\2lWi_CJ7*3W1C&Ir&#oud=_\\&hl?h/Dr3)_]N&O?P/SUuZMqu'b.:L[X;ugVk<Ku/@.&.G*r"s(]nG$r_VJ+eq(,>9AV+F'!<O8PZn=@OQ?2Y<5*qZeY?tXEbn("='07`Ge?V3NcE$');LR'h:^Yqh#]sBp>RH;K5J7!g?(2)'mYK=OI1Q\V\C/aKa*l,UGZ-*F)%/@OmPjV7O_NW9r^/<'XS+%.8RWKh0%3d#XWN?Dd/]`gpRT?jX6n0;c56;CXTdtTnm;$NhGmc5^:UqdeR*-M.5V>&h'(E_UHE"iV1V%r6H>ia[#AMHWiW5jTsE#,G&3`b'^6k+AA6<j\Ub!Ojlps:Is58AFIoFL>9PtW!=Ar2rL!EepZ,=VeuF'W)qU^Km:8)iSIu&,rE%e]gfY/o9j;epo2[^dH_%@B-*q<\8T8d'5gPfUEY>t4(`I7h0kiFXWfoacRUGUfJY##AoHSDB#77m4A(K24c#eb]BF"lc<jY_WfW>FnAT0/#oD(BEOJq\IMZFFt&EpY<h/$WrSI6Dg(A7fb]u"cWAP-Q+m9&=T*-MJskcDi2Kt at d1Mtm"q6Pc_VQ3(#n5TnE^6.tRid0WFd[KWM-eZ-%46W-/lck/k.DFk-ca(6U`EA]E8nN*)AA31,9qXd&rd)/J.gH`a]ECe!Qb_oZ)k%N&E-PutI"#<3IkNM2aJF>Hh';^l<Q4gE at n1+Ki5X-%WDW;J,YoWM[`4_1T&J'<X+;!`noYYOY at V!Nh\LKL%Ru33[+;!b0U<j"^$fA71hYu1LclLlK*btGt`e.V$#R!0n132HaGL5"5OXB[FR3o?>AhPf32`)R#h#W'J.9>9M#oZs<c'a`T3#-*l#QgP<RE0RGBV_>5ZM]s=+8-qK;%tKGTT^T6fktR<%4ntuQ%+qVEc:\!pX)#0"?I,M!UVcZ;.4_Z2su6:Edt:(%cEk6U!Fe`!r[U0i:[g]:3N03QE)\Xr9Q]lcspdCgO2JXjZ/Po[8O;Ge"H^el,Iqgi'RQs#)ll4M\SinGP(14I+H7h%>MS$&.!A#ZItfSVi,BKEqM#IO)j$!;!RXr)WI=s!^-iFZ0jN[O>u$0P\(]uFK[OHZ!7M8SLGFjE;O??A9m'=G"i[O>3/1b1u`(&L at 1:L1)C&pSNE74F^&EJ.!D[IBi<VGqU%_;"F>*!U>Ba^+TZdG5[PmU]aa[W&Ek+Tk^`PSR>A*6FS=k-]/FSG*B5$.=V(l2^^B2k(dPUm%nt/U/QFs*WH)Fu(,#4n"m#n!kS1n$]1[g1Oo6u:907sgoEBf;#+8j`:a;e8cGnR%b^#08_'%+2,U465lA'i$>Di2&)`5?kY^o'cP)O4e/!t<u@"H,C1jTa"=T\g'Sre#[&#7K3RGSN7!Ug!ooDjI,hG#(5lTWoR[37(eTZ7RH;hY0r3r4']HeG?u_M:HOKZ@<j)cG+RNIDsT9m>J3n-O0Mc_pj8l%BUD";;i".Zgk2chn,QUBo!~>
+endstream
+endobj
+12 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 11 0 R
+/Annots 13 0 R
+>>
+endobj
+13 0 obj
+[
+14 0 R
+16 0 R
+18 0 R
+20 0 R
+22 0 R
+24 0 R
+26 0 R
+28 0 R
+30 0 R
+32 0 R
+34 0 R
+36 0 R
+38 0 R
+40 0 R
+42 0 R
+44 0 R
+46 0 R
+48 0 R
+50 0 R
+52 0 R
+54 0 R
+56 0 R
+58 0 R
+60 0 R
+62 0 R
+64 0 R
+66 0 R
+68 0 R
+70 0 R
+72 0 R
+74 0 R
+76 0 R
+78 0 R
+80 0 R
+82 0 R
+84 0 R
+86 0 R
+88 0 R
+90 0 R
+92 0 R
+94 0 R
+96 0 R
+98 0 R
+100 0 R
+102 0 R
+104 0 R
+106 0 R
+108 0 R
+110 0 R
+112 0 R
+114 0 R
+116 0 R
+118 0 R
+]
+endobj
+14 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 655.001 149.98 645.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 15 0 R
+/H /I
+>>
+endobj
+16 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 644.001 179.44 634.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 17 0 R
+/H /I
+>>
+endobj
+18 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 633.001 176.22 623.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 19 0 R
+/H /I
+>>
+endobj
+20 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 622.001 192.88 612.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 21 0 R
+/H /I
+>>
+endobj
+22 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 611.001 254.83 601.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 23 0 R
+/H /I
+>>
+endobj
+24 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 600.001 172.33 590.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 25 0 R
+/H /I
+>>
+endobj
+26 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 589.001 207.43 579.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 27 0 R
+/H /I
+>>
+endobj
+28 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 578.001 204.67 568.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 29 0 R
+/H /I
+>>
+endobj
+30 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 567.001 210.83 557.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 31 0 R
+/H /I
+>>
+endobj
+32 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 556.001 268.43 546.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 33 0 R
+/H /I
+>>
+endobj
+34 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 545.001 211.33 535.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 35 0 R
+/H /I
+>>
+endobj
+36 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 534.001 210.22 524.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 37 0 R
+/H /I
+>>
+endobj
+38 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 523.001 203.56 513.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 39 0 R
+/H /I
+>>
+endobj
+40 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 512.001 314.52 502.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 41 0 R
+/H /I
+>>
+endobj
+42 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 501.001 263.73 491.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 43 0 R
+/H /I
+>>
+endobj
+44 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 490.001 216.88 480.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 45 0 R
+/H /I
+>>
+endobj
+46 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 168.0 479.001 312.72 469.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 47 0 R
+/H /I
+>>
+endobj
+48 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 468.001 178.87 458.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 49 0 R
+/H /I
+>>
+endobj
+50 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 457.001 177.32 447.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 51 0 R
+/H /I
+>>
+endobj
+52 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 446.001 195.83 436.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 53 0 R
+/H /I
+>>
+endobj
+54 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 435.001 193.43 425.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 55 0 R
+/H /I
+>>
+endobj
+56 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 424.001 209.53 414.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 57 0 R
+/H /I
+>>
+endobj
+58 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 413.001 188.43 403.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 59 0 R
+/H /I
+>>
+endobj
+60 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 402.001 203.58 392.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 61 0 R
+/H /I
+>>
+endobj
+62 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 391.001 182.32 381.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 63 0 R
+/H /I
+>>
+endobj
+64 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 380.001 182.32 370.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 65 0 R
+/H /I
+>>
+endobj
+66 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 369.001 198.99 359.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 67 0 R
+/H /I
+>>
+endobj
+68 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 358.001 205.66 348.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 69 0 R
+/H /I
+>>
+endobj
+70 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 347.001 212.3 337.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 71 0 R
+/H /I
+>>
+endobj
+72 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 336.001 188.41 326.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 73 0 R
+/H /I
+>>
+endobj
+74 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 325.001 182.88 315.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 75 0 R
+/H /I
+>>
+endobj
+76 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 314.001 166.1 304.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 77 0 R
+/H /I
+>>
+endobj
+78 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 303.001 235.08 293.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 79 0 R
+/H /I
+>>
+endobj
+80 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 292.001 219.52 282.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 81 0 R
+/H /I
+>>
+endobj
+82 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 281.001 221.76 271.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 83 0 R
+/H /I
+>>
+endobj
+84 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 270.001 223.97 260.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 85 0 R
+/H /I
+>>
+endobj
+86 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 259.001 205.65 249.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 87 0 R
+/H /I
+>>
+endobj
+88 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 248.001 196.2 238.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 89 0 R
+/H /I
+>>
+endobj
+90 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 237.001 230.61 227.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 91 0 R
+/H /I
+>>
+endobj
+92 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 226.001 221.74 216.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 93 0 R
+/H /I
+>>
+endobj
+94 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 215.001 216.21 205.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 95 0 R
+/H /I
+>>
+endobj
+96 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 204.001 199.55 194.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 97 0 R
+/H /I
+>>
+endobj
+98 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 193.001 233.05 183.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 99 0 R
+/H /I
+>>
+endobj
+100 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 182.001 212.32 172.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 101 0 R
+/H /I
+>>
+endobj
+102 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 171.001 205.08 161.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 103 0 R
+/H /I
+>>
+endobj
+104 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 160.001 160.56 150.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 105 0 R
+/H /I
+>>
+endobj
+106 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 149.001 227.31 139.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 107 0 R
+/H /I
+>>
+endobj
+108 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 138.001 215.65 128.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 109 0 R
+/H /I
+>>
+endobj
+110 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 127.001 190.09 117.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 111 0 R
+/H /I
+>>
+endobj
+112 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 116.001 192.33 106.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 113 0 R
+/H /I
+>>
+endobj
+114 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 105.001 255.08 95.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 115 0 R
+/H /I
+>>
+endobj
+116 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 94.001 243.42 84.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 117 0 R
+/H /I
+>>
+endobj
+118 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 83.001 233.42 73.001 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 119 0 R
+/H /I
+>>
+endobj
+120 0 obj
+<< /Length 536 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gb"/i:JZTs(rl#lMOr%8J at 25'i96md1V7>IMt)=%=\')JC`:(%/RZ[I-5ql2pkHsFDg=quGoh2Lk-6_#3$R"m-r(eA[LPT**s<0jMNUes8/+:]gW@^gRj+2>;kHJT at _Kt-U@(Z%4g)*f.]G177[]i7Q]/?n"9JWCM^W'>R at L!5'OUK]Ds at rKlh?B2h6aN!nM-A?Y8mlSkkDD-(sE=!@[e*XR;CZcXAlV[gq7q0^GM>jN-u4%5X5R'k'5P)1:2L*ZXV#%<.nc=!tZ$j8'\!Pc>L4<+Tgure)p:'\Ld#OP35F2Khj#-Xau"Q^6CYWnCIf02KR0dkJD<Hh2/I/fI]TD$?S[m"4_N./ZjW>;c"Zu0(V"C$P3lr%g3.Of%DPo*a,a*)?II35X7TlMjUq+o!saI7:+Pf]?B.h55)R=J:RV4]d4EZP3P/Q*nqblg)i'A0Lr3QXJo)GFY9514P3A**dY]TU>XMV<5?095]EPt<N0H0VKT^fZ-P=CG^Y0hro!A(0&U5Hf=CBQ2ucf at d4=jD!)r~>
+endstream
+endobj
+121 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 120 0 R
+/Annots 122 0 R
+>>
+endobj
+122 0 obj
+[
+123 0 R
+125 0 R
+127 0 R
+129 0 R
+131 0 R
+133 0 R
+135 0 R
+137 0 R
+]
+endobj
+123 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 719.0 223.88 709.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 124 0 R
+/H /I
+>>
+endobj
+125 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 708.0 193.43 698.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 126 0 R
+/H /I
+>>
+endobj
+127 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 697.0 223.42 687.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 128 0 R
+/H /I
+>>
+endobj
+129 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 686.0 222.31 676.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 130 0 R
+/H /I
+>>
+endobj
+131 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 675.0 177.22 665.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 132 0 R
+/H /I
+>>
+endobj
+133 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 664.0 210.93 654.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 134 0 R
+/H /I
+>>
+endobj
+135 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 144.0 653.0 177.33 643.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 136 0 R
+/H /I
+>>
+endobj
+137 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 642.0 155.55 632.0 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A 138 0 R
+/H /I
+>>
+endobj
+139 0 obj
+<< /Length 566 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$u9lHOU&A at ZcHqY#iq(N#UOh+G;8gJG7H>pN,ee/A?2Oj^DcGFI8P:C:b`Uc314ruMoDj,+OK&hmAF[92rUngX=P2_gj.]4`SF[J0i8:)W.2\-+WODmjAOnL.X99Q.8K=i]^bKg1ON+Q(rP1kPs\)].p3SrP!">DO"K3Y*ff)*8<K9\p at 5X9@Fi-r,/$VW;A]qI^$fn at jP]iE85<Eh.PlS:*eBt+!06%]>24n=t,IC_><<,#j52s!>!%ZCW>1S1gn)`A@/IKFT=n/BA%?4,Gc>o(/?<N;cAC"Y=;]u[1b+iZ\[-*'#-ni at 9XM(2ZW:tBGB1etV$qgNqC6PmZ.+C'kMSH<buTnp/A1E<Ir[NM+^2uTds'4(6Y%*Wm!J<1DFeM$kJJXV??KDg\Gl[NF?rsOe"<>AH`YtN!>>7<5\0^SHSO3$oD=`:q!>n>Lps5G6O299 at 2<gVjr_\!*^38N6oUfPq$7r+H?\ot0njnVgO$tlkphu;X8]hNsZn(+4J<T64cCcSD<1-eh0R,#/T8)3%^T71^ZSmo-ei9jn.^Q\@OrrQ'q2g>~>
+endstream
+endobj
+140 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 139 0 R
+>>
+endobj
+141 0 obj
+<< /Length 1955 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm<968iG&AJ$Cn5a0k7ehH)<\&;?*@GjIng$"c%kn/Y(fLPFP#@iXh^&:8$]26\2T#oG_0p`6//Ga%>eI`V*'Y]_)E<Z*L$Pfn4NE0%EtY+T:7PoA%MNK[FoK%DDeRZTq8Tu9PD!JGS&N[L7r8$MfgrAao7i1oNUrLCpg)Ql8J8t4%9n;r&N<CKrju33U1T$WjEN<TK4I*ZA&NpkdO7pYM[cl+K@'9^kZg`g at Zm!:1TY`BQ\\nP3g]c,eUs:b`/GeK,`H3ed)4,Qq\NN/PCWH-Oj)&%V.NiWr/%S=:X+VPBNg96\6P*;k#0_%(#N$qgTn,Y$Kf5W04B90'SjGd@]S<K6IEu8UN<]rp56H.?0CdEf9N$J at E.o>JsP_'q6,(SfN-qP at tAk.J!<oQ<g3,X&4)U.^9:eP#'AEo[,pjp,"-E=,%#!GY<+)'_0ur-,]cXIRar'bl3'AshpC'ge-rgffncJu=$e*B)KfAh%C=+Ai![Ouo.8*Bmf]tlE21d5]@a@!LHA(!E,`$>$nBZ+=>d0:,e1Ht9D%\2HQaVBOP7]mKOfIi1u>U9hXLirD'-s- at D"P03Ou5b$O[m-[_?(b`r#Ue(ekMe^u)LFD-6<j6XcNPE]">;(`<2Y[D7F^lWikBbF7/&2CoD6+f!V2 at i0A-eMB#1Cg*XCP&(AQkla$E_2otbm9-\\As"8CSEcVASA$H^3lSTCPmu'oK$&'m!oLco\Z/\j]T<h2cL["MRI]Qq1%><LA5*(,fu"NB?-T$SQk.qQd<5=gZc:?!+#RBhjJ)lsSdkRZ21*?)Nqng_6V1,(d9=6uIL,TrbJ#M+aFj89>@]C$<KF>>l^H]LFi*s:7m$p5V?^Kch#jFma1uB^Si7TUn`D3p?L4rbB0bK!6dp'i#]raScBc?3AB76gZ7ZUjG/V(;[Gn+0N[)t<4s0n1(S+*3,AEmT=O'u17iW1q4(QWFY-#8UV.u\fhd/DO-^*Q3f/PY%^4Vt`Le?hj'[o%bZ4n'_,A]i-3hMNim)IDJH+*-^/P,rS+.=]QVE$Di>6aGcaq;R[gZ3<S*Qo1Oc(Su![K'B($WTjEe;!CObedP(BsVib4Sic'%N?p[n\p:s'0N&cAipa<>h&XY.PiCZ`+33gq?[J$.IM'1 at uXd/S at EP?a.f^/CsNd+Yc+]`1]bV29(K)JEV7=Z[2$Jcqb@;s_.JCbFc0Ykqjbd(%%s&#T'asoS.("&Gc<7rXietbCDQu._d?c!56Al7jk)4T_4XGkh\ojG1%EZNU-8F74`ZGDh`a6:^#`g`Wksa+m/$^P at 6b&Q1Xs*g_il<QG!8K1'@;3d?'c$aQXP=)j\kH-r0P%cg(?S)S-Z[+7!g)LYSZ9u#l2O:$s0#,TB@:;n.L$2niPZu]m>O:E)+slQ>>9"2k0C:rYiBY41nM^SQLqTo[@p1U4j>5mtVa=P:;-V.TV#&U\'0<S5AKKUkq1<BC]q(mLaPGK1FOpTgh^Wqa8Io/',oHBU?58WAA;caRiCDgU>BJQr-,s`"k'Bn0eLNWk9*IH`,hjTbUL)2#h[tjnu[K_7eG at qMVr"M%)3]XEJn>'#8D4,+mej]]3gX[__^2^5##Pap('S:qUV44]MlWFq*<6pJ`eRcbZs;$n'mk%^YBY4FJtR&P3!Ib8YP=<N>Pj<H2>f8Hn_gB`B[?`9@!;E`UdgIe;`$ECJQ'59l$G6*EMO;4"^j57m&5MPA?)8C at 9gfT/gG5["=[nrM"RFmm$iL3:\3fUg]2Altlpk1JX<79cr6^?+7,k7d6<H59A2Iauj\MTk_V,B0HH60%U&"r,]CA=@!P%8ioEC3,3iI>1s=(Cj=K$.ib<bcmOqB\+3AYar<k(Cg=1&'=U!6^"1:^)]8JTfbkNo#dMJlJ:k#r49E5><U.Z7?H+5oTe5LY)&*KcKaDMMsJ at PO)[^BdJnqA!ZbD(6np^7mWun4^Bp-%E<~>
+endstream
+endobj
+142 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 141 0 R
+>>
+endobj
+143 0 obj
+<< /Length 1080 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GasIgh/Ac:&:`#5_.+uI*oE&BG$:_;RaapqC"n7B-F"J*C7 at WXYFiX]cRE^1V7JbVj*)S/qk;YiIZ1o^6XfBtou?_9S&"Xg?f5K=o"E7C:nB"?d<NFpSd"5-.SAd8pX^q0CYQc8I''8?B<r^#"DJpO/..>AE?t;82GAi9G8684^b!gt`EE&g=dGb+kBd$uq"XJIr6X',WG=gHLegZt're9Fhcj8MW*E:i\4D1B"Ie^UR4f5\X)]J:7Iql8'5a0Ve$$CcN]KbbiC6,=h">lt+;+/Xf;.Z,!f=<Qk`T%6ab:k63e>.ecn]u0=[mRObCrkkg9`6U&>nbe3Kn-i,a&+58IGANK%ZtKf?pTSeufKJA3+.42qV0>Unfk"JT at f)6iS`?B), at oF<^Z2/(%'++NfD,4:T?@!gkMfWTlt1^sMb,fl[=iYlMTM9^)@VR$rssSs^JL1r$897kP*]<RlY]MHfq1bEqnLG3T7"b!$Zc3!rKH\LH>Ob;b>U&A':TPEP;'pEo!)n1urb-f:V.C5a=t=B!CAVMM0j#t1X5L9AUcS;*4MXmFVQN&87&8mI$.nr at 1-*;qB,A7HBF$4omhV$C^bYHJsHlcJUpZHS/4bT<7Z5%4^Vk[Df`A9D(>4L9"o\f6/iEJi0Jpr(E3-Pkbt8YC*V)6M#jOs\;bLUR+'E7:3*9Yr#<O1gtWZ'DWrQ9\CA/HP2la,;,`LVaBPWrO at ImamAZV7%6;NZbb/Yu1ZZgLQ(+]eB_k%)b_FVTmJY,g2/5hQH2j7%p6bED!25*64==^XMqeCNL/uD,'Uri4<F[Gd7?JPP'm_bQEAU1XjnqBu4C.aL43?1&f(eJl,!uCP>CpM[fM"qJ\,0dKmel-aL$"]qpedW*7Id$:F.L<fdDub8CPNXQ8_A(tJQeRe)7kg`Ck%S[oAY31:4nqVGQ_>YAAk]-[+P at De@'q:.jrC'VXL[<173F->!i#(*oq>fs0qT0P&(X$un!R<S&- at e4?kIH.WXi`IjcGbfa^$0'L)T::VQ:0AVHYJi'<;372fSsU/'l:M_*c#"AokX2P9I\l8)R%eir)-TQ1!C>;(2u~>
+endstream
+endobj
+144 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 143 0 R
+>>
+endobj
+145 0 obj
+<< /Length 2312 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gasar968lH%)2U?kZ2?9B(^W6Q=T8P3bd&$Ro at dg/9+a-oSO]5gg=Dd!(B_bNFS#^LlVZEJfshcIXSa&q(?XaOJQ[L*0++'F1Uo^=8mM at i\T2Cdu;7SiZ&m"n*;o4hG8NDiS=9$_Qq\9 at cuHX[f"1mSVFdk7!l4$Id\UI^2X'k%_ol^/k^duc"bQA7Ec3>R.4J2f=^)0PY\#h[CsM<'Bf4%cO4_,KoKt_nIju^kEC-6MtA9ulC+?"m`g)XZURDU`&ou2Omg9A5Bar2EHbq)YujN][nj'8n#SCj!Z&?ZkhL:_(T5M%5MZ:^Moj!<ir-[5rLi4gB`kPrJr_6$OlNum at cE4,.j0d,k'Q%-U#H/U<aq,8dNfR)a3Frb/m:$5mtWMK.M[Dlbp+lu1=7-7+q/QM!<Acs(-fMYF-'_U:Ab7JLutacg6l@(=3o'1=<_8AD0?X=';]JT)W#SRe'4VNY]pU9$DuLYgBR66)@W^fc:FZ]lFFj3/]]WT\!(Jbd=:HCH"$u>HUR4c&%To='7maToB(i:,B]7[*1t6-2u at S$P;Orr"?,dPjBS$,H]I[#/[tiY:2ST:)FS3fFRqfdIRAF:+b([[B!IXD`Dh!OA,n'=A at ggV(@#iMQ%=FU`Ls7E==*f>4]0NWbG:os7ae,b]GHtY?6^]$9INF%>,hb?a*al[^k[g1V*UE"JaF+hq2eD-+:ot9`i0nJ+*`PBfkB3Tjp_ at s3hGJnp?cPIk(%1C<oLUB?b at JK`@nJg-(JOLl<Mq'+#f;:FW4G at nVrMqMAfWi.#Ms_.(Z8l2;_)X\S;*WE&q?1MtYA&\Num_)0qGCVF0N2Zf/NAODYRf4"K!BXh;&`Ce598;93#<UUQ<*(_["u>!RgNp)?E,l9)3c%-\UGRFac3oeLn at ZTAZOWCnsLL$Gtg1Tu/`'K4UfOA(ts`nPM$DtcW`#&>XaHDr``_Ul=acuB)c].hI/2WnR/8HBsjD$Ie%Lk7++m!/XE,QVs"A1&IF\[19[6G.gM]YUs4aJ\QEd&4LfGL+^7+S8g4VgFsN?fXeLQ/BolMnmM<(a at 9d//096j5oFN":rD*E0WY,,F.8u`, at EX`/CW1?Y<,u-=XH:=:c^L--"\DFbW,q0X)]@=q`fK)2.KH%4t"Z-`mG/2%*^Q;gN>u;JS/j<hb-8HI8E;Ni#P=:d'+I[]s)dDR_Yk^mbB/88R\3nZkN6fGfB]o9)jp@>:<C:-2!qQC&fZZboK-+0'V!=`Z&Vc`&a/6"$1ede>j5ICV#9X^Uh=$\oAi/[T41k[S?:?,M`E at jR"iP_$"9Begm0phloOeX,ZY0T"%Hn?F-Tl',aUp[F;3TmOM<90*@$,sf7aNl7$0-7B#@2mW"hgsommqR1b3%rgP@<(oMn%$Jf'UA;f=l\s6%pWL8m7j`,BU<=pe:FRX3(`eht\QB!Pm]dEa%jXH"ckE1dgGMd5ZTJ[Z=_8r`Yl$%t;(j<q at X88Vbd,IDOo]B0!?f\G%J'[>KRr32?>LR.$-U!F6l:^MV7c>(#@JBuE9bN&jAPnm"HF;l;dT-/Y%a9R[TpP*jAR\:F`MMLSNGjXapD9>qBEE/]2*2!&'iZWSDt_G6e8FK$Q[H=;h1NHFKIYcnB:n9=9c.7ncTMA3!d)fTNHC,iWQ7J-JCm_4;gF*2X4%o/-:0ZUqN?21p\/SAcT6i$X;on-6soX:`/X-;j//_ch0\Peb=kkrdCuEX-]TD/39j?0t`mFTgE'$0e^HH4ETV.]Dnu_P(PSI_iABNP,IZY0p8AedmP'9C?pSQU.?^C+F0Y#0lgXaPIa;N#U4HL/aGo`J*UlILrgd.)1Z6^!t[l[XUUHP]f[*M%A5H8]j\a%_r*$<hp>]rR35>c,7i#pnN[J>/AjUQ^nL&U;e>$h&k'482If0[Lb2.4YC!!q8V7Y(U0])ol5^k`p,\cg.:M;B30%eql?UKA8KKlp3Wp;Rn:>*Ljli])eg>N!gj&X0VQ!r3+2P#f#On;n0O'M$($W)43XDml,A+0@>Sa[:L2*_M/mk4OJ0H`(nT0q!>aP=?2L0Qk$:.,_].>YD+)j.CKA0q&*0Gc=G9AHg!'EME,^f+?<*M4j5M["uXWZo_8G>MR,p5#'!Oll at NRe.&Ed^?WNpOeR&uIN-QbI=s:s&"STl4q=ndQVC08'>>LRL.$QE,mV!;pA['%t)ieqFF+L/1fN'$L"hb6Ed/:;QuQEC;\a-CVJ"^etnc`O7m=Y:^(W[o!p)F!L?aii$2o='sq$--NM<P,DTWH.@(LCZ*M.lHcN_L[@@KOb2D//!Y2+@?u:9s3i8J1]@o?X\%d~>
+endstream
+endobj
+146 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 145 0 R
+>>
+endobj
+147 0 obj
+<< /Length 365 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Garo>9i$Er&;KZOMVa"RCZu'G*]MK!#GVSanPGQ$@L=Lt'E>`L at 2Eq*>UD7jpN`[-6fq\3V'r-mU.fnJQ!T9FM\(SY/4M'5M*tL+T)IFd['"9Rd+Ees5_*fA`u3dK!Uae`*:;7kDIU)C#6B-:g&75#0Tr:@a+-;\j=V.tD$O(obYmc018[2a$`B-\oc;U.=8sh1Z*hF$BHuXbjGT!!N^e/qYOm%fXiW^q`!M><7L9k)VR?1lR0!$#p._VL\cPgg7b+`sn2Bl%It)Wfku\38OdL1SZ4;uiT"Msc$1`0EMe*Yq,2E:<+sGo]qQXhZ:=XL;P`F#L`-uAOoTtDs+T*F&JT/b;>t.6+"E>4R!G(i*Y5~>
+endstream
+endobj
+148 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 147 0 R
+>>
+endobj
+149 0 obj
+<< /Length 462 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarVKb>,r/&A70VHn802r.pR/8.-D6;2#]ZLdPjb_'4_gS[=Wba*kb7V93@^1:*2#lm.Xpmj/Q#bq_l]<Q%EGEPhXkM,9(%8Wo%[EMc95PF'*;/?6Q&SMlJ>,-N8A3&G#"Q-$2FY;m>^OX*]#b`[U$^';4#YkbUS_O22D-8'I0+p@";IOT4]Kqb(G$4@,c#>7IU_7J.^5hE[S?t&>$=(%.FD5V1JXd]q`h5lR;pZY!=S*<"f?3.VGhKR]i*(<!WXbEXQ[_j5hWOBi9S.3e)%R5AhT$Fu?ACA42\@ug>m2Rn)?oo(eH%Yca<C(=nfV`DK#\Meu)e2+f&37KS#70:h[G]j1(S!n2M(&FR#Dbuc^lC%nb8AO*(Ibadb=F%is%pA5nc*+hkGcsFKD_[_bG3D$/al'TSWq(iReb)-=[c-6,X3(l0pNPtQ`a=DkqsraEI(/WR/R3B9?mJ~>
+endstream
+endobj
+150 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 149 0 R
+>>
+endobj
+151 0 obj
+<< /Length 828 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GatU295iQ=%)1n+kdGRu3(]EHH+.m4JIYn8,2"Tl%]Ub_#3*[>GAI3Vj@:CSNpC.A/gAQ$r:ghgbOt5>NJE<#<2+Ll_ru)0&2lb)HjU^IJ:eOUXV:>:I]!g,JUX?dB7o3"?t3S0#6:I*6:_Ht7p<i37uM,S)q9K1qWiMrWGeU`*Q>!1X[:_$V^tEFeB2.X1:L0K'oli&0etonM*!J"<ENd%Lm)sG at ul0`U4o]BBr,-rQs^b#a;T[[&4'*5mSF#s@$K)<=P=I5+n.5"8ZJ;%i.9eFQc8!+U=6+kVXHmf#rD6J[lsQ!g-+'\*iIR)NZ3RDGV6Do^2nIT=P?60qrApT=kPcmdmp<u:V,H62itqqL?_&oagh\4>a,t[91;hjnQ^ih'YDiIE:#uK at 8fl^4MN!(gWe"1/*s4Q+P8 at kYVC&:9!Q8[c(#=@\*9rnoG/d/L'\';b;Rq:0#JmYX15lW',R,m!gp7qn:*'nPo`o([oRTZlEsM_#(c,>ROGRV'U8>8r?X4&1#da[JeiD*U69oe>bNr8Tdc<U$.-TPgpiiX]Ahe5.Md;0=O"J&r4S at ZecqV%bs`H6`4ai?%!V+?i4P0p^mWC)3OJm^/@33*DQ&N5iWOpVgk7ahBGWaq=lXkQ]BP-IK1s;^6-Yle%gtGTlJ at -)NZoKEjlA6sj,+hh]Je$6raUZDh<O^k?Du7^(c0ih0@[9NYPTjI at 6^:kXW,bQ"F"#FL:AL:i(853l;0E45j`lk=)hf[MU>5OPF-Wk9F`LVY at kW(rtUNa?b]a"2.p`#KgsJVIWi7c2)K*k4)9&Qd+C.#/qA)$$QJUh>\j5F~>
+endstream
+endobj
+152 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 151 0 R
+>>
+endobj
+153 0 obj
+<< /Length 1187 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau`T966RV&AJ$CE(i;M!K$P&kqn/jViN8e[67oZD)GG*4IkrV0*44=#pY2%R8,(b at aV+Pp=j.]Hl"GRm]h<_1C12sY8<M0=kJJZrn.LmJSAQMn,gcA"4r?Q`qQMe-/Ht;*ltao7)%R8YX6[GMN<*^>oQ"fpk-BZNp6A2iM"&oD7di<5*5>#ajXtmc+RoFQ>(?rB:Osk_6]6f3I'a&U\7.oL4O>EpKjP-S#Dehq6H`2P:KiI8`#Q<b1Tus.GH7Do-RCpkr'uSZmK@\*5J$!C1p=D-6)X^AK5R0k'0OZ$F3V5bB"u:j)1jWT\%U$D5$'kaLPp(j`fFG`4?C\>We20;c./DYYW]fA4+Sa*^!)?pjnP(SDS:Q?T^SA>X_piGfXu<aAO_h7Q68+VSR:AlV>fjiDqKc;Nc2"cVfQYq0rm^c\X??Ui&d/A4qGhcP8,X%1_Pn!teDJW\2$IKLX&V\4.#;1jV-Pnfj>5.^((`*R'cV,,3Vm-I\4_+of!6HN/IB%H"c8'?1 at WRDMK#Oh;!SqDseDY?"/s-^O5G'al4[C0Qq1[Yt8?'#\J+aS*mt?)$VqF/_KZ&9E^b6G2q:YVrb4f%?D6)Btn6HTHH.Xp-%9,;2MIU,JT9'I&4CHH)m@\2%#6Y*LjRd7hgu,0C;%RI#J;7'!Im(Z=9E*3nY"]S2FFT!4/o&nb.L0?,>uI at esSU>1`AiS/F]J-_:P#uUQ--XeA8pjZjpk71`0,$O.u1>Uk6bYkQLES[04"kNA;&aF&t5U7MIXCtYFp)W%>GdoMB#nuqDmag1X6pa:U<L6\bE!C._L.K=(qUc0M]-$Z`F^DsDCui_5:CeO3C>TH6M=!RJZu=qEAP(\m4`Gk1!8<l6h6l[B$"2C5<AhR_^4q<7J)_(5M3"`2>SQ33Xga0,NF"6WAf/[a^XM;Bb:8,(dCNb#9ac-TAC0[?6pa:sJnC4k*0!W91$g=1WoB3ZkZ_hA;_5Q, at 5-%k<3YoC"e<CaRO3!.X1(ZKn^+U5TH+dNN-;9&\@rBYj=VlEH]jO'd:rSb:+4u6lI!Zmon=Jc?'YkOYp#'j1^1Elr?CJsf0Q`u/ICr:>L'n-UQJ,`4S'F^oDTP_@;LQV?IFA'0q[+3Nu,S.hk.KIrDqg!T^(*5mueOR`Ri(7XD[YM'49O=%M;pTqshIDr'!AQGl.ZG4]Tl~>
+endstream
+endobj
+154 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 153 0 R
+>>
+endobj
+155 0 obj
+<< /Length 972 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gasao997d\&AI`dEiPG*\@1EW:2arAV6/I:Wf>_"l+mM/7%76kZO?fIc3l]?+UAC"SG>9'TBG0[J+iE5D'9^'B)0%V[%:pOK'J+B(B\>JcN/tcQ60=\mN-X)k13n_s/&VQKqM=?TGE&s\Nq);Y)R27<pUSfRM:o4Ec*J5;ek*i0m9sH+"#`/Md.on;nP[H/^*d\>&+,.I<3GVEtMfana-Plo(3>F8E^[o'0m/3+]#"(o&CVJ%F%^M at NYl2i_'tB8-B/o9P>N:<.$>IXMTAHdD6CO]nhl<`%ao+3>mh:35G(>qY4Y$I#(38/+Qs^GRbpTfOWa!J!FW(CS'/53Z%rcD:A+H9VJhS=C/Q34ZAPe/W>X,)e#hs6gab)>NFYfX,$m;6j/YGY at 2o1,SRIWZqXEW\J0dJ]/5ShJddS-Yfop)6:q"_ at 1`^OO1i1DMlVL+]beeu)XoGb=Vp()Zf&*>reE!I?=p/HUr.,B`ZrM,LHHAb8'6)G_OjKpg)])#=#J24;=As'#p9]ZWb$>TH at 5KO=e(/t!'.+bHkAf/LRAS"A?t<[nfO'Ml?u*ZN>Z[RMOHES9=YQH/\U7.b=$5]k&nt/L5:]OMI+o=,&,EeL*#)aUQ5Q3nq5HX[V!_pN6ad.B43&$19>MjeYm5Z&^lP$*^qI:e1+<&PDclPH`TP0]@cRD=-?5>d_pRg$iq/i[=Qkja&s[jj]1]69g!s\M7i7PfOc+6+kFO,m_'C?WO/8#k8.X;D%@1;@AGKc`Qcu at oVl[im=m`M1/8ZeSV8p;ne>t1B25RP3t]PCZ</gRJ.%itr](chJdn=eM0Lgg;C7!W)[Z#Vo8ml7!N,<''/et,=3%Ue;fl[=jtuH`.^-ORglH/i6[g0h!O$oEXH%jFWhEr!.?pjPeG_:Gjl;)(2KWBhci2Hja%FZ0*uT3T>>VGB at I7YkBD6j^OV2&/e2oSsBWHQ:!n%4s[)N&7D0<,~>
+endstream
+endobj
+156 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 155 0 R
+>>
+endobj
+157 0 obj
+<< /Length 738 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GauHIbDr&G']&?q?7(qVD;tkCQdMUe8falLeBOcs#>>=.9M3BJo(P#F@$2Y,;,q1;?f/a]pR-f`q>AbF=?tku0Q at ZV3>`n1_a"ch!"Tq=3<N\"?5?<l=%i#jK\m2q!K;ti!VHFdC'42:'HV-(YtEfI-rmk-DKXYPZqFNg[Fc$7L>/Iq;QUF]5n6DerX>.]@tUKS.QiV%;kaDL53bOaQVgnU+]e6qa?9kjjt5ZiUau7i`WXmMgoiGg5g7>Lll@">.l\.)'!@^7],[BZS<_;8K.IQcIT>fr\^FKA<$>Yb0K".+n`]sNB#ct$e'cqQ1.!,FSh4fj&,6lK2&,Crb-sfOPum+IhH:#1<?J:?[!%*--#[qAoAXW.C*Xt3V93P_V,mKY_Ko$9VlWi[Ko@[ss2-jal3tfa`6</[GuTQt9_VOjkh0[I'LP9%&,\@b3iNa=:uIum>JJ@/T38jQA*=hfSrY&Z=4HB`b3<Ld5IikP<LH>E^.<CCb2M_\B5ugd1u9cFdL.8*6n#X!8 at ie\gh+]'ZD+=>:L]fk82u?_hE_dfb0o*I<XbJ:-]>$Sh^m))dolE!KgF</cY9IMqdH$@.]NubI6n"A?n)+?I6pUd1YQ^;<MNBMf at opTYF*nkm$?a3U$pqtRDOdPr>DSHL1E3:ISMCLm)D5]1`RVTE;s+Y3coh[s2BtiW:r?Gbo)pJWBfJ at E#ukh8!=bXVI.[8+j\dYLU7FO(`<8S;-Mtc~>
+endstream
+endobj
+158 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 157 0 R
+>>
+endobj
+159 0 obj
+<< /Length 1111 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:9lJcG&A at sB#e`&TLugS7!\KN%Aq;P^!(GCDl5ge1Fp-H\=-D%phj5$gOcjR\Md>O5;LFunDe@)dO=oDf73WuW:82jDJC.t[,%s.S#n14[,m+Hd;7_\"?/;QP^5fotkspA8&V=VI!?D1HgBF0V+:*"Diiq7YforGqrH/faAiEsH0c#5(lFNtn<;E6,WN=L4?Wrdr:I(K_^mnLk"q9q7gtb\D`eah-"F4&&K*FJ0>]NddOMD at t8S(oT6NT]3C(^k5iXYPK;Dd\%KKFu;('?9V*1tWb"!W!T'np.n"\hQ9:(ZmN)r3MjFjKC+R\"Y`0a=!ZmXUdAF4f`o799a;)58In`G.+,C=TJb]Q%sJMui&$N&PB)d?+_I2j8Me#33 at 0oL;p?2^guQ%?)UEa=7;rX<,Q*X&TbmqGqH"<i\>]9jWKgl_.7nT4(/o$p-1m,^d[IVIBfGJ;bVGMRerlPZ**7i\5lI3ihh"PF'8TSO+b,&6#bM at 0EguC1$4+(%%>+F.G:Q\qO1\DQNai9S./]%)uQc":OmeN!KN;fT>9dNeF$6J2`iZ[6Zo1J#jU42csgd!k28,HEA]'A30?+)"70&D2V7o_2l<h<$osJq=/!UZhT1R;l+WI$YGZA%TVKN;^mHp"A&+Bl%/\tY@]Be,X\*64T7,a692hl`2O:CjcE&t`Ss:`:3:,lARokEkd#0!%@&8.(_=sk at tFr<";!I9kpWu2qQ9YCqHD,[/<L2D,TZ1DVm8lN<<peb at 1qL.c`f6`XCG71l6YlbqI_*QIf/n9eG5ugX7gsG?Cu at m:^JQ:O5B0A+0[TZ\dmn+=Zl#MM467YNIs-ea/4`!>e3Y5eDmUk[Je,=(q93p"H<'JT"DJSRi"%CrGnA2c>107P'\4\%PQSW'(D^+s1_[RcJM8%Rm]h%4)G#ds1TESM![uoWGd'@Ful*j[R]Z3n0)0'5q?nim]cDBRs>K[H\6Uq7bsEMD`g28gsD4.c.Ym-7h>KYa-Tr at .'_K^Iq.)P;f-Aq'pRtV_,K*>l%co3%.<3`$76ofP+5F[9c*i>p:]90Ca0_CFpuWoda<C2H1<$uD_t6F3P2K0oZT[@\eYchk;\(Mj=eG.bl7~>
+endstream
+endobj
+160 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 159 0 R
+>>
+endobj
+161 0 obj
+<< /Length 288 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarVI]5GM?%,CLj*1`d^W!=W0%?M!(M?;Lh%RDTa*ZV)8iLk[-3K at Mm#dg+HG<D&#+LVLab+SJI67!o,JjAHgTN$c2*O(l4H4-F#cf2 at 8;ll%.gq\hg/ebO$.)Ok%?8h9ViGJ*HKBsFWGpK-+s$"@X2">nDD@[LRU)^LP+/uN\;B["X,h7osd8,VjpR#":GLrEbF,<+SWN0(p[*j,3_/6[LP$>:fh[GR>Gb9C+`:%fPgVD*<Zs[cRAs=K=i^<(LUQ>rMVn2[(>#OK6UN+cZ6qcT*AL(co~>
+endstream
+endobj
+162 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 161 0 R
+>>
+endobj
+163 0 obj
+<< /Length 1740 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat<AbAQ>unF!IkZ9XPF0e:!1aI]]j'^,U(TNItU\d)E9*MJLXQ/k(,^-e"q8Qh4_$XGa0)9mM_jJUPf\)1nM at mlJf[9J=#IY!+_4rhKDKgCrDPXIW94U1pkIMIq7.ekr)I/trAi"-0EWFN_3+ejX_Qt"=FQ+NkDNfR8XP&RgU\L&T1ctBo4$X$\ekl79Hr1@@(](c?pB(R7"+?H/sb/d13H!-f324cQL`[D-&kFWs!b+?TBRI;fO:kU(<o'NPm`9W at N3,-?b"Q>.F4_D3CG\S'$)6aimBU2NJH?#:p_m[#C0E9-Q$e=f>J.'M7=Z9>em*?Th3Cc2k[A;Pl%k]E%2J@)h;N;X5Xk7shhr8TSELf!S]9ksE=@?F>B&X[;3Gr]re8LD;nmLG=5r9?T^TQBeBn=[%R+=78<ds5qF#poqXj0LsBQ/7<lc)9QcE>nD>B$Y.6n)4_MnBkZ_gj"61_uDa#M;SZ(3XEjB!eL+aei'T?:kUHK3T==pb#rgBO0!IO0XEO.$jo at 7HmWQ`*P>;&9XQ4$b:C6G583Pc%<',B!$]%JF$B<+OrcBa.e]]7D(bDXZm7s2kk%,PuKY9(,Dd%V+KZN)4o(\(8mI'QOr6b8qP7!a=>l.RDEasAi-/(7q':4?fDq4-jI"ei\TrTkSneFkEgbbj//."O2cqZf>\8&`#m:%EPD^hHo at XaXI[InWF at uFU;X(3'(T3P?4+*j=0r0TH)7iIK26(7(P]r:ZGnk at 2/(Y7[4t:AQ1!cF#jHB<gFF:iogJWFfUAtc at A9*6J.7Q*XP@)c&KRUL#_RXWFF%ON*SRB\a[JZ*8r9`-rcKP()$A"^6h?C$_HWA?UH:7M3I[D8FHcC]EkAZsY`I+rIJGFp at VWJ>*K)O'1e'FMcK>?f)Uf/9U'-`*NX&'X?I*m<ju)Akfl?Q@@a=YnZ%a7^m"p7i.De3pjI^"S<V_h:o$$?[`o(LH3l^M/Wcg!naFJO7pkPUMd?saEQok?,(s]9(q[EJ.n)WcJV:U&s-j!JP5"ZU`OuEmeK&J9THC/BaZT8&-Y\C0W0V)&C0JWGgY;(?XNKIu3LE46V2WE<1c9/re+2T]W2QM-lh%*crWV(?Ec&`AGo`3OQa2dm+E,ZBU!NW5\G-j>%2<[eWR%A[3>ROr$Gn'h>1AGi4c=A5Z(nta(1ReH:p48Dqj0 at Odr_4CrYMD,%2^N+[$la*1n2%cUp/%*./i1".om\GAktd8I-`=kL9HNM*hLU'Mk;'OaYk6H#3JSt!V#qLB+_oi1%pG>Cc@#>T]P(n&EbK;WQ?RF1(^Mik2>R3OG^MQn\^%5X:Jup<G?nOef3`Un&t@)HlcU5UTpq%JcIQ(_X3o]H#t$7#,!LI_4El2\(kgYOXS<=C<<05+Y5RaI]1l&/4nYf&Z/9E)f)XRn at R"HjbTJ#Q(?jQ>m]_,jG.TeN%<MWn>WA4L?#L]<-T;6%5WU0$-;nkcQ<pL8p-E.R*4h0?Oe,ot:6-R3&^-*3-o6V+kU3.,<+#LeqJk'h`$5OX.&]XeIkKH>,<V9q58%ft)".b(FCF2T;=-V5d,`rig\&l.pUd!?R^ig>2@@@3@%hl.\XVis>,BnIljSF3n2\]U*hK]r-K&P.=EWBP+oO>;kPdGT(KP6_?@'>OKfh")mep#W$?cB;an?]&%\Da"H#mf"A`qbDe`+2iCi%)1l at CBlm5fo#-%k%5YJmEiOAJ[;;7b-oDMS>0iF$F0_Sh?3+#8f/1]~>
+endstream
+endobj
+164 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 163 0 R
+>>
+endobj
+165 0 obj
+<< /Length 167 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas3+YmLOe&-U@/^LBee>^)B+0(jc2(4qWClqFMK7)Am^H?(nfgC-0]lSGZP!@fYAPlqn$83;O:f<Z.2g*$td0)!o%n.I,0*GmRfVYN&)irFF=C$Ar#ks0Zg3L:p;CVquUk>GAmHjmd3B^GbV?F4huZ at +k.?g.kjSh4X~>
+endstream
+endobj
+166 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 165 0 R
+>>
+endobj
+167 0 obj
+<< /Length 1056 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GatU2gQ'uA&:N^lo$f:WE.(<JADc$F.W)#b<.XmDqI"mWQ at _I;ZX*RENcVH=2GgA>6Cs%[bjh+kj^C%Br.TAD"?>sQklc=E$1abg+YUb6H8H*s6j%@Mn:'6-YQLMD^V&)uN=%cNo`P_=!=2a:)IX0i<$Sh6SX$37-#2_iE):tt>@SXVl\VN+o$TR$QQa)aJ.^1FqC*Jh0Z"Y/172Ft3>ENU^i4*=+T`6lE8Obqj;l1dXKNH1!CaAM/C.5![k$c1O\#X05SRQTf&.+P>aS<B5\Z*3UX5t7U#;cQAh&&6/T7p*JcGpn=9k?4]@2=(ASMm5+:aL:b9OJZqZk;>]Y)7lehYUKn0r at fN].TI6c at b<89mC8o$#g&c^aF'6C7+1mN=/U5L(&hRscF:-t=''(t/J<hVB\4"P[JBHK==piJ"]2e;d6YCMp0^U-pV,@%@[klj$HW295P]BueF-1L]"3YnA'W4+uD&:W3?<eXI;XK7On3qD.h#Znh7\cn2 at So.8)bE6#:FgTaSO414!U-_8,GO%pS5)VP]-5XA at JH/`C5Lh!R9NDn%KqB,Sd0ZdF*g58,s81dLkFIT<'c(30NSd:Wb7n)3:_@?@a7+V!%lPdm5jiWE'S`kD*D<,kR4fa^`G'M5RZ^K,*!\uY.ll]<r7$0*ufs!>K=]'!H/JXJ+diESo]sDX<>(#T$nXeg$mob&iqq^4Q;L.Y)M$OAaT at nW;_lVp%HDO[K72OV29hF=O("^nNDsVGepbdf6F<lYCDK"NWs(6+Dq)l.+g6B!"mSA/(mj-f9oX`W&6#A<U[Oq#Zi571``XVU_$'jj[Z(?sZ+Ya9#/kFt+\S"@Ic;#W.*V'Jr#K8Ej;&<4&2[@s8PnRV3s/P(W\M]^_bBs!:,#*?WY+G<`**AOPNgbn*Z/A:b*\m\?EaaRmR[^e,glUOoS$tF/Dio]Q24FF?-("Xn([8CAp2SiW#rh%D3P]IrV,/OOm\H<dOOa`Sk`Wel2>LOm2pK">H?shM)+-P:\<ft):EEQSM:C,^b^8rm9rW&>I2>i//fa[Fj^2M+Ku*~>
+endstream
+endobj
+168 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 167 0 R
+>>
+endobj
+169 0 obj
+<< /Length 870 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:9okbt&A at Zc\97NWf/=J`Tp;ouHDo>Yg7Vc@*XFKW.fu\)gSDTuk1^"E)ekRq4dsF():,t;PAe,6Cmg(\m$`B65]^id'<3-0.0e. at 49AcCR/YM2q=#@Dfq\AdoY2dg0bI at p$If%e/e!bu!OYaXfJC(Zi`%O:JiHia"X\rL_ZjW)h7bZo3.#(:B*u61'f6QfER_1Je(rGcge!AcPdt1p9nZ7f64n0FS]KD*'PRs&.b:ehAHN/t'kD_aA8lE at hCsmmL4L0a#ERK;`ZdAB at laUfgYXJX#F:4hbDCANLpM>MK8Sb!^@pMq#Of!eb+9.GLdruj;XF!"94[jqPQHmg>J3G1leR%)+3ncc=hP!T(takFjZ2.Nc2b*8hZ&i26o*.-A?*%<.N%%j2nNXi,",_TWqpcVFbIah.E?8+Ol_/-&R/K4?5pN6*E.',OSe;1=N1O!C&G$1c'9[NUir"4nN(EE?6E<DUVcjgM^pNM0((R,T&3)`VoHVT/W#9fOo3/';"0\0Bel`fQKJ:)mCMdqaKfVK.f0kRC>mZ_BPd[!CE`?ASg@&51&n/dANeYq,n..qD)DNCVITUGH+5"h[]S9.m3eM\);Q^-mFVN^r4?''k:,sOpXM8`SmkEW7V',W'[$Tg=cAj/U2,E at 9c#0+3lASHdT0V^(EKt5L2$6=g>j#M9b,p6<@o-agG<Ne#e#,XCP^NhGO(-iq2Y,9IMG:&PhBlF at l;4>f%]dV9jTPQfMXK^m-&!uL\3UMp+d^+(/INjM2PUA]Ok*Fc64\c3J`$Uf3IH(@@p>$klPh/4/B+ONBbt.ZI4dL.on)jEJEa(Ql-e!N$nYZ;,)X"lITp$[=$I2Ee%FCN^suW5Aj.q70~>
+endstream
+endobj
+170 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 169 0 R
+>>
+endobj
+171 0 obj
+<< /Length 835 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:bDt:1']&?qhK;rY`_L?jMcO<:WRON\WL[]\V2GaAi$o8+R-F,7FWMe<M$Z]f)uJolgiFROL\kKQrj)tDK at gDp1ipHUL4H%K#VZZ-5WOBZ,p5aocb%4O&TdFL"CF$D!9 at eu%6=M$/e-=NOL_;ZCkZ%,EMaNK9VtGCF0NHUoX\78bduO>TlMSg7F at O?mPk2:H'XD8QEe#*(6(DTr304W>ei68AkRk%kW;KohnjN-[1K*JrJJ-,UkmT`VdlaD[hcl:@JhU6K-?uA<jN!iS,jW,p`,m=r77iFVb0r0pS,8g;T,%4A6_%fg4t_0r1&hM!e_+U33,9JbdW?qUoN]2 at uqAbl#*;dhYfHn%qYA"RF_<Z(dj at q7],lnXLX^Kjb8gpR5&#N0'"q(3&,T6%dG7hoq15W+q0KGp"[QA=ma.W at dE:SCLd,%_a_*?\Xi.X'J^IDK7=p7FHu)BWL[TfGXp"lYtJ5V%SRqIjiC_+?9>ilhal:7&&cpaM25Nfr$7/B0)%tMl/Z`)3JS+<C1+90`k""QKhQ"sSdi/W"`\BErGT/,W2YrF(M;M(%(j;^e2Y?5 at 8=VqSZl,e6C4ch?XB]Ujl;kKQE)<^+^V)?n.mAJf[s.JjfCQ*EemN&\Jir5dn\2o`EjF:GGV,V-GuDp([G at oQene=,]1c5$o]@U2kmcu+/2<-<A?LOQuY`2, at up=H:>6GLNVI5?nSK>U;,u#Nmht[LBt4jiZbOZ)WOb_etRIe at GD7h,h4%hmF/$Zl9jk66OF@?lqdR=WUaPqf'*EFSfN7%"c-dJBD96Q,P@]klIUos<WT<+'REL5LissA!Qne2KE~>
+endstream
+endobj
+172 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 171 0 R
+>>
+endobj
+173 0 obj
+<< /Length 680 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=)9okbt&A at ZcI,#_$HMgKU=`&J`e<R&,?CF$%'9bjW9M1,Pq=f#^"A#cLY.3+r*qO!8hsd"$?bS5t$<)qI1a6TH!@%LDUaRQ\`WBp):pNI'+.ga&:='A@^3c)05^\(e>l[.9#?"L%(t=AL9rFj:b\=Z71KW:>Ju2M;_]G,.Wcn,Ie'-K4HXPRh*OO#qj/PN72GZDje)'(7FVUXR!,L"Zs'\qsIYDlieF*q.=G!UtMj#[9q\9e%VpSK_68;"LlqdchEegPrhr7q<a]+F=SYM^/&6QlN`m9OeEG&Q[[9b:%$fJaaDVa(I1>ChlSM7I_K7["F-0nG:?PgOs&[PNCVQM'oh`<E\rS)5<]Wg)/Kk(_#-I?es[4o\5Mb(F4#!%((OIOF/\$f0<O/g;J`uoIujiJQE7CFkUgl35;F23J"$S^q^IKcPsgJ.AZa1>&K2HW*rX<=[(R(o-HIbVE2!tMD)B,WJ;9XX!?P\LX"H7Edqh:JD`GcC(V\p?0OE\^7Qq-h\'DNV&<cXHE%[B&jPWYtuT6HX;url5m"_GkU6Ve.'s.YbAr(g^"5N;Wu8d&-6ogjLG$@ouZU;0?HN)f<$se;LCjRe-?"e#5Ks>2N8G-deR_VcUj:o418%=qeY#/4u\0d:729kWQrjj">VF*tWlp8BdR?6+&0A!AD*pq#~>
+endstream
+endobj
+174 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 173 0 R
+>>
+endobj
+175 0 obj
+<< /Length 1126 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:?#Q2d'Re<25^cf,J;\9[0PQa!2Usj2?'h9[eZoFHQkV!#b`K4-pTq\DPCt7n;l%LdptRNpH[RQB_8Qkl+9<mpU1E1ao)Z3<nUhTC^p3ga"+foDdF.l>ISZ;HB`531Y6*fgck-KcVu]./2uEXVJmjY+1!UE$E_a)2b=8'cE'?^HB^(s3i_UCH]gX_e/[:tV9)>V%#QdM!rC1:g[h'dsDJ7Z+54iX3j#/FP>Dig^blj:L#6F%`"2QE/FS:g;6bCDd+hgmo=Dh269<5]rb;@Q%E<_UiQ(L6U%3)l\Z_R&;Sd2oieF4'BYEpdj$^l9,5j1L8?Grois-/D!pO]Mc_a=^>54/R.:E'r56:UhNPFSt$hG8rV*uq3oeep[6Jr,:ifK2j,)cKY+(gftlWP5rq>cm,$qsX-cK,PWaV-1q&N9cI4`Sr`-VV/W&;/NZ<SEi%F,u<469F/t2Vo64]VAF!&'hN6nlVQM#$#`!crg2UGAnHQ at a)UD#oMp_uGR;'VpA(-l0i(lkDPmgWLEUVugAlNJjpIjq[[A_E_]Ca\11>pDf-[oH(/.d#naNdHRfnJRQfC$9>V1m95L9W#fPh*mo.!F&,?/O,?KI>s>dpGplLi3mKlS'p!GZ!fW8Y*%(Tc,rWV at cn.E?_B at D&tjgfC7c(F"tV^"&f4qKt1Ab29?b/8GL.&9r).Dke5?2Nb*X$X5Z.YKZD%K;Q(Ok<>7F4,</-^9m?^^^jWGs2>nVj6arB&pt+L\,TXehqfAI&ILi92O>C(AJ0#<:i*nm97oW\"bOZWnpRk#@aWRcd0cHd``f,%C!o(W at BAX[l4%Jq&4-b+GK*4rD5i?6qDD75U>QGRq,.rnP"(?5S+HRC%d:U\7'F)q=pqO`FL,_UC)td?pd,MKO;$o4kXpHZnGuVS)M)L[fBqbt8SZ1d at 7n:PUG)>kkV9 at b^>Id;j%2c0SF,Nd:!4>?]H0kg2`9#IkW'%RmJ2!I;$0:Oalqu6$\H;/4B&$0 at le+jO^jn,/2!!i$+`OORkt8lfEm99:lHF[rN, at im_&/hmbC^n%10g9Y]"\)%K=r=FENP`@7r^0E\/`UR?\20$ne=2K>%`__/o#1-`.S4X8'J1_88I,r!1RU^>f~>
+endstream
+endobj
+176 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 175 0 R
+>>
+endobj
+177 0 obj
+<< /Length 235 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas3,\I-2=&-h'AT41DE1 at FLkfsF's/-KrSYm at q'J7jh6Dsugb)j+i`k4iQR`FPis(mP21$42&F+Cc"f64#1p]$u<r_KqG2[c,Y6k>Q@;6_]r&ZXdINWg\:^p2=HnJ=f?\!m,[.aYu_iD59oMC[/UPq%Rd-ah>4Xn%1_@"tc2pbF%PpV-&VSs*2\#jNPV<LVu?c$[!k]U99F;D`0JOs/K7#SCnV$5Z7<@?HLY`@K~>
+endstream
+endobj
+178 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 177 0 R
+>>
+endobj
+179 0 obj
+<< /Length 901 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm:>Aoub'RnB3YV^'02W<?/2Ge+O;RLk=Zq=8l]o5*N at T"NS)4.K$pG:r@';4E[MA5m=rd;G$k at V@&pr*HiJ]%`HBSF6NK`R?$$lf<\i#[M'B4-&d5HjL-K33b5@/Eru(r/[KOJ!)68\MrG!Z`4=Ln0@'.ZLcV%4oB]j"$`57n^<8MGmC9NBf.l//Rj5J=aGRSrNmGI%32\%YcTNq0WRe4R4/FiBsAW$9 at 5XjPc>h_/k\-`bJbT"qcYO)4B<t0H/mU*T9oX@#H7 at hqMBMV&#h.,eINJ4C\dTcY4HUjSS3bdS`*XEM1?+Ps.re"8PHK<2+VoCZA#V#c-66\]uQ)kN at Y\%UEj`.qOhTe0j9!(&onFr]FhH21m\$cE]>_#4!O8nX*_?4hPHj1'0'4O`Cd`EuP=mU'UAc=IT%B=+-<BL^<BuY>ni64L#>9lo"(rSqFp80bS2p<YS-[`K519`?-pn2V1Tiq1B%>+0]Og[]F2#q?I'PHjXnR^90nS4UpKi19.%I'rON`>t`:HO0K.4l!0SIfL-QA?iDNR%$DkDK2PgRVlf=U[g3G]4)O&C`eLUTTr1%RLb^`.lpYV'8QK#ElO)2jeYEsjZSB'mWZV,2"jY>EpVm6cCVk>@H]GY<I&o\Wbd0Gr^IW'e&JI]W5X\dT\PN<,ImI1or,lhaR^<nFDKs5lCqDik-l;KKX/6>-8O>N@=dLD+5&8Lahqot#Pk9V;GWU31SJ_"`]-rh!?L2#."mLB#nDtuNkc^bAE*3RandC#2G.qi.6STQ6O/GFdfVtG!%^#UZ]gT'r'QQdsH:";DA<74!5K%+JeGIEa_aKe/FiP3a[];X;LQT12eFODO[752%$P9GSYAUf3(M*u`-gu2(D)l4hYi1\PL(g at _rWacT2_+~>
+endstream
+endobj
+180 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 179 0 R
+>>
+endobj
+181 0 obj
+<< /Length 301 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarnQb>,r/&A7ljp/iTmqJC;U6k<N6P&H//PAEif8\h`kpj8/^Q(n]IbO!O at Nd!C4Xg\Y57dh(FQ>tP3!IT7rUt;QH"7%u(HNW4/?<0kP44X.G"0W7WMpuIJc at V<&Kb1T_8EndSpT.Y=%1%uAZFS0c3Ai at SBXPE,\<CMK=#!Q$W6\c;BL1gjQqLH"IPJCj%s?+Ggm29 at Q;XGhZ!\uiqC22\kk\!;YS`CKo8cnZpg]eL)P"![#jglIlKM8\$l[J?bX[m'>5$/uiEBp8m/PR at U/P<US?]$K3B/IFjY'=;CSU~>
+endstream
+endobj
+182 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 181 0 R
+>>
+endobj
+183 0 obj
+<< /Length 973 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0BheUt#&:Vr4 at 2Nee/=IhWQ;t@[au\`oKi,1CAIjYCV]L\c.EZ?#f2&gi>B]!eK+5RdkPLtAmaI_EU=$SK^5!Q at Tbf""kcI=qKB>NB_Z4u`V]ZDH(N$hRj*S%n'CU\mI5Y-U6dR4uUS at k,KcgXU?p:SA`-Rup6Ha)+/"*QGBtj?k at m0@ZQkmj)3QA/Rc)gcE&W*SlVqFh'/=)8@:E7VkBqm\7AQVbNT(O+q+V6tepb*glH#;POWLY3)J,fb<aho:Nii0BFVd[Ft%)`,LGT]N-$%aO2Hq_+XoO1tb-%I;ufD/IFGp_+%BU:p+(CipUM9?F]NV->Q_+[Zt!TgC<SuL7h,;WVkOtja$,"4AUXo12`hA=`1LK`5^@LPfc]28B=84hDWH?;,V1NeF<4g]3&F,+YACnMA/O/^%PX\e/oBW2sQ429lqKAG05_$0<OC;@1`faH]FQrT4R?k=5sNu`7#d`SaDBd9RqqGHIb`8[fk/iHd[QZPQ3AXk*H>eY'u7B6qUiefmY5Y8XjfniaBYEV"g&s0bjF,DC(S at 3K`&a9RVNl<_IFm36]ZY9dJCYKBL)++U)a(-DR$`P,/Xn-B%cNr7e,RJ]/\82[SN'gp[E at 45IAuu@,("2NX*:2@,D27n`B at 3qEa@Ee!<Ees?E)I9]:5atB,QE2a*!LNr.pN."4^FYj9/G[b#Va1I^pd*KZX#Z;pWTike)V/PnF6f=+"q1\h.a8MqkBVk at aV:?,mLul1(`R]pSXd3[ESB'[@C#"NAD"7ID[a@#O[(7=FY8-U<aM8J.d/hem?$Kbe5&k*&_^RDAi/0/nJgQh'Rt=`bplUQuW`NqbXfK1HA\oCoC'bI?)Oo33k\4(PgtZYXg#9S%-Pt71^Pt&kckFe=ds^D;'W)%mr;-'C[,,4i2%mqGf[>90H=g+?WQ)Tiii/-)7Z=S#EA)&E'22X'\DpGFL#u!+LLhgk>S-3qS at 8~>
+endstream
+endobj
+184 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 183 0 R
+>>
+endobj
+185 0 obj
+<< /Length 605 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$ua_oie&A at B[GYATZ\W]'$LiXuk!_%cKg)apqE`?/8/(820pE_9-g60O20'$^&/8sD75"e(&;Lg&=$=lSW^b3G'q%!R!+9EbK:^IW;$N.F0W[i,uIY$jl7ra'AGOV8,!%,N)'S2G,(/Zp.X:!^LE`]I2k-rIg/Q`T+*,g9=,5^,iG<PZOb#Gf0pNQA5#LL53i2ZNuRqlZF]ud/lr#aTZ.D9/"6V['uQ$fbcM4m7A='p(+fF)4Thj?IITYR:U4Ip8c?S7^fSjp[ULd3N4#NU".0UbG'BGTRbR`.$BkE)UI"l(uI;e9\[fp*2I*&CAu]cGqDlhr9VlMXmidPrD3#s,9O%IGi,"l/cL3nU`]Ah[+qLWV;D=r>S5Wl&8L^c>Z\N%#5k=)FK=k*S*h_3MH8>Ri)CS?Nbg;>dARWVfQ4 at 8!*]a6goF0'sG+X[5\((!V)29:U1:0"5GgNHJ+n.*#mG0SWiG4tO.VJp"(q1e2Q(1hNi45g)Jt.PSe7r)[&oTjljCY?u;`8$2N\e5)o&7Ga at mVqrteS<pJ*P!A=A*;sDM9YfX*q,:cgOaKgiZ`0^-OM9u2^C3(QQ[l0\8najf+-han7f~>
+endstream
+endobj
+186 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 185 0 R
+>>
+endobj
+187 0 obj
+<< /Length 1273 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%#hf%7-&:X@\+lm'QJ;Fpg8tlB'5gj3S6ee<8gHEc-?t at F2.Z5?:,u+F9;C!Pd[N)a^&EHSKhKR$/IcPCSq"aYDJ/LTt=I"dmfIgPCW?2sf#XgtI-\/!aYhB?^/Dnl=]+4fL<duNu,_2"<TSs'WLjDK^&BJ<o/=n?%$VN*S[;A80n/j1AFV(:C5IarCPW at uH5nC(2jc2?Peho+ZXE`cI]_&qM5HQa1glYYfGh6bDD'/Q8H/:j'2[kY=BBMV-+<ZdUr=(=]+&0Bf:\,N8OM]M7]ROfErB/fpVf%<6'-R?SoKn<""Y`!J+c]<8=>(bq:nabK8c812Xfn;nK?]8gNH>pZNm[Cq^\mAu(!q at WR-[4^0f;OcJ0`Ib-+@@<m9(Yk6a at -]$,l,rbX7E]7p:,<I49X::^KGgVm3d97t7,[H$X;2nu8Ui/,E(hRRUB#aCFZ.X(jQN)ph%#3U<<t1-FH'!md7[;>OaqprI:Qp,+P&<kHL)f)la;Crq?/q4H?8H5U9YL-LY7.pe;3-QEFi*[esu(PcC8=3LELXK/AS*]9.JMLkh%VC3cR5L"PVG^aH1/lEVJ(r1flj1hk-&CnU=[0o\DpV.:]*a#<uL+tsY*P82QS^D2DCaZWbl(h@!Sb+;-m!5T$j_7Cs=^f3O.Cp`O3p"7n&'`1qiLFKpE/HlnO0 at DfGkLolf@O#L#j9kRjXqEH>^Xsf,IurF9k@*C:Lto1&KJoP>^6QY8W-A>*&t]Q.Wr'2=BSZn`L>d(39?]oGC)BeeF**q%u5K1DsNj/"kQlo6=@Z"0GAf'',UP[.s>6C@<,7qrFBl1$;OX at gdo+PgGk*V#'8hsr\N at PC9Ph+N%"id-3+LU_cj<91"B!M/X&9Qb._"&Vd1tQd5-bd:Qu]q&rl6h=+BK&d!A&P^TeN.H`uRMJcm?DK[m&']U<,*7SL7c>PZ>4nqIK;]qK]"26AWFS$:Q at ZP4_MqYE#mN-cPEl(hk.;3el9021kfY:)^j at K$Lk^\8X]9VLP+JQIh>Jj%Z=p`o_GXAi%I5`/qP:"*&1k)frfQ at eSG1o['SHL-cX\N:)u\RP[SJpZ^a]ZA=oO4s`<C,IcLHE\IKo0c#LF_/0X<?!jL%IVD;4_oDLeKUA2g=hPQ/T9;'qLCS*n_(VE<r6=S`T6!S=^q=&W?Nbf0#&5)[@%GG=YN!4BK^A6^65%io?3gp<>mS8V\&8tMuV'%#5VTUDe<T."d/XSYb576>MQ?@&#L2^Zfg-)L&Lk2!c.s/fX^ne'^Z#Z~>
+endstream
+endobj
+188 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 187 0 R
+>>
+endobj
+189 0 obj
+<< /Length 841 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!bDr&G']%q&fQCeWCE)"nV,ka;l(Vo_C4j*3]'t5AW5><;U.N,6jqSh%L8hJ`0DBJSnNAfA_<UD8a$MDoSe]0oB^JmBK'J+B(B\>*T)t'N.nHe7GE4j$pXUuJpoL3gKqNH_5skXhNIc?l\.7dJWoU at fo@T)p;C).`QKLSGYVBuWmrfP[qY"49]$)X at O9`Z^X4&Fnl?aT<F2TBV\#6PH7[CUuOnhkHNL1cZOoFUS#c3)@!=+tJh-7S)#^ETBr at 8E%r"<J#4=8](J0EKtCsSO1c^,LK\r>7,JJ]Ma?_Y'VJDaE7#I8'$GSG3,.A[_ThsEb]jh=JY-<m3M(\e[V`Fp$HmQ^KODVjA2RZ9=a0d+].6SgN1lmcQE_FonZXsui,`/,mn[KVH)R$WDkC<WM7CZ]8L;E]"K,-XTTnL-ZPlQCWj<ELT%9_*!s6A2=W9Y*J@$O7=&5R?m&%E!.ILLFsE at bc<u(m[H;L8gN_aD$$ojNrRLV$Hg`QobVBVOi&H at m1'\jc_eu(*;dTdQc&).).$-0t(%:0DU'aX9mo$Bu]b.-kCpEk(U&B>i^*;RqJ<.7q:=ejP(Gk49Y/X;g2:E^2V,#4)s`SXAX3Rg!+U*mUmJXeE.pYch[QmN^iX.$irt,%H1$-[Ln0E!;iQUj^l&:DLkZ$12dX2KSu?]L]G1+br0:n=YH"6*38ATU4TVQ(,>'_l=6EBjgW0e-qa?l]l*.lnMY09YZ-rGcf"e(?.CT[GaP1$Zo`j]8#<\O<(fa7QWlsD"?uF[+`)b\TC*6(olHUFXsUY=6Zjl4'sG?R*eLAdil.>Ye,Lhp=i_#5^2Zhhaa`KGoA9~>
+endstream
+endobj
+190 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 189 0 R
+>>
+endobj
+191 0 obj
+<< /Length 618 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$ub>-hH']%q&]IPPCp%:+DJ2E'j;5oga+u[e:QuUPR9JZ9O,l%6t%jhdS9L.:`NfVMsk<?'/i9MsBW.BXJ:'4+o!"!ci'$Yq>'hJ[r,k6UOSGbu:k+)>rnMc5d"KB#k5]6X5ommGfBT=ZR>NS at clp\3d>I3(TP7&`'94s<El$iBM<-qho^T0Srhi,?^lM^(9*>ohBl7%Q.+f([In&`_<#DhQ^cj)0gTkY`pY=4_h*&,d-->[?D"&s*RM%5JdKP"DId$6a[a6AEJo#gd&kg7)4(o<H>,MbPfYh=J8MQ3peCPX5CpJeC=m-g/$]f?s(laUI6K];$"N`8lV`<Rq`3VFr!4B`,,Bhb06?HkV226.'J+I-E^r8,"V\NX]cdFN%g?`u=kpS'H%0=$F\mpc4#)mo[ik"mH,.)T*,NS1FM^9-t3Qu-%N&1A2Dn<<g<q!1kpJ$a2CUI,M0UTP!r[2B\=1/2&3:F<+KPt)O!pbpUD_TW[7`LGm7]a]r=2T!r/4KY9,6 at F_,)2+_'<6LVnBl]V(&#esfC7j#=o9$@5!_r>i_D2W#[DTbiVs?o>7'h&C&SjoUr!]agpD7,CnY>jTd=cXh-kICL;a'5lm>$'X~>
+endstream
+endobj
+192 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 191 0 R
+>>
+endobj
+193 0 obj
+<< /Length 1068 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"?#Q2d'Re<2i%]Yq`AX?P2MnkAldU&_Ji6WP*aE.['7gS5des!qI+]'o1l;ueNR'c^?I$7XNBatf`sT0RZ5#ToBM(+4MT1*AYn57rdkQAi)N):1ISHHURU.GX(&nY/)%+mG"pSfC&FfqQ7_lmF7P&7K6ZnU3Bh at nH77@F<10l#5$1!V+Cg.h)6ECdhfUtONC`R#o+L&8.q'udBXFj%mp=$o?0VMW:k52M2D]QhXUp2Eg%0:.:d0(C:e./_(e;)[Na\-)X<L2`q6VgNgBFj&D57-sHP&0C9C^n8^L1AbQ2ikC_R[-t$/IONBe61VVA^C at l*>bUdX(uVr"EY;MM&hq>GlVdo^:%,lZVa_U=\e!*'ar^\*u^C%*MI4E0_`_=1fbLQSqs*6ejU9FDcUrsWj#iES4:C//EIMOC%X:0R3&uM)@<@h`a!4V?Y4+]?5hL7`UnRhn%k?j((,"]L:WBG2!d9i4'Dc4]IDkl4Zchhrf?[i32>Rn:Q'ED,-,CdMM'HY;0."TfO7,X3d"ui)d.(lWG=sM8X0fu,cD`dMePLNdEr?qA)&#KKd95*OHQW'nC0)6B$1F6=BtCR:bT>9;J1='3kg33U$R4fXIC%)-u')t6gY^.epsH<A=G]>i,GI:Q&8]r9Y9&(;&!O.=KQGi\I3J)]O'CXGeND2_fe'-pQ<KJeBTOqc[4.]/5KCtWSs5UOU_D.+a*Ngf&-aJjd0UU=JQhi at O3Y&k9so`0#[n8>o:&3dS;DmmYLApP?_Y"P9`i4,,qg%,b\),h*(nFp(3,EIC9m1NlYX04kMk%UlaGpdIJNZTWTD(&.iV(J;q1l+DDd;pUZs8Xgp#olfWp#=hSt@^A at cpiQ:h+4hhRLptE^K8i#kJR<N!_ea^_S,9lkof/:@7c.nZWZNN>U)M=JobWK4[hLY$I+d;D at 2*o]'?"LDF9^+WpR/jMJgb.B>L\>WgYP[q(m%T)Rq\!4jFd\9Efbr0%0H`rJGoi=,<i;3Ec_(-;YH&D?`NM2m!MOI(j\uO6h^:A^E$K-k4M#G^--QjJG5RgpD[OUiXY'L$K9Da0~>
+endstream
+endobj
+194 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 193 0 R
+>>
+endobj
+195 0 obj
+<< /Length 173 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas3+0aki`$jGQP^ETE_`oMHtCY+.J%YBd:grtUB><VoaGZq))8<ud&j6IE1gOR/ZW!O:o+NWXI`P%k**D&Zdn[R54K@(<-W&rW[go's)o:?$[GNP'o@=eT'3ccp^e<XArF(`[^<k%T[4=pMECJWJf[:1RjW6'Ncf6jDBC?7*W~>
+endstream
+endobj
+196 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 195 0 R
+>>
+endobj
+197 0 obj
+<< /Length 1092 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%">AqtE'RoMSLu>+nLl$&\+G$nV:'-8DBS at 8FK9nW):n%S8L%X?`>N-o$)l@;6O6>PEqp'D5ZX1;X`?'s<MS4/@#e\spH at c!e(Ej?7 at 7!7";K%!QIOss?JR<[e^%H$;76ML/"&c*uJ4OO10`hrA7Y;NM;/eaJA4$=#[,L#eo+=tmQQ(T%-a!%"g2/[-XDnkob:OMmPCH$D\",n.1P[Y2!0a*Hn!"b-K"te#ifQu9k/G.)]Uj5GM\'t7U2sIp+G^,HrtguYZ;^"Q at os'U9aF+]EdoPWp2hI$(i(o.!\d"YMd`f>_=Lns1qo`4pr1_E;U-^/lb*6?;\TFAMIn*0PQI:A7f-BUNX&lI3os3A&djK>HEeL3hqA"-TQ<:6PBVlq+<d<bAcg?m$mV<ChE:M*0NES2<DK/cE8(!2eJ1mOm$&<us1LEE\%IFJ.)Z*HG>5f"'M"#.]"SI$F7gY!!Kb=``fIc-7:%is=j1me+V4d4fZ\L*NTE(cg=o6$E,/C>]"cXs]MQl0mQ@#pg<kIHi-B.5#Xj=Uh3o\o.%rcQdHEZ17cbPKboDX&hoQH-)1+b\No6V:-(nR2R,C-D/baNr9qm6t^tnaJg<36O?t)e(`"(>3f4Pc0UTNK/!2pnWS)p5#NWM-0bNcg3QGjpu)S[a"X;"p:afcXlR_^%k`EmDae2IjI.jqTT1^Q3aPpgiqI#oa__B],GF9g-OVp7)X/Dp!4rC>anNLqZGN'Wm*0^]?]K(CV7Q@@Vkdik0=b24&`kD]7`ZXL1?7'Z)d9?6f&Q4LKHQ"?iIB"Al%U*d,c5^-eUkL"o9QJpRQGHL9%+`XPHT!Jf)d at uu[KeWdfTGFpaf6kR2"4R!iF(B$85'/2?LI&t2'ed!"Sf#HIHHTeu(/C#+_?md<(cB*rU!.];9JA!pePp4Q#U]h]HnCG!kf1*dgJ=/\$VRdh6Zf!=T.3k+2go'+A&_+Go+H'&aU*j=F9]>WgmSVE7pR'TFs\*gK0P318.t*]m>?b0<`)W,#A5Be*OdV:<pR_Co?u0t,PBd[LgE`IH%LCrip5T94[(9l+J(^IV-Hc%3I`?)>Hjj?RJ[:CUT.`~>
+endstream
+endobj
+198 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 197 0 R
+>>
+endobj
+199 0 obj
+<< /Length 1023 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=*gQ%aW&:Ml+=Sn>JMX*?#WKhYWXOKjJWS4^49cmJHZ;_-,6e^A2YAGlr6:+nM8;uU!S2iAh_sMd?qMkXD6P=olZ9Vg,^]<U(".qg]7*&dZ3*79<\)i$[OOrDP=F\h,*+5R$BW'D^'=/e_!e#rA&"/\Q-,'(&;I5elE[TBpn-CrlQQ&8=B<COOdOeEo;<=n#]l'[0M>h(kgidYR'0)4qaS[3Q2[7BX'I`]a3:\M=K=lt$m=C5%hKk_8m*>@O;<24(T]Z#F;69?6V,rR`*@QOAMq[:O-**d'$`W1%L-YrO5qZ-23<5gQ,1+F<q;Vu'=-j2*AF/p]SYeoMQCcbd3TlLi!a+V)[6#F?<a!"^>o8Ti@=1/@^IJ*qBq+_)e>..P+;8iPQ\f#a at dLEnX/CCcoK(F))T@=Uaes?S>_98CELOP9g$WcSNq9AhHYeoj_ at E`FgS:8nj)f at A:X<$n#mN*plLWlU10/*dV0Ou"!K:HC#]"[S\_'&UD-<B77;4*XDWUD"8dEB&?-i]YBfO$iY6b77,G5"fKX4on$@NmPPW_Nl at c-M:M(<J#VHQP^/'j^H?<6L.D=j$VI65`\?W'm1Q$Z**A at fssZ;NQ*c).Q*C3+6`EJ%*jOp^#QW!c\*I##`]D8/r.+_TWNkqUQDZA%ojVp-<3n?tkd\E\%E2BqA%,tc<4_lfoK;l:;1q4q2^#sT0.:s;t%kY[0Uh0V]%EhH=2,ge$_fpb?N6,TACq>3:<o:86*"X7WWac29)LD";Rc!4L_$Kh@]>T>Li(hl&iQ<"s!r?1`"=reio5+ameWFOGW9d-i[h3o#_&;0)L0ZqjJ>)Sr6RbM:@79%H/]3`g@`qXC^VZ at r9Y;t11B4;/,bMD!09@?(Rkj*4Gn<)%N.J9`*<\"]?Ff5PZ1LHYLlAi7\FpY[&WK\DQD9g6 at 1@dqRZF@)(%cgH!qs'I.dpHB:1N"I[X7bIbrAA;!qduu5B&A`";\C at 6c\pQNGb^iiFE4#N0YqAL$.q-d75!XCPfn_s~>
+endstream
+endobj
+200 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 199 0 R
+>>
+endobj
+201 0 obj
+<< /Length 698 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!bAu&c']%q&ZtpPhkj%O=bd7os9^)sa_Zj5QNnbHa44qj*r&sTqYoP38Qu"&0*Z^em+27J^Da&2n)OM[s1o',CL4m,['$Yq>j[h-u&q<9_h`M)^HV8f#s-#fAK%'r`ciJZu4A^c`k#`id_/DD2G3egKS&S$.ZWf1tZ4+A at _3f+amkYms[bV0Y*cJj3KO^*lU;sGJ%jOk[aocegBjLp4R(f at e,8f.-4pPM^*[)QiqR1AE$<7O\g*]>Y3[+i(77.rc at Mb#>i(/XgN&einqlLlIj>]E;IHTBeZuUY#A<RY&PTW+pKC?+4h8Ud1?=m#Ln0A at -`+7QUIgaghRu]"t%@<$);#H981IW\1.H7K^UDeO4V,:n(r6'g`-SfPjIogX"lMS'TgbGbfbXOM6i<iR!gGa9r^*ouhn5j,q`%iXEO-jSeoF/eSa?X"^Z!JX"<MB'#j8B?5P/dtQ5[^ngKG&g`eDVKc*bOrNLsomT1^S^uRAb]0`6#2%3U!gVhS3I@?R&3\4ijS:6+b at M2N4E`0)P'D at 1@8(kV[E/?J8`c/Y^>:Hp6d.pF&RR)#@re"Yj)k3j/=_U9X[RJ)3uM$4832J'fGB,F[#mGR\Li#f4)Br=g'[TKJiIcAW!slJWBlrp3GZFfaSE3W+]3f$5e/=VAunbjPGY5Zau`Cts"C]@qJ2Y!=hF**^R8+dfQm~>
+endstream
+endobj
+202 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 201 0 R
+>>
+endobj
+203 0 obj
+<< /Length 666 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!bAQ&g&A7<ZGYAV$nkJAq!X\-5MDRR1[?n<,g85i*ZD:*5Oo0X,LTQn[V9hY9E&bJI)<j?UhL/jh.%gTu at Lo6)7hBhS6&G_51)(9jJYG=(EV$.'jqdn^d:\4ILg[^.JW9^sl[fNn-q7B.H:SZ5cYQdQ_U!._:IVt[jsR"*?U^inb'p>ef+-LNiiG+^&C*>0;?@?K/NeK/Gdu0Y%4R)>jKD;g##6:`Bi7AB^`DQqhA"WL16?T/-fZ>+C`uTXBr,1>N'i2O##cY-SencO&j.70c+nUI<P4Dh!Ui64jX"f/\#!Gq09.H6E.Y+`J at f97fUK7]?)8YXKY%Ue\"iWj>4;%90Wj8b;W*__LH4D6[[//qDWE!OGA1F*f"]J,RecC8JOpfJoV\9knYtT^EV$O$%pEUK at e>1":@o#37HBU6&OB([d?L-;k*=3>`Un.F!)l(N3%rM,DKIaLX`CDIl)l\lph^nUK<.9&EH!SC91`N3gttFTRBp?VJP;e`;*Vo_Og*#sh3sJ`<cRJD]3H&6Kc!3sr:jjf)i0nm9t?D$TeU&\Y@!W13<m@^J'elV(%4=TX-\f[gnKuEoolKf\um\^:4j)l<q@)-OnYdP9/QNF*HoAjGGc0*%#Va%hL.6:kkrZMmcuNqeBsGp4'"gtb't/&IU3~>
+endstream
+endobj
+204 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 203 0 R
+>>
+endobj
+205 0 obj
+<< /Length 432 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$tbAMqd&A7TLHV>-Y[10S'R.PBsU.CR5WU575P9M;""`rnbQ\5nP8VnoLZe!FIGh+DikO-Fo.ZjlGV%/'96\3`/"j)jV#WW*@6aVKTaXZ/H.==DQ>dHCd;E*+$Q9a-^5QhLl7iTHA=50jHPbuOo`nfgG2QE-=_.EPk4*bI4g1kM6P3^Q7g779A$TTP#'RdOBlZ,!pOG*aMT5h/KKhic[4@]<m:J!8`V_Rp5]:DXmH$VX].N6lj.[)(2Rk31#A#0n<J2P:@81^!Z-s==b7P9o5A-9tF0^VI(Q'Io"`S))CAT:_M:KsZ@@1/i&dhBi$MrW+LTp\68WmKS4l^t6%[*hO0mocA)$."qN\bK6NSBqX9qg';.kI^PfN]WJq,7"7)8W=&\WUo+#U1'hddC\,aML)ZYJU21IC_T%Y9)\mq<SSG~>
+endstream
+endobj
+206 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 205 0 R
+>>
+endobj
+207 0 obj
+<< /Length 1572 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat=,=`<%a&:W67+S*n%&)*1>E_/<*!P+L((U947640LQ"%B=C-9Mt`ER\?f]uX=tZJ*/K1TR)4RtJ&]=\jLXZOP)FfJhCYM.o(J/Al"JQJl7_)C09a:L%D#)LkJJ at 7m_^^Q%pT9Zf4DP?hQ_NIZ`Y!V%o8CeIC5`7893Kk3,'k&FGLil[WsQX?5"0_U%oZNuU<YT]+_I!5WEhZFn\3slrd26(%lRJR(kQ&eOKoL6B53`=Hsm[]9kZ]K+*a</9taBK5ci\%mPK8;sla<.=]$GWu(_9e,oba95M"J5pdQkJ=kX3*1&\o?U"F`$/T(MD(#9Vf3rF0%3h*/MiSn36oPo$lXD7cKj=lTbCNdU0nfVAI'i>o1&&-cP8fF.La\&k1l,-u^bn,rFA!plA["q&1k at PqL(t+nca*B?MBd\1]jt&h6]A2G^]#4iG`6YMM\EED-!$Y at S9_EifhY>Lc]bQu>4:W'^M.<mq,27CFk'W!ggVBs][u[Ef4!5A1#6<JNFsCRNf67:/+ho2g=$g;_-+#A*/"Sgd\XI0_muC;T7)iWe>-.X+ql2K+N<>.</^pg6123REAL\N at ls3%31nQ?-/N>HTX8^85C?`5a at QZ\r/o3s^q)*@\Mn7\dPhU/cVn4C`]D\pXX_)<I$.^UddT(QWO^b\tVF,*TD#)bGfMC>fY6R`%j:rUbPi1r&IF\+e)'B$:"f!`%cRpJj->ciM\,,K[EC+2AH%fPHd44 at qlIigS(AG#oKcf%S=$O&S at o1=7(u8l7Fc(BM/9f[8ppa=NtF8*uV>HCcDS\]B8K#=mO[!_.ahE9u?9F_+fn3"?]ChCVju(2J*N at G`\5oPb.B]Ec$7[cU$coWcKP`]Lb!E25`r>UmMGA$RNmZO5>W]-d*PkdhI\TM^dO*TbtP3f?tKe=eGi0`VI[!,`U6Mn9k6K^JU[f*0Olb5CdLY#6lImk^V:qVXUbdauZ70Q23>]`GiAXPgsoWl$)BBu8hA:&:61OiGCDhoYD5=Z*SVC<`s%S2RddO^8l12YN5F"jI/Wdpo+h![GmSE!EZI(H;6[7]ot\gG*IkDS'kQnNYaiFNpZm?^A8Xg-/U(Z\g],g:(udk&.R.7MMDf6Qk at BeJph/WKVp7Fcjdc0iW+o:n<#>h;=7ikHWR[Bu<\Z-d3$8JM]#TqUn'YJ`Sk-Y4u at 2]1]YWiZd at aW!AdUWmWra-?L[%nW+o,e`#O#j?h*[2+O,FQB-N'?aLMqcLR;3YZ_IG^',<0/9QKDK5U-dnZ[=el<,[YrHDK\O:hLC%DP`G'Ga-9+YBS&U?emkFWdPTZZ_rjHH**^OC`SCq:rTUTAAhQd#@94-H6in`<9TtR9a.<.4o\MZ-M^gG-W2.+7#Sn_14I$[Ks0ec/=PYN2<,Jl6F1\M^J`f$$%a+#qpT9pV[#N1VN3^)'[N&XK;<]n)@HT8AOLn4TK!fTP^;OMuB5AR.B6[AN>E$P^5eOo8HusLR&Z/o[IAn0'psQ>A8GqBK+iupP*8rlcBt=^BAQ$it"#U4*'%c<'cNBjMU%jh7lK#A<5S_bhDFJ_&a^%2-+Q!9R[4a!:-]~>
+endstream
+endobj
+208 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 207 0 R
+>>
+endobj
+209 0 obj
+<< /Length 241 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas3,\IQJ1$jPWQ:Z8Pe20"X;XHgrDJ:u!u(ojT$-"mYh_;c1Wa+BD>?Tp[:?Atd#Lf$2%)^/W?#\5If<[`Nq7 at .0H#?W:kXfD9FFD\Q16)p;l@`^m at Cr3#roZnaaK:bT]!m,[.aYu`TdE%hEehhXCY-%5:;L!1$hEUbe(pm\B=iPQ`@3ZO3pE*0cTeg]9+n=JrS$5Pdnf6)lCYDUWIbU8VrKl)uill"J?EgkFkmiNE7?d~>
+endstream
+endobj
+210 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 209 0 R
+>>
+endobj
+211 0 obj
+<< /Length 1395 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%#9on$e&A at sB#j at sg@*OQC77eqKfJG&(+t\o-kbTm5=f0b<D93COc+6 at CHh\lr,tmP>^<DQ3L,4n.iTSO4n_K7'J.k?!?sPD%i,O=#;#P?p&/5="Mc%XV@!rI_>lL06q-EJkYl7e!iW+aKJHBro9XKAI"=4YgL`J-MA_h=q=KS1cjt9bu=>*iq#Y@:.b=b]P$&0EfGr]d."6de<BPL at J:X4lMb at rVEF-1AO*%[fcfnB]dU>A25a]t\L7VV'ArPaNQ+<I at H3[9M!Aest7V/#Vb*g9lJPF?>TJhSE*KK:dsYL"P'@ru8lE5b.:h<!^3a*Mqnn=(<6EK&m.Z2Pf5a7GEpXl2B6:_mQ at BWlR]rK$kqeqZ=/WoZ#`"Aos1U!D7. at q3H0hDE1WX.!`A;*BM;2]s2qCqZ)]?AMJnQbiNAcb1WQ!F":ni3s=-3`H7I:F4*!gIc^PHlVIc^NnZGS]dGBqQ_t8NMsZ1W9L>>7%$md#F6ql^)->CR]@$ufq>HP1d#^P%Lh)"aDI,BnrU>@7r/$7Zh`f:W<`I)5][Z]mBrmn-f,9&qJOTV'5po?0)^lE#Z50i';?'h;+Y(cd>B<2NbFAB:PR?:nT<^#_Gt&f,n^&b::XTZHEmZ6#>nRY4fJ&kSPk>7qArgh]]lW'n4kobHl:S\-50)"1]o)->2OJ#lmfk0<I7cLqsM.I,Zi%JrFq2IaoAKRbI4UIM%.$_Ks8qkY!Q7ug"Ma9UT4e7%kkR.Y(8X9/n`%mV&52Q`s,3NfY6[o/*tusN@,Un5c=K:i+u[A7d6I(IH)6 at eIH'CjNV7W2hUhQ0SVli(e_cCfXZ4](ds)Um=+)fcD%Qq`7jQh\$A3SeTAc"$n1pV2h+I at jc,TVateY1e:QOt=Z#-6Dt2'Y-INDPTcL?V9d92aLLGB=61(`*ZZTc8BDT7W`I;JMnnMjjntCMuL+Ua"NkG'QO([2u+*fqO<fR#JhO:55?11:q5O"M]BJNRO:PDj`SlL`TS9_Uqq^_sFoc/^(T6-<j"D8M at mQ&ln>P]b*kVYmO5)\2Ep-UdCU^W<]^PT3HdWgpc-tEf at WYQq\D>k%oY<e,]+"(kF`>OO]K*J/a492?RIP*bGs,MM(WdR^odaP1'T!(&[J1*dD35D[\gEUd,b=nQS6V3X7(Kb"pog]t`$r.Jg,m]FB6$1GVCp+'mG9S at -*hS7=nn!,cS:r at 8;oGV"5hR^5?$MKA4cRoCrJ%fEVAc!#9E9o!ZOfZS\L=^tFK-;6e_P<@s6:5Pl4YCb/iLmo=c-;WX'n]+b.kD[A?0=APk8:R!V]3kfQZ3r-D`,#4m(a4CkZ`oHJlF.ifj>p1m^DR?PNT!Ei>dg#Nas_ilue^OAQ]dY+'1h;2Fo'Vqqn"<5`2AYDnorq#~>
+endstream
+endobj
+212 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 211 0 R
+>>
+endobj
+213 0 obj
+<< /Length 571 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$u9i'Ou&A at 7.=IaPsG-F./LfZ&=8B[]^8enn%W`l_%2A.8HP,doQYFT2_6uc at +0(sPP]f0</cB=))6Pou!17(hC:Dff)@tZ$"7V+QTP%9X7gZ!+u3`iD,eu`1]k"S^<9<qGP"T-4q=&in._;F[H9CeWaT1;SS!bTTkQilL+8Vl<#&K(4:le476>o)ONKO5O,'+\%J>RuCHeZO>)@oT at GcIf$E&7d':Wj]m\>lEC-PAK]sIpZc6m]YdSGcL4<]SN6)]6Tm<p;]g)[s at S6hHO'pFeZb%%d&sYG^*1e!+W^./u>LUBa!q!;P,R3A;jti/O8;=^S8qXUhhb$,s^]TMhn_7k*olTU;PTXU',61O*YeuKPB at YfS;hm%["W(J;7F?/TtR(\CR7:$*r2CBCk9ILa%mQ2:X._oX,W1r1tkpS0f#C7&W<1WoL at r$2OOle%ApNb4nJOd:eV`keQ>)DP+egD]^=U[meb`KDfoWkQ_,Gc6[;4jLP<bFFMrQ;L61<9`:s!`$JcSlg0GJI1^lnZq,`WqIV5k6hV1IDZV.ph;j,(?r;tUrrCJ6/_0~>
+endstream
+endobj
+214 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 213 0 R
+>>
+endobj
+215 0 obj
+<< /Length 2102 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GauHM997gc&AIV:0_SBl=>P7f2Q%nc!\&^*D;A.H"4sDO6=eK?-p-k#mnfguTe%_K9<l9ao.B.IiQP-q@=@n<.9lufag,ljhVWU:QTK]U_2l>:ZBY-H^IU, at jB9,t*u9>YJ!Zn2?^`p3^D?.-mFF*<8X_2n+="Vhl`FMh9Un^u2LF=E,n&TTSl4&/q1/S[0-Eh#C9BdmSj!T'nMNh$&2-daSq;P[Wt:MnMrh[T\$G'PJg<kP1F=_ELA(09TK0d8*$cDYUYODtEQ1rmPUhL=Q62,dQHp;PH5dmSa-fJPECN8+iX":R`Yf`4/19]g0c-s91Q!@e:-BR#Gg?OD?g8Lt;4*QoO'FU'(U9PMMc%]t5_3Sf2J8LSQT4`A$=6f#flZa,0jPQc/5Zg;QU`OhJOq1"VR&^p]3+aE?LS&kqE,u<qc)<m_[jshjl'=H"03^gEmn^+bMbDc-FBu=Eft,rR_aBmBhLUuEcbAW&E-Lt&J7tX9IM5P-:sfl)2K`/$[aRrUPi5q/QU#K<I<_W?YYqifBSA2Q/KfYEFJ-qgI[\%4>f4$'QJ:q(#Mp2FtS_?Bu(J;8hR8)N[)Bf73"`WajH)"+Q9aYhc,D`=D_0C]20GUcb[,tG1&XHK4[hn]4Ts!asmdtqUMe(`fYg)SjBqE2sY*9&PG!_bPFLL+p=+35UK=>4OL0?A>XmGE2Z)8QuHl-m=&D+mb!!=?RHDPGb)Xpo)8fqApq8"fQO*bc'r^S_b:@IT\LiGnBJ89h'Fo5O!Y4'2n/R13%N>E5AFhR(p>2YSop:\\s$n-i)bgV3a at X:fZ12^11<l'$%jgXV!``uN+jgn7?TrK.<qu[MZlmUPSEu<K8$nL2="U5IC;PS7r'A[`u.dSCJ_5+>M7*pC!33[q">Q5"l"K3RCZq=_/2j#MQ%AWH6i.<KK5C)=P7/6K=S"U_Ob",f92n"8PVA\7BY]'Y at 270.oko51i0@Ud-=SEKi2]l+6bV5hgV1E?-e=YQpd%m]U".-o"dZ$-lKg,A-;$*g(W#)?LT%L,RpTpcs?J2/K"n\`Qgo_/M(&O'2j3c#;.X]&6!)\oM+jr)hN4[2Tk+m,3kYl^3AfLDdB#J\pR^MpMERt(:`R9k6u">X0M##,\AHX#jWt5$h9>ue0Xcj5((E$6eb-JJN7FF0'ZtWAWs#(k*\@AVr6kkIpMHdebGcK(r[D>(]1Achc79sP&]9o?J2g),UHUaqS#u!7]Pl4DI,JTUF)s#ht(`/Yg)_jC.<'r5R?"[V/GTu;sQOS,</q4jsl+%I4T.ofaUsC%A>-Rfj$K&\>M.*LY#FEWtV3e@,GkTiPFQi]@dJ_h)#6Aqh1aFniXg`ODc0<=4-Gr\M#3YPB3dE>6s5!.Yt&bclgNiofT/eXD'0kYJ?^(a%6`iE#i[o9a^RCN`B$*4Vu>adXRYB7ggH_Y&jg3eI=1iS-6r-^Ut:'SaT<pFL+/e@;bC,q#,Q_WP8YM at N)d26lZ at pPrQS/0&%:*[:j5b+m>:AS%)bm"_6$T7QETu-gVkb9<T2G1^s#8rqu9kjNjOS9J#\.`(=:0X[`j[mpXX/nGNOI[*rX)m%%Z#AufOt9ZLNK<o#H3LM*9_$K6+ULOlYr"plYj=*&sO)(,1g4W!C at 29:INPf8+,AMMF(\]nS1"J1Kjl.-#Pn:6f>9JcFHT(79=P!doK6I5:c`1tXX)Nk8hQEh0YVRnYQ5?-kF*/Od<$iSB$JFge2&Gl*0J:b6Fg/&u90<Ac[]-R[F5<qm\f0:o1-C]RYTE<tuOm&6P!-:^qmc4R?T8jJo;,`3W/iX7TL9A'[+1[L*\JfJP990'5 at M>hPZl*kO`'qc2 at GUgV58>>0I6Jf[4sA:u9LCAd\`nj,F;->#D)E@/344=0)7'[;q'p$'6B7)g/sEd%T:#O!-"6MiM+KD$/9&Y+*k]lXHp8osJ7^++I>9$sR^;I22%TIg8s3^s_K"b@>@U^sDO-GJ\i'!LSm][og)H?S0Eu-4jIs(GUM<$]ZmP8<#XWgq'iM'gc'D63Xk9e at C67lhVOuF`J*VRdFC(e`%/2jKefLmq>O:g-^&,#TDbM>f:@=VL/FE7$I2O8,Wa-#hX8ZIr'DGQ~>
+endstream
+endobj
+216 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 215 0 R
+>>
+endobj
+217 0 obj
+<< /Length 343 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarWu9i&YL(^KOlT7Z*<!qOc+n[Lst?AqHoeq8-B0j?^O\$%HlA(A$H!Y=8a#G,c9DBBRg";=lT5[XsJ,[jM?3=A8I(mYk:#PbU(2eVG@;"O(FmFhsm6/oFODpZo)LSLJVj1<Mkp^4(B#q\Qt'oLtU8EaCWS%i(d6H"B2l*oL*G'^0cbW8t*W%t67$nIT at k$m5=[.D?A".A"[gNI90Yi-YN?RCRP6#oYE9)(-\hAN6aea)*WFlO:p\g9=JEjXu.pD*HAHc)R&o,JQ#+6FimS;%51K5KsdEU@>s=Xc$4^Ff$idn at JTGl,VJo=?SqbZFU.E^IZMBOuY_\=04#'ePKc~>
+endstream
+endobj
+218 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 217 0 R
+>>
+endobj
+219 0 obj
+<< /Length 726 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%!995Pr&AI`dI,$m'p"OG!V;4$m<,JIH;(lbsPaDS&J^g'1pYXS1#T,mA'e/^4k*p;G4N>4<pCq!A8I4<,5[Y[AJF!dK8K\'Yi\2&d`$b'AmW3DHpYZ:45?JU)(g-qKl2d8/$5!n!.<^NS/:K*d2OQ0nS$Xq30D>-J6[3*dpRMjU88k&92/&033Q%<VWnk_.3Y.AU_+W!m.;"EFLq8s<-)iLMOAU#q_GCF?((Tp-;OHP at Jr/VH at 7u4Y`.Hbo:$2PP"W'9FOJ:UN"LZ1kD+b`35d0'ep(JC7Q*kZk'>I0ti']h`V8GFZI=5"Il^sCqigAEM'K]+iRN-*Ch9<4m#d\f2+haK1Q-jC-nN[VkiITIr*E1Ga*]-Pn6lM+r0=OGeWCG+W$(%?,s%ZRncHdgjMq't"(u(oB#9<+873"(9ljU7B58(R.8"*(3, at .o@^6?P++V[;[R30Uu2i+8N)"_P&6U&V(.\Fl+pmNroWpj#2V09T8cXCR0en(k]C0laLneG>.ol40r1:p]]XOJ`W(Y;.bTcsH;/lL<rb6^6UArsAT[4Z?'^\)<9[doeTh,VUAb$2SsQDrA5X.r0(<n&5iZ;CQdCtGLJ">,Q&p\s@!.P$?"aG'C2<au)ckjJ0<3E>H],tF$m.5uCtkgpIq/:s81GmN.apuO]"Xe"MmEkpBfZ7i=F(46E0j/J_[OC#?\Gq$VT+Vg)]X:,Q&If[4S]g_~>
+endstream
+endobj
+220 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 219 0 R
+>>
+endobj
+221 0 obj
+<< /Length 733 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gatm9bDt%*']%q&]UY+_n_;=jU_tQg"G9/WYlPW.e7g/h;3DWjIub8Tc)YPD6J^;^4nmaP\Ms86p\Fsq=@/`I&:4\!4UdGJ at 3>kE5kl<K_*O06D`828VJj9]&:?;_%PTXB#'9oSdQ at e(TVU3aU*BW6bBd/)X/N&A,i at I1(#b/.c$)KbGC*sSX6q;#Nh;JLhqc;4lJa#/&]/V-E\:gXTgCBkcXBcgB1T3__m3)C"VqmEFNj(?jc&`-1dX&:6m*7U^+^%Xd>S1q'1e7,0ETL]EmkK;*9PLMB0W[V.2b2`fZ<Sf"ZR)*@;/#Ojn=f#gicIck]=sA0CmBGr\[@[]"4>CgCIoe</P#+o7H8]E!D]AlcOe=.Tk7k"XagDYqk"^W:+dOXLT6(UCo2EFno?F;46e:UrX?bLgb,2`[pWZ9ua88#Z6]3+miA;do_Gp',9d=K:T_Gku1.'^J[rZ9p:=1C0)D'9um.4]5q4lh>?M^;X^d,`/#9b4S7KTR#L5c0]o\JFBK_c0o2gtek!*oK6^V?Z&\*a;(YaTLlgB=?h0d.MQBm;,ho6.RF8=e at .gNIP?lU8=+&(6X4"=rd^4hI>5*t2SJC8V0/B=;SsDd6NZRVAkMpT/k*ZUdCEJF=0=)9[+VAUeY?rL0Na8"^W1T7L?q[aA!YG]I,,ZTc"7N/dBXW)IF3'?"R^3;=PT%KsUN[f=%>@[&7D#nQ&T3o9JBY8Rgen%O<t3&n~>
+endstream
+endobj
+222 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 221 0 R
+>>
+endobj
+223 0 obj
+<< /Length 666 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat$ua_oie&A at B[G]\J)j\G'-T['7pJg*N7D%DLt\LOtr,$i-:?W*%U/QUZD(C`Ngn'0&q5/b:l7gcJR,Qr*&+E.T?5k]ta,S0tgE>T#miY$XnHqI"R#C_3u]gZpkO\N'Q$NLia+ at 6,U`>p.<PhN"g1jO5R"'`WJ`o]?+dRT?Va%)sUlfRQoP?*#P4cfU,YD%TQ\Y_o,(nt?aa!>Ne!AZ-Q=uKqg@*q93cBUt-##)D"&Y[)b!jNm"$La)o/YIcR3HU9be&XP)4H^`K^,_]U<>k3#,:/:.Amgg%qap]C.8ELMVPi_s-Nl1jYNr_SpeK-PFT9LRed>k0LR<kQ"n.[NS,?sj]"2T9-7k[k%d<9?\j2C.`3nOiK>Cf at I&sa$T8V)g;A=8BR+??WOn7AnkXfG\@:Ui2XfF[d0j at R0/?g[Vg'q9A!'U;Db(&a2/`7qtb@@7$cu"j9Ro'XoF%S[_)TSF'f7%,B:>5Kar#BS:LKkpL1uIWSBN8UC0PEeH`)49Tq-Hch]#ujo)LZtt#XKM<Su0(s[u%)[m;_I=Q:=RbA2NU0>&%il9`,^/h2IHg&('_j<NWBe at RC$XRo at aqntlO&78P2=Pd$'uhq]7.k"5;6fP\<>gFLW!O9K!CLNoC=(o17)#*U7t2I&MuZSLMhrrOUFE5M~>
+endstream
+endobj
+224 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 223 0 R
+>>
+endobj
+225 0 obj
+<< /Length 1061 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%"995Pr&AI=/TU`;cj5Ll9]k,`re>cfRh5H[;#D\ZL/WUUimRC4VHOY_^&-uK[Ym5d=q. at X=ICGf]s+i8j!p!MME+W>O)745U6-D^4[N(n at c_8oNZ$n;H=Mf!X?e5([6r=?GEe+A$!/N+Wj!!>iW":VE3%T\KjAEM'Z'L2H.i'(W>Wo]WdTrQE9Fk)$&teeQa>jo]B,HkCE/r$\Mog[gZ^[>rZ67K=&;, at s3$uFlNe0Bb;Sc\c)#nUqa/^mP!mj5#e/K[?8"e@%!8 at s)Zd:.Bm$arCDf2rDcSjOKr_E$WKZ\>Fb4-t=QO-GVSSm$_5(uC:4Pb/B5?M1]ibH\[<[gGPZ*A?*B0+B\.NT81d^:W$aYo':g9[U(1ZH2'$?,jeoQ\P4=p at Za+[4Cq]obqm at rV5V'h<mZ5LooMHM.ujnSmh=B5%s%45T&?XrN+7R]`b[Xu^6bUkr3C<D`1.QA#OB"4-dICH%i9D-!N'mD`>"?jr.cW<b`X,06OSLpD,#We`K!LFD)j%/!irH4d=D<L at EUnN0C9H!]!O%OI81>6no[WYAUQ6kllX<6-cV]]eI*<3qC=X))sB0R\g-U_fuo&n-&7Ggog<mpB4<N"(IYd*oQiR+QrAZk^P#&!p^m#-,,6%W3'R4Vp5/SnhQ7<2N8 at lTNOBE@&%1gHb%5lZZ9a%G0guTN0`$]St/+)Z4Ht7 at C%o[FQDqGf<=Ynf<oqBb419RfoAYBcrQgY=L,SCbmpJ?:Rn,-o9XNT2D2VQ2GFX1Wq#ONVPYQb&TXoq".!NU<j_r5'@f&[S/L;(OqDO0cuG2K)k-S":#u1/]Hsfe3VM(\c at MUanm**B4nnZLRH1Uo3cSFWOt8':o$I[c`:/KVg-:0gN4If9;@i4IMtF"#SPf0c*JYKn]oC,+,2lh`MB_(fbPWD]KB^RT0At>0MA^r'5:J8_n46HmFAg8m7XH?\Grt?jD0+@<JH%Ud`pdserPqA=_45&m`V at o]ZUTKf<aB"H!;qC.0\3FoiR*&Q#eIGI at K&pq[6t=nDLm$>AV4B=lTM1n0V7Uq%#V.X4R~>
+endstream
+endobj
+226 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 225 0 R
+>>
+endobj
+227 0 obj
+<< /Length 1000 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%">AqtE'RoMSa:m8QC2>9&P6[2X0r1Kt#o;G"GjnV/NC]W!\?PsZS0k3gCRS"HWDEG_lZ\B8AN"o,+Uenc3!lm"#(u"G"]54q5V[ci8RmjD369[eO0^pVk3'Ra+T&*7EIa^rTKrY[iDr2V$ttGX6sbed>cN&mlh.oh,qkTohC)Naj`rQ#E=4c'M(plcWt*Pp#r@'X'h7-I.YXl5,&bZed>*:$0Q\i_MEh7??p:i#epE4<2)f#R":-1ljF/TnHeMuXk at R95@NYl2i"L.^.me2C;k.;._Ht]tKG1kRrmbr$25c=iV-9:nfMpC+EOd\*;g^<LS9.!H-'+eWkhC=[IIE1kNkX-$nY-moAW-qGLj#-n\_O9sk_MMR87N at u$B'UZrl1rIDiWso=4g(,.7qCoGoC6R%^D).Qm=%=_4-a&K>sT+;dS+DCo&(l*ekB%1eeXaW0XM;gp?Q;-3-]K-]a7gh/c at pi(BV%[GV5C<6>rAc%K.GLZ5P@:D/4*8cGgD#ZXpNYScI^:1=3[X7#EAmHp#cKa<7^KB+O0=g!+p)HbR`PFU_b^,Ug#@;<002s_r:Cj=.]&1'[n+6pGs9Xqs6 at S9enYO$"5,g8DT`AYTJD0rjg[ZmP4%oZ2C6<o;P,On26!>m+8i;8CYnL1s,Y<C:UF3G3Qa?$VqF&.1t36XRV(ahGSFlnG#;9D?KV&o_a%QaG5l%]<0+>9L^a#HU#FAe:]2Ge`-*e.kD7X[fNLhY;:J'XThQB/&I`T4TB7T@,c;$[$9eOGG6X2?*qX:"13p*CX_YSJ!dI8uGeVIDVV%'kfgX.(&$\Zie2kan&D?[Hi\_K>Du9`$]B>]AjD]IjP_X(F,632HVl at D/]FT/MX"$AKpRB8*rNnABG'C..]-,VQH\;Lh?RLg<7,I)c^t3Mu7<[:-1b3cL>KNl(G!$eO(u:U^Psma3uuZ0n@[^Lh.%Gu2^KcRq$R,)JR0nD:l&gW:/J"@TrR-o*.L",2c>7K~>
+endstream
+endobj
+228 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 227 0 R
+>>
+endobj
+229 0 obj
+<< /Length 652 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GauHIbDr&G']&?q?Ht+]qYaO';Pm/)<Mr_PBJs]DKU<0JJu:lfakt^#'4)i(2AHk10DD!sq_EA(nE(r!=@/`IQim\2!t:9<0TZD]+>ejGE"MHR\!o%uhV<])+T1:s*+7hI*9[O at UbW3ETVT(``&@L0no at U]7:L>%DR2c/k%V9;"Ui0tpRCW)aEI<l!>MX^C6tRAijmkSM+W+,jE65;GRd,:"X5[#a9Q`-`OS-!3Z76rM_Z]bBHRi+XGgK2(d4/sWkok[YopCKnh_1Xn8M)E7 at n,l)JbPjd)3MEkPYXuY+CStT8>p0jb$L`4]42jA\L=o:"Ifp8uOa^Y#<rM[ss?[#?+k:\#p3bBp4K^%!UKq"LB7`H+gE>0H%8J;n-BUFYqVS<t*8RFPg'_(h8Y)eL5i"7@^:%ASSR)q-sQ>R^*.m5KE#!\2Sc(+$0s.p9<;YqmG[mji2C+rCP21.o"3KEgKWf_M[;7.sCm?`9!6uEC*,'o<k6[6ERX;lZ?W_*P4oV-X+_0L.]t+8o82>6'tNjrH5EIAP at SWf#N&=pLZh+7[CQ/1%@3[l6S?2k=*"SoKue'U<5YA3>!0E--&MXKu'tTT2YVYc67DNWRf.mEW_K_CN(("*<h)fU>JP/eq;$IA6tPk<q7oaDk/*~>
+endstream
+endobj
+230 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 229 0 R
+>>
+endobj
+231 0 obj
+<< /Length 901 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau0B997OU&AIm?jFh\&C>u^T"B&;P#GadT)o2P7\>dr1:#dN1G0@)0H*ha`VL\j7`A=''*oDps\Hs(UhI@(:J:n`Y$fB\kT]_ddoJcod`rZSNUL(J%^0Z5P4*Bq=pVIFF76TiR!s:Ra+DMTa+M]_u&2MFN,V-9]FeR6#^+?</c*u<]'%+_ol5N(F8upg][&W[o7`pV.Ntp_ at htVD7D'3dkQVXI$+V9*pm[]:DI=sSm$ou-,0ZZ;rrB at FGo+;Xp__BJGHitQZ1T^4DTKi"!+Zf9oVS<Yt(ri9N!nctD?9G1"@>4M/.s50eG\V:C?UW;@O#M"'a"a,3Upla?AVrj4c!58F at 9:FVhPn/&gWheb-mY\%q.:b!Q<E$;`\^7m8#[Yg'0IK'grL[1:(^poN*?NO8343BC1&q>dRr9cg<h#=^9O]f);4]>9KngsO9fOK*HcJ(a8p$eU1+]7Cnb[8. at FC/SB7muT$f*nP-i8hMIi>Y<q36TNtiV>-AN$$!)Q:B8VIsq^k.RI^de3a.&V`uW7=NkmUYia3r^O%RZBMS.oePT3gL4,dhejUQ2<J5f8"5pUI5la=qZWi/3(=Q?*?h-9h%bi#<ltuk3O;!nl(]@M%p]g/DE3E>toBa5U1.00io%4?>3kL'Z$M:opmS-,(6OjS^5"e/_N>P-hBPb!=-T7g?E)8(aQ]<2WsOD>UYqnmM\dFZXDoe(fo(03,WuSrh6(O!Ys39kYi#`S7;ah&-Vr1P]"uYA)>51$!PV5!"7tPf=Ca9^^pS$5CojnN#HU"omSeM&crW_rZs*Nog70Cf!itfC*u\eK@'@,<Qdir?TGt-,ks?QgMl\hq\j5:3&U$B,OO/CVa>\!imZm64>gZfm#?(0a%9u`/7jA(;$jQPrr?E[2Tl~>
+endstream
+endobj
+232 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 231 0 R
+>>
+endobj
+233 0 obj
+<< /Length 197 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarW2]aDVA&;9q/MQ%j:DYF&_D86ip,?uT3.Rm;Q1$\X_)FP:mAp/@Mq<C at ZA"YEoBTQC1*(`He-tq#0,euq/.QX@=ejXZKpUBSG?`0:U&Fr+:O(.[n0"]rD*P+U5D3,Mi:NRJ(CLKMJNZIIZ93/q2/ZksH^Hlekr6:LdK6l7>q9<\CA]&f%@:Ze);uZiMi\DS~>
+endstream
+endobj
+234 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 233 0 R
+>>
+endobj
+235 0 obj
+<< /Length 1416 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat%#95iiK&AJ$C#[<rmMO5-XGA^Q"$>csdTT.>l<>:BcfgKAm9 at DMd^Fq$u+t:]Y$=,V9%YsZ#P93ka?[mt8QiWEVX*P?^Rfs3eq8"1 at +:Q[B!I:+:X'P5hbnJrrgYe]3ot-G\!Z9&h;TK,/U_mg+5Sh1%@SQ-!I:t,s]Cn-bU."CY.1s]RoncWWAqX at u[S%hR7_RJ8]bpruW:bVY($e=$a$AOl-jD+o#Ee1Z/+ATsVDqS>pM*"t@#F*jdulCI&Of8T'lA:KQYAE]bVn6S5JNAVV0:\kco?@i&I6n8G&u3J,Y:7!A:q`([Q3\F.sd_l$ks#,V;c[cd=:-;TNlKnQ3$@U+V:Q6CWlO`aQ'8<K2`a8&P.Nn/m*%MTfZl<%HYI[\L/,oBm'(AM_22e'5O&3mKP6<\[H;=S5$P"j6>[n>]!U<L\#Rgknp*5',D64+LG61+l:DZU+#S?KLh;6.,XnA*C10J1d]Y+,?U&8c[7bLZs^E*%2K^YrSsf]r-,HS45$n23C>c3crP;V)e#YeVFMa%Hbu*?i5mem_5f7k+J:j_^"D&HqQltL-S;6J^,`e^PX]8oDhq!oXIR(WrR8fEfd3.G[qffH.Tl-j3<Xs]C<F&5Jfq\+kDb=,kWP==,gHc&&6eDtckTO;6^L^bPgfJD3BF68.3 at clbYam$?TLCVK_0T)R.KA+V/%&SR'<&Y@,,:r"g6IR36a#j6WLftQTU*0%<je_*_gdb?"7/3/SEnK0L(*)+b7kHP6f,--,05RcX/<[2i?">`1>FJgGQ*D^2qKGeS:n9-!\K+,<Ao5m9E6\lA4Hnk^me$.$Mm3;Kn`,pb,7AR-B"M4Qsp9&#MnK&LW,<h=lu*a8<TIe^fnlf+)m_Zm/:&oS$^s/8m+5,<SkaXN`W?Y`NX\S9jCfN4;R*6A[S#]_Rb=4&AD:N9b8[P:YTQp<(qIr5/_D_q6$m9G"N&7nQpF>9'O`ntOem4n(:H0NSq9Q9umeT?"Y:\'L[,0oM3'3:0PK0'6$$(8/_nhno9"Nik#<:80YeWA!<Xd#:&\,!(]W"2Dqu?)p#a((O`a("I<YRi8cOeNkf[;?2o.d/AgjMUB*rF.O>jUF60eMN-Pj62Oo"GfT3g"D"_RPW\r\WhJuVK62T#)0c.LQUNo_.Hjq/_hNtaa+^Pm+/Wq4P]E!\[tNcrj^bSJDgnt0rB\^1S!L.BeJ>L^p,#hp25_ZZL*Z;6A4)jph:#EK$MJ\#jlDbD_0\,a4R&ns_BK(Y^D!2MJab#Ya1<U_\CfDZI%eKfaS"TUWGCB'Al,@/Rd2?N6a):?cN at 0fY3A@^^$Pd_/Q.+.AE'L2I;Ir`e,2nY@;)nA\B!.Zg[JP:eRn*K,AX/[LN:@):bVfMHsBB)VQh[$F8KQRD@"e2.Jo#].*eskrr at BTR4n~>
+endstream
+endobj
+236 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 235 0 R
+>>
+endobj
+237 0 obj
+<< /Length 175 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas3+0aki`$jGQP^ETE_`oNS(caBEuK-4\<-bU/uY?:)ipU!g7OXuR+a4D4\2]d[0d1S->5`j.qML.K*FsION%1fdNQQscFLpi#F_0qi71KF"En'!*N&JON)[>Arja9>q:@04b0/^bl9L23-*]<tQ0Q`X@^kA/M,WN35p"FO-$;#~>
+endstream
+endobj
+238 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 237 0 R
+>>
+endobj
+239 0 obj
+<< /Length 1757 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gat<A?#QMsn9oci8u4G.DB3Q-:MQ`]2()[p<bcR-Q_k9ER)B>i$&6Xj^TYHXO'1,;Wms_5Z"H2VT&IS)F8O(#E.gdKm#$eg4Dh=_arbdNJm9Zs!YgE at ZTC-r?iQE5k`,1pZhm0h"V,_;!D,*\@+$::R%VO<MPB0G^+FRsfi,:1ftL%Ij,LAk6%AJ%Oc[XL&+ZeU?tu!rJO*sEBG)Xq'.1REG-s#r\ghJ5Y9k`l\?3.$UC`3<lH?GIdr,moEdCYHguK*$6ZPq=blPF(/3Gk]ZRApIX23ZIclJAMre2C&FPqFGJmHdS2/cZ!4m<=l'kUOiP0n,"eepnCim4IrnL&QKQ;JeX=t^-`j9LfVE7[3p#?nNfA"s;U!VW at .X5&=,9$<6PEu%[A$p9,(ils'^)NcLS/?1dWYo!6B-V4qDV:nD-bf91mL?l3peujOf29f6C4J?YbB*V/`6R9uU'oNXHWXHIcS]+I5oJ";a9N?[qWbkOj0ad#j1_g#O'f>tQe0XLQ1eFM4O4On9e8N!F&W\jTSYb7<`<"Ri#"T23E'Jh]=]u_3Dq+0[%ap9!%_^[q:R+Hm\un\rld(7o\'Ib#Qo](0=\B\QSPpshSXiL<UrM!jqo7?&hR-uFF4S^>jiYsTSajV'RXUD:2/DH<Wom.jYKo)jprYi,0#/M]XE+Tm-%P+^eN;,C[\JQ0G[k<!TKV5$mRmPfHs)^oL1rXn[hhU.V?g3&aFn:%+DCRN3CVn/!S/i)K/5mg:iMCd*4=A&XasqM(=C8KPW$(sFN%7c:egd\VUNj*=Q`X5YKX0]Hgo[%="0fCEnZbhG\A)#Bp5t at b"hUcL!^Dt,N8DS>UYLGbto29A at Q_2M$hP-OO)Q-R7:pq.UYpe"Y#Wg*1NP$EKcl7>1_kUH)o<<[P0+1/c3X#J=feD39_9Wk2Z:KqV'&e"o^!+dQdFMYkVLGJ:'GVX-_`'9C@<MH?TqR<t%ZqP$^L)q:/Y/8f36RK+8t,l]<(]R'&]L)INP>_'),;ZGHu+A<?V,q,-^fB/EgJ4%tj!^]+'!iP/KBW3K:K3ULb9ltk'tlKLR$=@q5QZSSsj4#ubG))sVj0ti$jj^M"7k\9@;IV$/*jjBBEk&[S<r?D^q:A8@)/>!s<dgd8_b!oES%XZK4%oCs#U.h39S`pDC/Gmj$gNW&1R+NVa_Dnt1<(/aTlCqYti*A%X\%u#DTq<OMLsL15o,Z%fj0YY?Xt43%Wj^6h^"<_?m"I&C1?YCiIsLqI`<KQ'Na-;Z6%Y`.a;S)`F3WEP7V'[Sa1`af`iT at gXN)p#"PKmgY]qYASLiC(Pamh2AR<:NFjQ5M0_utifeoeuZl$<!CiEG9\?A<P5WRQ]ZsAn'3(G-Z=A14hH^VuF]K5]r-jN`V]UsD-<@kr`.V-=d28S<oG:%'(Im$5[=Z:FT!A'b3YcbGZo0'19,>sPck[LWU&>L@?PWA0HV0rRtc4.\J5Xc<=8MF3CQ*116Y5GH:]'Vn,.l[>)i@&$U9L`+6,/LJF3>hHG._uE8j&_*3o259t@'N&_-HLC$b4A!l&!,=Dg"#--oGUFrqE6>hP+fZ%:']n:7B>EuTL:0s(R>T'RYKeuU6(#G\V<C=.[EParG\(I$f4,DI$4">CpQaqj9"F&4tLoQX4k*P)Ff3u\JqoLp:S.)?IUUmrA8skfX$aKYa=Kq<j!l(Vr^e2qq^C7IGRlgK)c(\kN^[%>W("[2SX/om,eOae9Ho7bdX)@\Wsk8YGD\5F611+[\hX~>
+endstream
+endobj
+240 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 239 0 R
+>>
+endobj
+241 0 obj
+<< /Length 311 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gas2D]l(_1'SUb&if;=B>JU.r at j@g;\#O7E#J7t^&iD7aeFr9fj"u":.[J!2n6HMc6gc!F?lF;"VC*&fKE4f*J`]Kh;i.oF@,Bk=fRLZhO3**LnJ`mef!pu=5k43<;`"=2#%#,.-Dgo8e+JCl__F=oWog61[d`^?)'`e/YVCm"[pRGX]PDB8UH>:I[`a]sZ_!2XW-<)pim0)7ApkSdeuuqh\38/nVR%:LRdCR[>^kpB7gjk\`*(QbU4o1$Oe'&6k"6fSVI5BW0=>G%fnX6>POeRi>BhHuqNkMcQHl9mEFDM+8\^)jDMe~>
+endstream
+endobj
+242 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 241 0 R
+>>
+endobj
+243 0 obj
+<< /Length 1320 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gau`S?]Us?&:`$(5[15DPo9lHN8^R5g?\0!=&l<0)tg&l"%c0qM3sfap@@TdK>BGKE[RE"RtnuCq>6ZOGl3$(=M4hY,QPg?3a;C9 at 0&Murh)amn@^6d+HE\85'_Y8^SWCTi;M]<J!EpaK>(lX6Ce*EM at d`4O8u^%)<:U*<X?hXI$q=C8B'],>9^..ml(LaZ[.bHV-0\X;_'PTOf"*!'_JPj.G"h.Z*.G[WVN]+"n/9=(gI>u&4A3eV;<i;8jDu(ak0MH=Rm&S&XiefCOlCT7Gp[''jMrdY_i9)gcZ<m<u$>?`:'gV_>^:SS5p@>(.WL-.tL:LEB#`Oe'CM]S6!\"B]05L&<g/k;&nj7j].LF69p-2-o9'@cMF_$Y:[Ml+O[+t#7(G\E"JEg7c_TWO[i>'AL/0XQusS=i[QHo-Q>Z\27b;K2)+HsWfGR[[V9HXG]S>:Bm,/I<;/45&=R!t'"N^Z/bfcOl?p9mAO+,N[fCEo`!o6Wd;K&Bo%$^p+(`n6^G]1k at NotW`?\!_8.-&m%G(99"&r(F554 at a0Z0#Ydo*cq!I-c at K:sZka9O7OY'GpM,rV?TB&JiDBU76F+<EGqDIEU`,^*UDrUAPMmPl>!OY41sjP\[pI)opt5dHTsqoo_?G68"n,k7Y/\Go[&RoO=75jMJ.>CcCuPM8.meoB[_otIJ\OB5+n<P59 at HaMGiS5XPBV<Z&BihbsJ6JDao??Jp#'*Y5g!;+S"Sn"*M.r)f-J5QV]1+`OHJ4-PIo4\M%"OKDcIF0WVjY4*R%54_I&E)[n&?;E)`iU%Q[+kt2G35p+!E)>ua.]*Q\tP2g^eYSGqJ?P,V)952U(s1AD?oKjVIFc!\MN=3.#Rk?S2JITe!:?-eoh\44r7eP[OnABB>q#&_ at jBN5A=+*?4L6Y89a/PD07+e0ql2FQ&6+5W7D(,A9I1cR*'C[_uQ!seaWJc<QApYj(Z,G^4f+m.5k+C"?gl+YdqN4`7(R\R.#&Bcg[LYm!%kU&&Ssr:i`3sSHs()WEL&"C=S-AUoaR$26Q4BXAk?dL at NiVBTssrPE*Qn#^u*]4+4fr0p[NqFe;Hb,``0?4&$BP^=)e7XmjG=4A4L?m7hIp'S.[Pj5L$Mhs[/nD<,%;YPO>(X+)m>]kV_ at ErBV/+DD8L-cR+[;s-=5S7Q^\S/X[r?_L/2''k>+CV`61@%k4lUKG82*ud;kI>htq\*\o""6>C,b,ZS;W&lChg9e^RG>,cVWc!1$9c%@$d#Z3g4KfPCgIHY/7cY;9]s.>+jd2WH[eOA&IQ_5#64dD`1N-1D4RPHN2b(gJs,7Q?)#~>
+endstream
+endobj
+244 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 243 0 R
+>>
+endobj
+245 0 obj
+<< /Length 1048 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+Gasao;/b2K%"?O+d+btG_Uu.?fmW1t($K'ci6Z;XYjF`!j?tpso%?dDr;2[h4,Vg`1DECU;'Pgm'Ige$c5)HQ_D*<-KU2Eb5jMR/!qR3PL*8f=8V+ki/[sruc$`_%[?A:Bd2XqHBbI3Uh;!XDT2aY9U>V$\l5'=`b<NT]!O.Bg62U_95S,;KJG8o5$I)X"ZhT,Ta=&<'j]R%YI!dtX&JPGhoskNL'f67?+]2nB<UX,J1^/JKPRo@#)XZV9M:-*\,>OBbX%4)*&;7u_FbLh_0pmT<-7-ueo!NFFo1EpAP"k>Z6+flFMW+mIo=])7<_O'^W2V*b*TGg*C:E#8R\m`%/9Z:ki?a2ZV.CHlo`)`^o9.=U>5q@?2gdiO)q?T8*?B#+&n2;*>ok$7\WcKSh`l^F:M3<j9<AF^R3)=8laIAHk"Mr(A<dnAe[]n'S324die.;DrimOd52Q;s;*':8OI5f4Y&s9YM%(*,fiIid3'aTi<@2`lXT^-#/BUTb,I41QA6Ha6/%V]!CW6:qK$t.i[ifI'#2lnSe_!h0+I at dT9_pe);$9JUdp at mD51Y_G66YZ81.)'Rl5OrlFWiOdAS7Fq-k^mrLX49[V$dS5b!tNYQtj3o`PA]r1?uDd?b`U5[[-M$W>9h0%dgjD?%Ed(?KLmYccEUfYDm.'C;DUlR!^a0P%oDf`fbN!i8MMn)c<#fZ,E-.f$C#MC?:!4h@=JActGSDjgH_#':0r$),T<+.<kGsC>Q5F2N;@u<I:Ak.s(B+F`aWWX+j8iSs0U7S4:;]n+b%@5g49h7jBce[1i+\ceR\I_Tnl-r8!i9W2ARn]Fo!_2q at HCe2'JpTU>Rnp:QRdV<GN0K6cCiCkNFJ>M*8'm/,Ri"':ILrF!,*WStISl.Lh@`&.#+>fg5E6:beVg[nG/XUDeB`JDJ59NQ)7B,QKMqtD_h\eGlt>#-uZmIc67[g/Mjd])]h=7c=Ve5\?U+2o(#otthDDtertGqejg6VO(Tfh=5%$'`d8T"S?g2prP;Mu-7(K@%%g$m0d at EZtGbS0M4Q~>
+endstream
+endobj
+246 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 245 0 R
+/Annots 247 0 R
+>>
+endobj
+247 0 obj
+[
+248 0 R
+249 0 R
+250 0 R
+251 0 R
+252 0 R
+253 0 R
+254 0 R
+]
+endobj
+248 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 345.52 637.683 367.18 627.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
+>>
+endobj
+249 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 373.595 637.683 444.155 627.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://uffi.b9.com)
+/S /URI >>
+/H /I
+>>
+endobj
+250 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 582.79 626.683 614.47 616.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+251 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 626.66 626.683 641.1 616.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+252 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 120.0 615.683 280.52 605.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://www.sourceforge.net/projects/cclan)
+/S /URI >>
+/H /I
+>>
+endobj
+253 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 156.67 604.683 172.22 594.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
+/S /URI >>
+/H /I
+>>
+endobj
+254 0 obj
+<< /Type /Annot
+/Subtype /Link
+/Rect [ 178.05 604.683 440.79 594.683 ]
+/C [ 0 0 0 ]
+/Border [ 0 0 0 ]
+/A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp)
+/S /URI >>
+/H /I
+>>
+endobj
+255 0 obj
+<< /Length 280 /Filter [ /ASCII85Decode /FlateDecode ]
+ >>
+stream
+GarVI]afWJ&Dm9u2p,Oq5;7s,UROh6F[-#*#uI``q">Jf5_uu4bMDo6GDSeiPQMRYME'f4&\&tk`#",h at 0.p9YnA5D)GZ2rAY7;m]`Ycp5'X%08j(3'#8(NQ6V2iC(k5PbFbR@`!A#[Z]BLMf20j!(['ai+_Ne81r4HZkJku<mrAg7mQkK#CF_B$2mqtVhU".j/B-Z1_F'IP.em,6^\M at 7Ln&E,lX[\B?X8;3M.Bs$'A)`V$TL;;7kW.$DaoCpd1H;(W-5 at Rc0#\\'!Qe&Dm/~>
+endstream
+endobj
+256 0 obj
+<< /Type /Page
+/Parent 1 0 R
+/MediaBox [ 0 0 612 792 ]
+/Resources 3 0 R
+/Contents 255 0 R
+>>
+endobj
+259 0 obj
+<<
+ /Title (\376\377\0\125\0\106\0\106\0\111\0\40\0\122\0\145\0\146\0\145\0\162\0\145\0\156\0\143\0\145\0\40\0\107\0\165\0\151\0\144\0\145)
+ /Parent 257 0 R
+ /Next 261 0 R
+ /A 258 0 R
+>> endobj
+261 0 obj
+<<
+ /Title (\376\377\0\124\0\141\0\142\0\154\0\145\0\40\0\157\0\146\0\40\0\103\0\157\0\156\0\164\0\145\0\156\0\164\0\163)
+ /Parent 257 0 R
+ /Prev 259 0 R
+ /Next 262 0 R
+ /A 260 0 R
+>> endobj
+262 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\145\0\146\0\141\0\143\0\145)
+ /Parent 257 0 R
+ /Prev 261 0 R
+ /Next 263 0 R
+ /A 15 0 R
+>> endobj
+263 0 obj
+<<
+ /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\61\0\56\0\240\0\111\0\156\0\164\0\162\0\157\0\144\0\165\0\143\0\164\0\151\0\157\0\156)
+ /Parent 257 0 R
+ /First 264 0 R
+ /Last 267 0 R
+ /Prev 262 0 R
+ /Next 270 0 R
+ /Count -6
+ /A 17 0 R
+>> endobj
+264 0 obj
+<<
+ /Title (\376\377\0\120\0\165\0\162\0\160\0\157\0\163\0\145)
+ /Parent 263 0 R
+ /Next 265 0 R
+ /A 19 0 R
+>> endobj
+265 0 obj
+<<
+ /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144)
+ /Parent 263 0 R
+ /Prev 264 0 R
+ /Next 266 0 R
+ /A 21 0 R
+>> endobj
+266 0 obj
+<<
+ /Title (\376\377\0\123\0\165\0\160\0\160\0\157\0\162\0\164\0\145\0\144\0\40\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\163)
+ /Parent 263 0 R
+ /Prev 265 0 R
+ /Next 267 0 R
+ /A 23 0 R
+>> endobj
+267 0 obj
+<<
+ /Title (\376\377\0\104\0\145\0\163\0\151\0\147\0\156)
+ /Parent 263 0 R
+ /First 268 0 R
+ /Last 269 0 R
+ /Prev 266 0 R
+ /Count -2
+ /A 25 0 R
+>> endobj
+268 0 obj
+<<
+ /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167)
+ /Parent 267 0 R
+ /Next 269 0 R
+ /A 27 0 R
+>> endobj
+269 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\151\0\157\0\162\0\151\0\164\0\151\0\145\0\163)
+ /Parent 267 0 R
+ /Prev 268 0 R
+ /A 29 0 R
+>> endobj
+270 0 obj
+<<
+ /Title (\376\377\0\103\0\150\0\141\0\160\0\164\0\145\0\162\0\240\0\62\0\56\0\240\0\120\0\162\0\157\0\147\0\162\0\141\0\155\0\155\0\151\0\156\0\147\0\40\0\116\0\157\0\164\0\145\0\163)
+ /Parent 257 0 R
+ /First 271 0 R
+ /Last 276 0 R
+ /Prev 263 0 R
+ /Next 279 0 R
+ /Count -8
+ /A 31 0 R
+>> endobj
+271 0 obj
+<<
+ /Title (\376\377\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\123\0\160\0\145\0\143\0\151\0\146\0\151\0\143\0\40\0\116\0\157\0\164\0\145\0\163)
+ /Parent 270 0 R
+ /First 272 0 R
+ /Last 274 0 R
+ /Next 275 0 R
+ /Count -3
+ /A 33 0 R
+>> endobj
+272 0 obj
+<<
+ /Title (\376\377\0\101\0\154\0\154\0\145\0\147\0\162\0\157\0\103\0\114)
+ /Parent 271 0 R
+ /Next 273 0 R
+ /A 35 0 R
+>> endobj
+273 0 obj
+<<
+ /Title (\376\377\0\114\0\151\0\163\0\160\0\167\0\157\0\162\0\153\0\163)
+ /Parent 271 0 R
+ /Prev 272 0 R
+ /Next 274 0 R
+ /A 37 0 R
+>> endobj
+274 0 obj
+<<
+ /Title (\376\377\0\103\0\115\0\125\0\103\0\114)
+ /Parent 271 0 R
+ /Prev 273 0 R
+ /A 39 0 R
+>> endobj
+275 0 obj
+<<
+ /Title (\376\377\0\106\0\157\0\162\0\145\0\151\0\147\0\156\0\40\0\117\0\142\0\152\0\145\0\143\0\164\0\40\0\122\0\145\0\160\0\162\0\145\0\163\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\141\0\156\0\144\0\40\0\101\0\143\0\143\0\145\0\163\0\163)
+ /Parent 270 0 R
+ /Prev 271 0 R
+ /Next 276 0 R
+ /A 41 0 R
+>> endobj
+276 0 obj
+<<
+ /Title (\376\377\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\151\0\156\0\147\0\40\0\103\0\157\0\144\0\145\0\40\0\125\0\163\0\151\0\156\0\147\0\40\0\125\0\106\0\106\0\111)
+ /Parent 270 0 R
+ /First 277 0 R
+ /Last 278 0 R
+ /Prev 275 0 R
+ /Count -2
+ /A 43 0 R
+>> endobj
+277 0 obj
+<<
+ /Title (\376\377\0\102\0\141\0\143\0\153\0\147\0\162\0\157\0\165\0\156\0\144)
+ /Parent 276 0 R
+ /Next 278 0 R
+ /A 45 0 R
+>> endobj
+278 0 obj
+<<
+ /Title (\376\377\0\103\0\162\0\157\0\163\0\163\0\55\0\111\0\155\0\160\0\154\0\145\0\155\0\145\0\156\0\164\0\141\0\164\0\151\0\157\0\156\0\40\0\117\0\160\0\164\0\151\0\155\0\151\0\172\0\141\0\164\0\151\0\157\0\156)
+ /Parent 276 0 R
+ /Prev 277 0 R
+ /A 47 0 R
+>> endobj
+279 0 obj
+<<
+ /Title (\376\377\0\104\0\145\0\143\0\154\0\141\0\162\0\141\0\164\0\151\0\157\0\156\0\163)
+ /Parent 257 0 R
+ /First 281 0 R
+ /Last 282 0 R
+ /Prev 270 0 R
+ /Next 283 0 R
+ /Count -2
+ /A 49 0 R
+>> endobj
+281 0 obj
+<<
+ /Title (\376\377\0\117\0\166\0\145\0\162\0\166\0\151\0\145\0\167)
+ /Parent 279 0 R
+ /Next 282 0 R
+ /A 280 0 R
+>> endobj
+282 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\164\0\171\0\160\0\145)
+ /Parent 279 0 R
+ /Prev 281 0 R
+ /A 51 0 R
+>> endobj
+283 0 obj
+<<
+ /Title (\376\377\0\120\0\162\0\151\0\155\0\151\0\164\0\151\0\166\0\145\0\40\0\124\0\171\0\160\0\145\0\163)
+ /Parent 257 0 R
+ /First 284 0 R
+ /Last 286 0 R
+ /Prev 279 0 R
+ /Next 287 0 R
+ /Count -3
+ /A 53 0 R
+>> endobj
+284 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\143\0\157\0\156\0\163\0\164\0\141\0\156\0\164)
+ /Parent 283 0 R
+ /Next 285 0 R
+ /A 55 0 R
+>> endobj
+285 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145)
+ /Parent 283 0 R
+ /Prev 284 0 R
+ /Next 286 0 R
+ /A 57 0 R
+>> endobj
+286 0 obj
+<<
+ /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\143\0\150\0\141\0\162\0\55\0\160)
+ /Parent 283 0 R
+ /Prev 285 0 R
+ /A 59 0 R
+>> endobj
+287 0 obj
+<<
+ /Title (\376\377\0\101\0\147\0\147\0\162\0\145\0\147\0\141\0\164\0\145\0\40\0\124\0\171\0\160\0\145\0\163)
+ /Parent 257 0 R
+ /First 288 0 R
+ /Last 294 0 R
+ /Prev 283 0 R
+ /Next 295 0 R
+ /Count -7
+ /A 61 0 R
+>> endobj
+288 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\145\0\156\0\165\0\155)
+ /Parent 287 0 R
+ /Next 289 0 R
+ /A 63 0 R
+>> endobj
+289 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\163\0\164\0\162\0\165\0\143\0\164)
+ /Parent 287 0 R
+ /Prev 288 0 R
+ /Next 290 0 R
+ /A 65 0 R
+>> endobj
+290 0 obj
+<<
+ /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\166\0\141\0\154\0\165\0\145)
+ /Parent 287 0 R
+ /Prev 289 0 R
+ /Next 291 0 R
+ /A 67 0 R
+>> endobj
+291 0 obj
+<<
+ /Title (\376\377\0\147\0\145\0\164\0\55\0\163\0\154\0\157\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 287 0 R
+ /Prev 290 0 R
+ /Next 292 0 R
+ /A 69 0 R
+>> endobj
+292 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 287 0 R
+ /Prev 291 0 R
+ /Next 293 0 R
+ /A 71 0 R
+>> endobj
+293 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\141\0\162\0\162\0\141\0\171)
+ /Parent 287 0 R
+ /Prev 292 0 R
+ /Next 294 0 R
+ /A 73 0 R
+>> endobj
+294 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\165\0\156\0\151\0\157\0\156)
+ /Parent 287 0 R
+ /Prev 293 0 R
+ /A 75 0 R
+>> endobj
+295 0 obj
+<<
+ /Title (\376\377\0\117\0\142\0\152\0\145\0\143\0\164\0\163)
+ /Parent 257 0 R
+ /First 296 0 R
+ /Last 308 0 R
+ /Prev 287 0 R
+ /Next 309 0 R
+ /Count -13
+ /A 77 0 R
+>> endobj
+296 0 obj
+<<
+ /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 295 0 R
+ /Next 297 0 R
+ /A 79 0 R
+>> endobj
+297 0 obj
+<<
+ /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 295 0 R
+ /Prev 296 0 R
+ /Next 298 0 R
+ /A 81 0 R
+>> endobj
+298 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\157\0\142\0\152\0\145\0\143\0\164)
+ /Parent 295 0 R
+ /Prev 297 0 R
+ /Next 299 0 R
+ /A 83 0 R
+>> endobj
+299 0 obj
+<<
+ /Title (\376\377\0\163\0\151\0\172\0\145\0\55\0\157\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\164\0\171\0\160\0\145)
+ /Parent 295 0 R
+ /Prev 298 0 R
+ /Next 300 0 R
+ /A 85 0 R
+>> endobj
+300 0 obj
+<<
+ /Title (\376\377\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\141\0\144\0\144\0\162\0\145\0\163\0\163)
+ /Parent 295 0 R
+ /Prev 299 0 R
+ /Next 301 0 R
+ /A 87 0 R
+>> endobj
+301 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\162\0\145\0\146\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 295 0 R
+ /Prev 300 0 R
+ /Next 302 0 R
+ /A 89 0 R
+>> endobj
+302 0 obj
+<<
+ /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\143\0\150\0\141\0\162\0\141\0\143\0\164\0\145\0\162)
+ /Parent 295 0 R
+ /Prev 301 0 R
+ /Next 303 0 R
+ /A 91 0 R
+>> endobj
+303 0 obj
+<<
+ /Title (\376\377\0\145\0\156\0\163\0\165\0\162\0\145\0\55\0\143\0\150\0\141\0\162\0\55\0\151\0\156\0\164\0\145\0\147\0\145\0\162)
+ /Parent 295 0 R
+ /Prev 302 0 R
+ /Next 304 0 R
+ /A 93 0 R
+>> endobj
+304 0 obj
+<<
+ /Title (\376\377\0\155\0\141\0\153\0\145\0\55\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 295 0 R
+ /Prev 303 0 R
+ /Next 305 0 R
+ /A 95 0 R
+>> endobj
+305 0 obj
+<<
+ /Title (\376\377\0\156\0\165\0\154\0\154\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\55\0\160)
+ /Parent 295 0 R
+ /Prev 304 0 R
+ /Next 306 0 R
+ /A 97 0 R
+>> endobj
+306 0 obj
+<<
+ /Title (\376\377\0\53\0\156\0\165\0\154\0\154\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162\0\53)
+ /Parent 295 0 R
+ /Prev 305 0 R
+ /Next 307 0 R
+ /A 99 0 R
+>> endobj
+307 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\141\0\163\0\164\0\55\0\160\0\157\0\151\0\156\0\164\0\145\0\162)
+ /Parent 295 0 R
+ /Prev 306 0 R
+ /Next 308 0 R
+ /A 101 0 R
+>> endobj
+308 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\166\0\141\0\162)
+ /Parent 295 0 R
+ /Prev 307 0 R
+ /A 103 0 R
+>> endobj
+309 0 obj
+<<
+ /Title (\376\377\0\123\0\164\0\162\0\151\0\156\0\147\0\163)
+ /Parent 257 0 R
+ /First 310 0 R
+ /Last 316 0 R
+ /Prev 295 0 R
+ /Next 317 0 R
+ /Count -7
+ /A 105 0 R
+>> endobj
+310 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Next 311 0 R
+ /A 107 0 R
+>> endobj
+311 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 310 0 R
+ /Next 312 0 R
+ /A 109 0 R
+>> endobj
+312 0 obj
+<<
+ /Title (\376\377\0\146\0\162\0\145\0\145\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 311 0 R
+ /Next 313 0 R
+ /A 111 0 R
+>> endobj
+313 0 obj
+<<
+ /Title (\376\377\0\167\0\151\0\164\0\150\0\55\0\143\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 312 0 R
+ /Next 314 0 R
+ /A 113 0 R
+>> endobj
+314 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\146\0\162\0\157\0\155\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 313 0 R
+ /Next 315 0 R
+ /A 115 0 R
+>> endobj
+315 0 obj
+<<
+ /Title (\376\377\0\143\0\157\0\156\0\166\0\145\0\162\0\164\0\55\0\164\0\157\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 314 0 R
+ /Next 316 0 R
+ /A 117 0 R
+>> endobj
+316 0 obj
+<<
+ /Title (\376\377\0\141\0\154\0\154\0\157\0\143\0\141\0\164\0\145\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\163\0\164\0\162\0\151\0\156\0\147)
+ /Parent 309 0 R
+ /Prev 315 0 R
+ /A 119 0 R
+>> endobj
+317 0 obj
+<<
+ /Title (\376\377\0\106\0\165\0\156\0\143\0\164\0\151\0\157\0\156\0\163\0\40\0\46\0\40\0\114\0\151\0\142\0\162\0\141\0\162\0\151\0\145\0\163)
+ /Parent 257 0 R
+ /First 318 0 R
+ /Last 320 0 R
+ /Prev 309 0 R
+ /Next 321 0 R
+ /Count -3
+ /A 124 0 R
+>> endobj
+318 0 obj
+<<
+ /Title (\376\377\0\144\0\145\0\146\0\55\0\146\0\165\0\156\0\143\0\164\0\151\0\157\0\156)
+ /Parent 317 0 R
+ /Next 319 0 R
+ /A 126 0 R
+>> endobj
+319 0 obj
+<<
+ /Title (\376\377\0\154\0\157\0\141\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171)
+ /Parent 317 0 R
+ /Prev 318 0 R
+ /Next 320 0 R
+ /A 128 0 R
+>> endobj
+320 0 obj
+<<
+ /Title (\376\377\0\146\0\151\0\156\0\144\0\55\0\146\0\157\0\162\0\145\0\151\0\147\0\156\0\55\0\154\0\151\0\142\0\162\0\141\0\162\0\171)
+ /Parent 317 0 R
+ /Prev 319 0 R
+ /A 130 0 R
+>> endobj
+321 0 obj
+<<
+ /Title (\376\377\0\101\0\160\0\160\0\145\0\156\0\144\0\151\0\170\0\240\0\101\0\56\0\240\0\111\0\156\0\163\0\164\0\141\0\154\0\154\0\141\0\164\0\151\0\157\0\156)
+ /Parent 257 0 R
+ /First 322 0 R
+ /Last 323 0 R
+ /Prev 317 0 R
+ /Next 324 0 R
+ /Count -2
+ /A 132 0 R
+>> endobj
+322 0 obj
+<<
+ /Title (\376\377\0\104\0\157\0\167\0\156\0\154\0\157\0\141\0\144\0\40\0\125\0\106\0\106\0\111)
+ /Parent 321 0 R
+ /Next 323 0 R
+ /A 134 0 R
+>> endobj
+323 0 obj
+<<
+ /Title (\376\377\0\114\0\157\0\141\0\144\0\151\0\156\0\147)
+ /Parent 321 0 R
+ /Prev 322 0 R
+ /A 136 0 R
+>> endobj
+324 0 obj
+<<
+ /Title (\376\377\0\107\0\154\0\157\0\163\0\163\0\141\0\162\0\171)
+ /Parent 257 0 R
+ /Prev 321 0 R
+ /A 138 0 R
+>> endobj
+325 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F3
+/BaseFont /Helvetica-Bold
+/Encoding /WinAnsiEncoding >>
+endobj
+326 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F5
+/BaseFont /Times-Roman
+/Encoding /WinAnsiEncoding >>
+endobj
+327 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F10
+/BaseFont /Courier-Oblique
+/Encoding /WinAnsiEncoding >>
+endobj
+328 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F1
+/BaseFont /Helvetica
+/Encoding /WinAnsiEncoding >>
+endobj
+329 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F6
+/BaseFont /Times-Italic
+/Encoding /WinAnsiEncoding >>
+endobj
+330 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F4
+/BaseFont /Helvetica-BoldOblique
+/Encoding /WinAnsiEncoding >>
+endobj
+331 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F9
+/BaseFont /Courier
+/Encoding /WinAnsiEncoding >>
+endobj
+332 0 obj
+<< /Type /Font
+/Subtype /Type1
+/Name /F7
+/BaseFont /Times-Bold
+/Encoding /WinAnsiEncoding >>
+endobj
+1 0 obj
+<< /Type /Pages
+/Count 60
+/Kids [6 0 R 8 0 R 10 0 R 12 0 R 121 0 R 140 0 R 142 0 R 144 0 R 146 0 R 148 0 R 150 0 R 152 0 R 154 0 R 156 0 R 158 0 R 160 0 R 162 0 R 164 0 R 166 0 R 168 0 R 170 0 R 172 0 R 174 0 R 176 0 R 178 0 R 180 0 R 182 0 R 184 0 R 186 0 R 188 0 R 190 0 R 192 0 R 194 0 R 196 0 R 198 0 R 200 0 R 202 0 R 204 0 R 206 0 R 208 0 R 210 0 R 212 0 R 214 0 R 216 0 R 218 0 R 220 0 R 222 0 R 224 0 R 226 0 R 228 0 R 230 0 R 232 0 R 234 0 R 236 0 R 238 0 R 240 0 R 242 0 R 244 0 R 246 0 R 256 0 R ] >>
+endobj
+2 0 obj
+<< /Type /Catalog
+/Pages 1 0 R
+ /Outlines 257 0 R
+ /PageMode /UseOutlines
+ /Names << /Dests << /Names [  (preface) [ 140 0 R /XYZ 115.0 725.0 null ] (introduction) [ 142 0 R /XYZ 115.0 725.0 null ] (notes) [ 146 0 R /XYZ 115.0 725.0 null ] (ref_declarations) [ 150 0 R /XYZ 115.0 725.0 null ] (primitives) [ 154 0 R /XYZ 115.0 725.0 null ] (aggregates) [ 162 0 R /XYZ 115.0 725.0 null ] (objects) [ 182 0 R /XYZ 115.0 725.0 null ] (strings) [ 216 0 R /XYZ 115.0 725.0 null ] (func_libr) [ 234 0 R /XYZ 115.0 725.0 null ] (installation) [ 246 0 R /XYZ 115.0 725.0 null ] (glossary) [ 256 0 R /XYZ 115.0 725.0 null ] (id2452772) [ 10 0 R /XYZ 115.0 725.0 null ] ] >> >>
+ >>
+endobj
+3 0 obj
+<< 
+/Font << /F3 325 0 R /F5 326 0 R /F10 327 0 R /F6 329 0 R /F1 328 0 R /F4 330 0 R /F9 331 0 R /F7 332 0 R >> 
+/ProcSet [ /PDF /ImageC /Text ] >> 
+endobj
+15 0 obj
+<<
+/S /GoTo
+/D [140 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+17 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+19 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 687.009 null]
+>>
+endobj
+21 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 621.683 null]
+>>
+endobj
+23 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 459.357 null]
+>>
+endobj
+25 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 197.031 null]
+>>
+endobj
+27 0 obj
+<<
+/S /GoTo
+/D [142 0 R /XYZ 115.0 163.705 null]
+>>
+endobj
+29 0 obj
+<<
+/S /GoTo
+/D [144 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+31 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+33 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 687.009 null]
+>>
+endobj
+35 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 643.683 null]
+>>
+endobj
+37 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 604.244 null]
+>>
+endobj
+39 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 564.805 null]
+>>
+endobj
+41 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 525.366 null]
+>>
+endobj
+43 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 405.04 null]
+>>
+endobj
+45 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 371.714 null]
+>>
+endobj
+47 0 obj
+<<
+/S /GoTo
+/D [146 0 R /XYZ 115.0 224.275 null]
+>>
+endobj
+49 0 obj
+<<
+/S /GoTo
+/D [150 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+51 0 obj
+<<
+/S /GoTo
+/D [152 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+53 0 obj
+<<
+/S /GoTo
+/D [154 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+55 0 obj
+<<
+/S /GoTo
+/D [156 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+57 0 obj
+<<
+/S /GoTo
+/D [158 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+59 0 obj
+<<
+/S /GoTo
+/D [160 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+61 0 obj
+<<
+/S /GoTo
+/D [162 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+63 0 obj
+<<
+/S /GoTo
+/D [164 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+65 0 obj
+<<
+/S /GoTo
+/D [168 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+67 0 obj
+<<
+/S /GoTo
+/D [170 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+69 0 obj
+<<
+/S /GoTo
+/D [172 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+71 0 obj
+<<
+/S /GoTo
+/D [174 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+73 0 obj
+<<
+/S /GoTo
+/D [176 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+75 0 obj
+<<
+/S /GoTo
+/D [180 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+77 0 obj
+<<
+/S /GoTo
+/D [182 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+79 0 obj
+<<
+/S /GoTo
+/D [184 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+81 0 obj
+<<
+/S /GoTo
+/D [186 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+83 0 obj
+<<
+/S /GoTo
+/D [188 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+85 0 obj
+<<
+/S /GoTo
+/D [190 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+87 0 obj
+<<
+/S /GoTo
+/D [192 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+89 0 obj
+<<
+/S /GoTo
+/D [194 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+91 0 obj
+<<
+/S /GoTo
+/D [198 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+93 0 obj
+<<
+/S /GoTo
+/D [200 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+95 0 obj
+<<
+/S /GoTo
+/D [202 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+97 0 obj
+<<
+/S /GoTo
+/D [204 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+99 0 obj
+<<
+/S /GoTo
+/D [206 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+101 0 obj
+<<
+/S /GoTo
+/D [208 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+103 0 obj
+<<
+/S /GoTo
+/D [212 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+105 0 obj
+<<
+/S /GoTo
+/D [216 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+107 0 obj
+<<
+/S /GoTo
+/D [220 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+109 0 obj
+<<
+/S /GoTo
+/D [222 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+111 0 obj
+<<
+/S /GoTo
+/D [224 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+113 0 obj
+<<
+/S /GoTo
+/D [226 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+115 0 obj
+<<
+/S /GoTo
+/D [228 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+117 0 obj
+<<
+/S /GoTo
+/D [230 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+119 0 obj
+<<
+/S /GoTo
+/D [232 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+124 0 obj
+<<
+/S /GoTo
+/D [234 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+126 0 obj
+<<
+/S /GoTo
+/D [236 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+128 0 obj
+<<
+/S /GoTo
+/D [240 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+130 0 obj
+<<
+/S /GoTo
+/D [244 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+132 0 obj
+<<
+/S /GoTo
+/D [246 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+134 0 obj
+<<
+/S /GoTo
+/D [246 0 R /XYZ 115.0 687.009 null]
+>>
+endobj
+136 0 obj
+<<
+/S /GoTo
+/D [246 0 R /XYZ 115.0 599.683 null]
+>>
+endobj
+138 0 obj
+<<
+/S /GoTo
+/D [256 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+257 0 obj
+<<
+ /First 259 0 R
+ /Last 324 0 R
+>> endobj
+258 0 obj
+<<
+/S /GoTo
+/D [10 0 R /XYZ 115.0 725.0 null]
+>>
+endobj
+260 0 obj
+<<
+/S /GoTo
+/D [12 0 R /XYZ 115.0 715.0 null]
+>>
+endobj
+280 0 obj
+<<
+/S /GoTo
+/D [150 0 R /XYZ 115.0 678.347 null]
+>>
+endobj
+xref
+0 333
+0000000000 65535 f 
+0000087357 00000 n 
+0000087884 00000 n 
+0000088571 00000 n 
+0000000015 00000 n 
+0000000071 00000 n 
+0000000363 00000 n 
+0000000469 00000 n 
+0000001525 00000 n 
+0000001631 00000 n 
+0000001792 00000 n 
+0000001899 00000 n 
+0000003924 00000 n 
+0000004047 00000 n 
+0000004448 00000 n 
+0000088736 00000 n 
+0000004584 00000 n 
+0000088802 00000 n 
+0000004720 00000 n 
+0000088868 00000 n 
+0000004856 00000 n 
+0000088936 00000 n 
+0000004992 00000 n 
+0000089004 00000 n 
+0000005128 00000 n 
+0000089072 00000 n 
+0000005264 00000 n 
+0000089140 00000 n 
+0000005400 00000 n 
+0000089208 00000 n 
+0000005536 00000 n 
+0000089274 00000 n 
+0000005672 00000 n 
+0000089340 00000 n 
+0000005808 00000 n 
+0000089408 00000 n 
+0000005944 00000 n 
+0000089476 00000 n 
+0000006080 00000 n 
+0000089544 00000 n 
+0000006216 00000 n 
+0000089612 00000 n 
+0000006352 00000 n 
+0000089680 00000 n 
+0000006488 00000 n 
+0000089747 00000 n 
+0000006624 00000 n 
+0000089815 00000 n 
+0000006760 00000 n 
+0000089883 00000 n 
+0000006896 00000 n 
+0000089949 00000 n 
+0000007032 00000 n 
+0000090015 00000 n 
+0000007168 00000 n 
+0000090081 00000 n 
+0000007304 00000 n 
+0000090147 00000 n 
+0000007440 00000 n 
+0000090213 00000 n 
+0000007576 00000 n 
+0000090279 00000 n 
+0000007712 00000 n 
+0000090345 00000 n 
+0000007848 00000 n 
+0000090411 00000 n 
+0000007984 00000 n 
+0000090477 00000 n 
+0000008120 00000 n 
+0000090543 00000 n 
+0000008256 00000 n 
+0000090609 00000 n 
+0000008391 00000 n 
+0000090675 00000 n 
+0000008527 00000 n 
+0000090741 00000 n 
+0000008663 00000 n 
+0000090807 00000 n 
+0000008798 00000 n 
+0000090873 00000 n 
+0000008934 00000 n 
+0000090939 00000 n 
+0000009070 00000 n 
+0000091005 00000 n 
+0000009206 00000 n 
+0000091071 00000 n 
+0000009342 00000 n 
+0000091137 00000 n 
+0000009478 00000 n 
+0000091203 00000 n 
+0000009613 00000 n 
+0000091269 00000 n 
+0000009749 00000 n 
+0000091335 00000 n 
+0000009885 00000 n 
+0000091401 00000 n 
+0000010021 00000 n 
+0000091467 00000 n 
+0000010157 00000 n 
+0000091533 00000 n 
+0000010293 00000 n 
+0000091599 00000 n 
+0000010431 00000 n 
+0000091666 00000 n 
+0000010569 00000 n 
+0000091733 00000 n 
+0000010707 00000 n 
+0000091800 00000 n 
+0000010845 00000 n 
+0000091867 00000 n 
+0000010983 00000 n 
+0000091934 00000 n 
+0000011121 00000 n 
+0000092001 00000 n 
+0000011259 00000 n 
+0000092068 00000 n 
+0000011396 00000 n 
+0000092135 00000 n 
+0000011532 00000 n 
+0000092202 00000 n 
+0000011668 00000 n 
+0000012297 00000 n 
+0000012423 00000 n 
+0000012508 00000 n 
+0000092269 00000 n 
+0000012642 00000 n 
+0000092336 00000 n 
+0000012776 00000 n 
+0000092403 00000 n 
+0000012910 00000 n 
+0000092470 00000 n 
+0000013044 00000 n 
+0000092537 00000 n 
+0000013178 00000 n 
+0000092604 00000 n 
+0000013312 00000 n 
+0000092673 00000 n 
+0000013446 00000 n 
+0000092742 00000 n 
+0000013580 00000 n 
+0000014239 00000 n 
+0000014349 00000 n 
+0000016398 00000 n 
+0000016508 00000 n 
+0000017682 00000 n 
+0000017792 00000 n 
+0000020198 00000 n 
+0000020308 00000 n 
+0000020766 00000 n 
+0000020876 00000 n 
+0000021431 00000 n 
+0000021541 00000 n 
+0000022462 00000 n 
+0000022572 00000 n 
+0000023853 00000 n 
+0000023963 00000 n 
+0000025028 00000 n 
+0000025138 00000 n 
+0000025969 00000 n 
+0000026079 00000 n 
+0000027284 00000 n 
+0000027394 00000 n 
+0000027775 00000 n 
+0000027885 00000 n 
+0000029719 00000 n 
+0000029829 00000 n 
+0000030089 00000 n 
+0000030199 00000 n 
+0000031349 00000 n 
+0000031459 00000 n 
+0000032422 00000 n 
+0000032532 00000 n 
+0000033460 00000 n 
+0000033570 00000 n 
+0000034343 00000 n 
+0000034453 00000 n 
+0000035673 00000 n 
+0000035783 00000 n 
+0000036111 00000 n 
+0000036221 00000 n 
+0000037215 00000 n 
+0000037325 00000 n 
+0000037719 00000 n 
+0000037829 00000 n 
+0000038895 00000 n 
+0000039005 00000 n 
+0000039703 00000 n 
+0000039813 00000 n 
+0000041180 00000 n 
+0000041290 00000 n 
+0000042224 00000 n 
+0000042334 00000 n 
+0000043045 00000 n 
+0000043155 00000 n 
+0000044317 00000 n 
+0000044427 00000 n 
+0000044693 00000 n 
+0000044803 00000 n 
+0000045989 00000 n 
+0000046099 00000 n 
+0000047216 00000 n 
+0000047326 00000 n 
+0000048117 00000 n 
+0000048227 00000 n 
+0000048986 00000 n 
+0000049096 00000 n 
+0000049621 00000 n 
+0000049731 00000 n 
+0000051397 00000 n 
+0000051507 00000 n 
+0000051841 00000 n 
+0000051951 00000 n 
+0000053440 00000 n 
+0000053550 00000 n 
+0000054214 00000 n 
+0000054324 00000 n 
+0000056520 00000 n 
+0000056630 00000 n 
+0000057066 00000 n 
+0000057176 00000 n 
+0000057995 00000 n 
+0000058105 00000 n 
+0000058931 00000 n 
+0000059041 00000 n 
+0000059800 00000 n 
+0000059910 00000 n 
+0000061065 00000 n 
+0000061175 00000 n 
+0000062269 00000 n 
+0000062379 00000 n 
+0000063124 00000 n 
+0000063234 00000 n 
+0000064228 00000 n 
+0000064338 00000 n 
+0000064628 00000 n 
+0000064738 00000 n 
+0000066248 00000 n 
+0000066358 00000 n 
+0000066626 00000 n 
+0000066736 00000 n 
+0000068587 00000 n 
+0000068697 00000 n 
+0000069101 00000 n 
+0000069211 00000 n 
+0000070625 00000 n 
+0000070735 00000 n 
+0000071877 00000 n 
+0000072003 00000 n 
+0000072080 00000 n 
+0000072251 00000 n 
+0000072424 00000 n 
+0000072618 00000 n 
+0000072811 00000 n 
+0000073004 00000 n 
+0000073224 00000 n 
+0000073444 00000 n 
+0000073817 00000 n 
+0000092809 00000 n 
+0000092863 00000 n 
+0000073927 00000 n 
+0000092929 00000 n 
+0000074131 00000 n 
+0000074332 00000 n 
+0000074474 00000 n 
+0000074752 00000 n 
+0000074879 00000 n 
+0000075039 00000 n 
+0000075288 00000 n 
+0000075451 00000 n 
+0000075584 00000 n 
+0000075729 00000 n 
+0000076036 00000 n 
+0000076335 00000 n 
+0000076474 00000 n 
+0000076628 00000 n 
+0000076743 00000 n 
+0000077079 00000 n 
+0000077359 00000 n 
+0000077504 00000 n 
+0000077785 00000 n 
+0000092995 00000 n 
+0000077999 00000 n 
+0000078133 00000 n 
+0000078265 00000 n 
+0000078496 00000 n 
+0000078652 00000 n 
+0000078846 00000 n 
+0000078995 00000 n 
+0000079226 00000 n 
+0000079358 00000 n 
+0000079517 00000 n 
+0000079699 00000 n 
+0000079893 00000 n 
+0000080093 00000 n 
+0000080258 00000 n 
+0000080396 00000 n 
+0000080581 00000 n 
+0000080802 00000 n 
+0000081014 00000 n 
+0000081226 00000 n 
+0000081443 00000 n 
+0000081632 00000 n 
+0000081809 00000 n 
+0000082033 00000 n 
+0000082245 00000 n 
+0000082445 00000 n 
+0000082627 00000 n 
+0000082855 00000 n 
+0000083056 00000 n 
+0000083230 00000 n 
+0000083415 00000 n 
+0000083619 00000 n 
+0000083826 00000 n 
+0000083998 00000 n 
+0000084170 00000 n 
+0000084430 00000 n 
+0000084678 00000 n 
+0000084900 00000 n 
+0000085166 00000 n 
+0000085323 00000 n 
+0000085542 00000 n 
+0000085746 00000 n 
+0000086032 00000 n 
+0000086195 00000 n 
+0000086323 00000 n 
+0000086457 00000 n 
+0000086571 00000 n 
+0000086682 00000 n 
+0000086798 00000 n 
+0000086907 00000 n 
+0000087019 00000 n 
+0000087140 00000 n 
+0000087247 00000 n 
+trailer
+<<
+/Size 333
+/Root 2 0 R
+/Info 4 0 R
+>>
+startxref
+93064
+%%EOF

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/uffi.xml	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,24 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
+               "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [
+<!ENTITY % myents SYSTEM "entities.inc">
+<!ENTITY % xinclude SYSTEM "xinclude.mod">
+%myents;
+%xinclude;
+]>
+
+
+<book lang="en">
+  <xi:include href="bookinfo.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="preface.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="intro.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="notes.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_declare.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_primitive.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_aggregate.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_object.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_string.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="ref_func_libr.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="appendix.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+  <xi:include href="glossary.xml" xmlns:xi="http://www.w3.org/2001/XInclude" />
+</book>

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/xinclude.mod
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/doc/xinclude.mod	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,24 @@
+<!ELEMENT xi:include (xi:fallback?) >
+<!ATTLIST xi:include
+    xmlns:xi   CDATA       #FIXED    "http://www.w3.org/2001/XInclude"
+    href       CDATA       #REQUIRED
+    parse      (xml|text)  "xml"
+    encoding   CDATA       #IMPLIED >
+
+<!ELEMENT xi:fallback ANY>
+<!ATTLIST xi:fallback
+    xmlns:xi   CDATA   #FIXED   "http://www.w3.org/2001/XInclude" >
+
+<!ENTITY % local.book.class "| xi:include">
+
+<!-- inside book elements -->
+<!ENTITY % local.chapter.class "| xi:include">
+<!-- inside chapter or section elements -->
+<!ENTITY % local.divcomponent.mix "| xi:include">
+<!-- inside para, programlisting, literallayout, etc. -->   
+<!ENTITY % local.para.char.mix "| xi:include">
+<!-- inside bookinfo, chapterinfo, etc. -->      
+<!ENTITY % local.info.class "| xi:include">         
+
+<!-- used for xml:base in docbook 4.2 and prior -->
+<!ENTITY % local.common.attrib "xml:base  CDATA  #IMPLIED">

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,45 @@
+# FILE IDENTIFICATION
+#
+#  Name:         Makefile
+#  Purpose:      Makefile for UFFI examples
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile 10614 2005-07-06 01:05:14Z kevin $
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+#
+
+SUBDIRS:=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
+
+
+base=c-test-fns
+source=$(base).c
+object=$(base).o
+shared_lib=$(base).so
+
+.PHONY: all
+all: $(shared_lib)
+
+linux: $(source) Makefile
+	gcc -fPIC -DPIC -c $(source) -o $(object)
+	gcc -shared $(object) -o $(shared_lib)
+	rm $(object)
+
+mac:
+	cc -dynamic -c $(source) -o $(object)
+	ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $(base).dylib $(object)
+	ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib
+
+solaris:
+	cc -KPIC -c $(source) -o $(object)
+	cc -G $(object) -o $(shared_lib)
+
+aix-acl:
+	gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $(source)
+	make_shared -o $(shared_lib) $(object)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile.msvc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/Makefile.msvc	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,27 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile.msvc
+#  Purpose:      Makefile for the CLSQL UFFI helper package (MSVC)
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $
+#
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+BASE=c-test-fns
+
+# Nothing to configure beyond here
+
+SRC=$(BASE).c
+OBJ=$(BASE).obj
+DLL=$(BASE).dll
+
+$(DLL): $(SRC)
+	cl /MD /LD -D_MT /DWIN32=1 $(SRC)
+        del $(OBJ) $(BASE).exp
+
+clean:
+        del /q $(DLL)
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/acl-compat-tester.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/acl-compat-tester.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,600 @@
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by 
+;; the Free Software Foundation, as clarified by the Franz
+;; preamble to the LGPL found in
+;; http://opensource.franz.com/preamble.html.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License can be
+;; found at http://opensource.franz.com/license.html.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple
+;; Place, Suite 330, Boston, MA  02111-1307  USA
+;;
+;;;; from the original ACL 6.1 sources:
+;; $Id: acl-compat-tester.lisp 7061 2003-09-07 06:34:45Z kevin $
+
+
+(defpackage :util.test
+  (:use :common-lisp)
+  (:shadow #:test)
+  (:export
+;;;; Control variables:
+   #:*break-on-test-failures*
+   #:*error-protect-tests*
+   #:*test-errors*
+   #:*test-successes*
+   #:*test-unexpected-failures*
+
+;;;; The test macros:
+   #:test
+   #:test-error
+   #:test-no-error
+   #:test-warning
+   #:test-no-warning
+   
+   #:with-tests
+   ))
+
+(in-package :util.test)
+
+#+cmu
+(unless (find-class 'break nil)
+  (define-condition break (simple-condition) ()))
+
+(define-condition simple-break (error simple-condition) ())
+
+;; 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.
+
+(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 , at 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 , at 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) , at col) totalcol))))
+	     ((eq state :compl)
+	      (cond ((not (string-equal lookat "elseif"))
+		     (error "if*: missing elseif clause ")))
+	      (setq state :init)))))
+
+
+
+
+(defvar *break-on-test-failures* nil
+  "When a test failure occurs, common-lisp:break is called, allowing
+interactive debugging of the failure.")
+
+(defvar *test-errors* 0
+  "The value is the number of test errors which have occurred.")
+(defvar *test-successes* 0
+  "The value is the number of test successes which have occurred.")
+(defvar *test-unexpected-failures* 0
+  "The value is the number of unexpected test failures which have occurred.")
+
+(defvar *error-protect-tests* nil
+  "Protect each test from errors.  If an error occurs, then that will be
+taken as a test failure unless test-error is being used.")
+
+(defmacro test-values-errorset (form &optional announce catch-breaks)
+  ;; internal macro
+  (let ((g-announce (gensym))
+	(g-catch-breaks (gensym)))
+    `(let* ((,g-announce ,announce)
+	    (,g-catch-breaks ,catch-breaks))
+       (handler-case (cons t (multiple-value-list ,form))
+	 (condition (condition)
+	   (if* (and (null ,g-catch-breaks)
+		     (typep condition 'simple-break))
+	      then (break condition)
+	    elseif ,g-announce
+	      then (format *error-output* "~&Condition type: ~a~%"
+			   (class-of condition))
+		   (format *error-output* "~&Message: ~a~%" condition))
+	   condition)))))
+
+(defmacro test-values (form &optional announce catch-breaks)
+  ;; internal macro
+  (if* *error-protect-tests*
+     then `(test-values-errorset ,form ,announce ,catch-breaks)
+     else `(cons t (multiple-value-list ,form))))
+
+(defmacro test (expected-value test-form
+		&key (test #'eql test-given)
+		     (multiple-values nil multiple-values-given)
+		     (fail-info nil fail-info-given)
+		     (known-failure nil known-failure-given)
+
+;;;;;;;;;; internal, undocumented keywords:
+;;;; Note about these keywords: if they were documented, we'd have a
+;;;; problem, since they break the left-to-right order of evaluation.
+;;;; Specifically, errorset breaks it, and I don't see any way around
+;;;; that.  `errorset' is used by the old test.cl module (eg,
+;;;; test-equal-errorset).
+		     errorset
+		     reported-form
+		     (wanted-message nil wanted-message-given)
+		     (got-message nil got-message-given))
+  "Perform a single test.  `expected-value' is the reference value for the
+test.  `test-form' is a form that will produce the value to be compared to
+the expected-value.  If the values are not the same, then an error is
+logged, otherwise a success is logged.
+
+Normally the comparison of values is done with `eql'.  The `test' keyword
+argument can be used to specify other comparison functions, such as eq,
+equal,equalp, string=, string-equal, etc.
+
+Normally, only the first return value from the test-form is considered,
+however if `multiple-values' is t, then all values returned from test-form
+are considered.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  `(test-check
+    :expected-result ,expected-value
+    :test-results
+    (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
+    ,@(when test-given `(:predicate ,test))
+    ,@(when multiple-values-given `(:multiple-values ,multiple-values))
+    ,@(when fail-info-given `(:fail-info ,fail-info))
+    ,@(when known-failure-given `(:known-failure ,known-failure))
+    :test-form ',(if reported-form reported-form test-form)
+    ,@(when wanted-message-given `(:wanted-message ,wanted-message))
+    ,@(when got-message-given `(:got-message ,got-message))))
+
+(defmethod conditionp ((thing condition)) t)
+(defmethod conditionp ((thing t)) nil)
+
+(defmacro test-error (form &key announce
+				catch-breaks
+				(fail-info nil fail-info-given)
+				(known-failure nil known-failure-given)
+				(condition-type ''simple-error)
+				(include-subtypes nil include-subtypes-given)
+				(format-control nil format-control-given)
+				(format-arguments nil format-arguments-given))
+  "Test that `form' signals an error. The order of evaluation of the
+arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures.
+
+If `condition-type' is non-nil, it should be a symbol naming a condition
+type, which is used to check against the signalled condition type.  The
+test will fail if they do not match.
+
+`include-subtypes', used with `condition-type', can be used to match a
+condition to an entire subclass of the condition type hierarchy.
+
+`format-control' and `format-arguments' can be used to check the error
+message itself."
+  (let ((g-announce (gensym))
+	(g-catch-breaks (gensym))
+	(g-fail-info (gensym))
+	(g-known-failure (gensym))
+	(g-condition-type (gensym))
+	(g-include-subtypes (gensym))
+	(g-format-control (gensym))
+	(g-format-arguments (gensym))
+	(g-c (gensym)))
+    `(let* ((,g-announce ,announce)
+	    (,g-catch-breaks ,catch-breaks)
+	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+	    (,g-condition-type ,condition-type)
+	    ,@(when include-subtypes-given
+		`((,g-include-subtypes ,include-subtypes)))
+	    ,@(when format-control-given
+		`((,g-format-control ,format-control)))
+	    ,@(when format-arguments-given
+		`((,g-format-arguments ,format-arguments)))
+	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+       (test-check
+	:predicate #'eq
+	:expected-result t
+	:test-results
+	(test-values (and (conditionp ,g-c)
+			  ,@(if* include-subtypes-given
+			       then `((if* ,g-include-subtypes
+					 then (typep ,g-c ,g-condition-type)
+					 else (eq (class-of ,g-c)
+						  (find-class
+						   ,g-condition-type))))
+			       else `((eq (class-of ,g-c)
+					  (find-class ,g-condition-type))))
+			  ,@(when format-control-given
+			      `((or
+				 (null ,g-format-control)
+				 (string=
+				  (concatenate 'simple-string
+				    "~1@<" ,g-format-control "~:@>")
+				  (simple-condition-format-control ,g-c)))))
+			  ,@(when format-arguments-given
+			      `((or
+				 (null ,g-format-arguments)
+				 (equal
+				  ,g-format-arguments
+				  (simple-condition-format-arguments ,g-c))))))
+		     t)
+	:test-form ',form
+	,@(when fail-info-given `(:fail-info ,g-fail-info))
+	,@(when known-failure-given `(:known-failure ,g-known-failure))
+	:condition-type ,g-condition-type
+	:condition ,g-c
+	,@(when include-subtypes-given
+	    `(:include-subtypes ,g-include-subtypes))
+	,@(when format-control-given
+	    `(:format-control ,g-format-control))
+	,@(when format-arguments-given
+	    `(:format-arguments ,g-format-arguments))))))
+
+(defmacro test-no-error (form &key announce
+				   catch-breaks
+				   (fail-info nil fail-info-given)
+				   (known-failure nil known-failure-given))
+  "Test that `form' does not signal an error.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-announce (gensym))
+	(g-catch-breaks (gensym))
+	(g-fail-info (gensym))
+	(g-known-failure (gensym))
+	(g-c (gensym)))
+    `(let* ((,g-announce ,announce)
+	    (,g-catch-breaks ,catch-breaks)
+	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+       (test-check
+	:predicate #'eq
+	:expected-result t
+	:test-results (test-values (not (conditionp ,g-c)))
+	:test-form ',form
+	:condition ,g-c
+	,@(when fail-info-given `(:fail-info ,g-fail-info))
+	,@(when known-failure-given `(:known-failure ,g-known-failure))))))
+
+(defvar *warn-cookie* (cons nil nil))
+
+(defmacro test-warning (form &key fail-info known-failure)
+  "Test that `form' signals a warning.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-fail-info (gensym))
+	(g-known-failure (gensym))
+	(g-value (gensym)))
+    `(let* ((,g-fail-info ,fail-info)
+	    (,g-known-failure ,known-failure)
+	    (,g-value (test-values-errorset ,form nil t)))
+       (test
+	*warn-cookie*
+	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+	   then *warn-cookie*
+	   else ;; test produced no warning
+		nil)
+	:test #'eq
+	:reported-form ,form ;; quoted by test macro
+	:wanted-message "a warning"
+	:got-message "no warning"
+	:fail-info ,g-fail-info
+	:known-failure ,g-known-failure))))
+
+(defmacro test-no-warning (form &key fail-info known-failure)
+  "Test that `form' does not signal a warning.  The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure.  This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+  (let ((g-fail-info (gensym))
+	(g-known-failure (gensym))
+	(g-value (gensym)))
+    `(let* ((,g-fail-info ,fail-info)
+	    (,g-known-failure ,known-failure)
+	    (,g-value (test-values-errorset ,form nil t)))
+       (test
+	*warn-cookie*
+	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+	   then nil ;; test produced warning
+	   else *warn-cookie*)
+	:test #'eq
+	:reported-form ',form
+	:wanted-message "no warning"
+	:got-message "a warning"
+	:fail-info ,g-fail-info
+	:known-failure ,g-known-failure))))
+
+(defvar *announce-test* nil) ;; if true announce each test that was done
+
+(defmacro errorset (form &optional announce catch-breaks)
+  ;; Evaluate FORM, and if there are no errors and FORM returns
+  ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn.  If an
+  ;; error occurs while evaluating FORM, then return nil immediately.
+  ;; If ANNOUNCE is t, then the error message will be printed out.
+  (if catch-breaks
+      `(handler-case (values-list (cons t (multiple-value-list ,form)))
+         (error (condition)
+           (declare (ignorable condition))
+           ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+           nil)
+         (simple-break (condition)
+           (declare (ignorable condition))
+           ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
+)
+           nil))
+    `(handler-case (values-list (cons t (multiple-value-list ,form)))
+       (error (condition)
+         (declare (ignorable condition))
+         ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+         nil))))
+
+(defun test-check (&key (predicate #'eql)
+			expected-result test-results test-form
+			multiple-values fail-info known-failure
+			wanted-message got-message condition-type condition
+			include-subtypes format-control format-arguments
+		   &aux fail predicate-failed got wanted)
+  ;; for debugging large/complex test sets:
+  (when *announce-test*
+    (format t "Just did test ~s~%" test-form)
+    (force-output))
+  
+  ;; this is an internal function
+  (flet ((check (expected-result result)
+	   (let* ((results
+		   (multiple-value-list
+		    (errorset (funcall predicate expected-result result) t)))
+		  (failed (null (car results))))
+	     (if* failed
+		then (setq predicate-failed t)
+		     nil
+		else (cadr results)))))
+    (when (conditionp test-results)
+      (setq condition test-results)
+      (setq test-results nil))
+    (when (null (car test-results))
+      (setq fail t))
+    (if* (and (not fail) (not multiple-values))
+       then ;; should be a single result
+	    ;; expected-result is the single result wanted
+	    (when (not (and (cdr test-results)
+			    (check expected-result (cadr test-results))))
+	      (setq fail t))
+	    (when (and (not fail) (cddr test-results))
+	      (setq fail 'single-got-multiple))
+       else ;; multiple results wanted
+	    ;; expected-result is a list of results, each of which
+	    ;; should be checked against the corresponding test-results
+	    ;; using the predicate
+	    (do ((got (cdr test-results) (cdr got))
+		 (want expected-result (cdr want)))
+		((or (null got) (null want))
+		 (when (not (and (null want) (null got)))
+		   (setq fail t)))
+	      (when (not (check (car got) (car want)))
+		(return (setq fail t)))))
+    (if* fail
+       then (when (not known-failure)
+	      (format *error-output*
+		      "~& * * * UNEXPECTED TEST FAILURE * * *~%")
+	      (incf *test-unexpected-failures*))
+	    (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
+		    known-failure test-form)
+	    (if* (eq 'single-got-multiple fail)
+	       then (format
+		     *error-output*
+		     "~
+Reason: additional value were returned from test form.~%")
+	     elseif predicate-failed
+	       then (format *error-output* "Reason: predicate error.~%")
+	     elseif (null (car test-results))
+	       then (format *error-output* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
+			    (when condition (class-of condition)))
+	     elseif condition
+	       then (if* (not (conditionp condition))
+		       then (format *error-output* "~
+Reason: expected but did not detect an error of type `~s'.~%"
+				    condition-type)
+		     elseif (null condition-type)
+		       then (format *error-output* "~
+Reason: detected an unexpected error of type `~s':
+        ~a.~%"
+				    (class-of condition)
+				    condition)
+		     elseif (not (if* include-subtypes
+				    then (typep condition condition-type)
+				    else (eq (class-of condition)
+					     (find-class condition-type))))
+		       then (format *error-output* "~
+Reason: detected an incorrect condition type.~%")
+			    (format *error-output*
+				    "  wanted: ~s~%" condition-type)
+			    (format *error-output*
+				    "     got: ~s~%" (class-of condition))
+		     elseif (and format-control
+				 (not (string=
+				       (setq got
+					 (concatenate 'simple-string
+					   "~1@<" format-control "~:@>"))
+				       (setq wanted
+					 (simple-condition-format-control
+					  condition)))))
+		       then ;; format control doesn't match
+			    (format *error-output* "~
+Reason: the format-control was incorrect.~%")
+			    (format *error-output* "  wanted: ~s~%" wanted)
+			    (format *error-output* "     got: ~s~%" got)
+		     elseif (and format-arguments
+				 (not (equal
+				       (setq got format-arguments)
+				       (setq wanted
+					 (simple-condition-format-arguments
+					  condition)))))
+		       then (format *error-output* "~
+Reason: the format-arguments were incorrect.~%")
+			    (format *error-output* "  wanted: ~s~%" wanted)
+			    (format *error-output* "     got: ~s~%" got)
+		       else ;; what else????
+			    (error "internal-error"))
+	       else (let ((*print-length* 50)
+			  (*print-level* 10))
+		      (if* wanted-message
+			 then (format *error-output*
+				      "  wanted: ~a~%" wanted-message)
+			 else (if* (not multiple-values)
+				 then (format *error-output*
+					      "  wanted: ~s~%"
+					      expected-result)
+				 else (format
+				       *error-output*
+				       "  wanted values: ~{~s~^, ~}~%"
+				       expected-result)))
+		      (if* got-message
+			 then (format *error-output*
+				      "     got: ~a~%" got-message)
+			 else (if* (not multiple-values)
+				 then (format *error-output* "     got: ~s~%"
+				       (second test-results))
+				 else (format
+				       *error-output*
+				       "     got values: ~{~s~^, ~}~%"
+				       (cdr test-results))))))
+	    (when fail-info
+	      (format *error-output* "Additional info: ~a~%" fail-info))
+	    (incf *test-errors*)
+	    (when *break-on-test-failures*
+	      (break "~a is non-nil." '*break-on-test-failures*))
+       else (when known-failure
+	      (format *error-output*
+		      "~&Expected test failure for ~s did not occur.~%"
+		      test-form)
+	      (when fail-info
+		(format *error-output* "Additional info: ~a~%" fail-info))
+	      (setq fail t))
+	    (incf *test-successes*))
+    (not fail)))
+
+(defmacro with-tests ((&key (name "unnamed")) &body body)
+  (let ((g-name (gensym)))
+    `(flet ((doit () , at body))
+       (let ((,g-name ,name)
+	     (*test-errors* 0)
+	     (*test-successes* 0)
+	     (*test-unexpected-failures* 0))
+	 (format *error-output* "Begin ~a test~%" ,g-name)
+	 (if* *break-on-test-failures*
+	    then (doit)
+	    else (handler-case (doit)
+		   (error (c)
+		     (format
+		      *error-output*
+		      "~
+~&Test ~a aborted by signalling an uncaught error:~%~a~%"
+		      ,g-name c))))
+	 #+allegro
+	 (let ((state (sys:gsgc-switch :print)))
+	   (setf (sys:gsgc-switch :print) nil)
+	   (format t "~&**********************************~%" ,g-name)
+	   (format t "End ~a test~%" ,g-name)
+	   (format t "Errors detected in this test: ~s " *test-errors*)
+	   (unless (zerop *test-unexpected-failures*)
+	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+	   (format t "~%Successes this test:~s~%" *test-successes*)
+	   (setf (sys:gsgc-switch :print) state))
+	 #-allegro
+	 (progn
+	   (format t "~&**********************************~%" ,g-name)
+	   (format t "End ~a test~%" ,g-name)
+	   (format t "Errors detected in this test: ~s " *test-errors*)
+	   (unless (zerop *test-unexpected-failures*)
+	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+	   (format t "~%Successes this test:~s~%" *test-successes*))
+	 ))))
+
+(provide :tester #+module-versions 1.1)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/arrays.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/arrays.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,63 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          arrays.cl
+;;;; Purpose:       UFFI Example file to test arrays
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: arrays.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(uffi:def-foreign-type long-ptr (* :long))
+
+(defun test-array-1d ()
+  "Tests vector"
+  (let ((a (uffi:allocate-foreign-object :long +column-length+)))
+    (dotimes (i +column-length+)
+      (setf (uffi:deref-array a '(:array :long) i) (* i i)))
+    (dotimes (i +column-length+)
+      (format t "~&~D => ~D" i (uffi:deref-array a '(:array :long) i)))
+    (uffi:free-foreign-object a))
+  (values))
+
+(defun test-array-2d ()
+  "Tests 2d array"
+  (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+)))
+    (dotimes (r +row-length+)
+      (declare (fixnum r))
+      (setf (uffi:deref-array a '(:array (* :long)) r)
+	    (uffi:allocate-foreign-object :long +column-length+))
+      (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+	(dotimes (c +column-length+)
+	  (declare (fixnum c))
+	  (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+
+    (dotimes (r +row-length+)
+      (declare (fixnum r))
+      (format t "~&Row ~D: " r)
+      (let ((col (uffi:deref-array a '(:array (* :long)) r)))
+	(dotimes (c +column-length+)
+	  (declare (fixnum c))
+	  (let ((result (uffi:deref-array col '(:array :long) c)))
+	    (format t "~d " result)))))
+
+    (uffi:free-foreign-object a))
+  (values))
+
+#+examples-uffi
+(test-array-1d)
+
+#+examples-uffi
+(test-array-2d)
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/atoifl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/atoifl.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,56 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          atoifl.cl
+;;;; Purpose:       UFFI Example file to atoi/atof/atol
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: atoifl.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-function ("atoi" c-atoi) 
+    ((str :cstring))
+  :returning :int)
+
+(uffi:def-function ("atol" c-atol) 
+    ((str :cstring))
+  :returning :long)
+
+(uffi:def-function ("atof" c-atof) 
+    ((str :cstring))
+  :returning :double)
+
+(defun atoi (str)
+  "Returns a int from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atoi str-cstring)))
+
+(defun atof (str)
+  "Returns a double float from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atof str-cstring)))
+  
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+	   (format t "~&(atoi ~S) => ~S" str (atoi str))))
+    (print-results "55")))
+
+
+#+test-uffi
+(progn
+  (util.test:test (atoi "123") 123 :test #'eql
+		  :fail-info "Error with atoi")
+  (util.test:test (atoi "") 0 :test #'eql
+		  :fail-info "Error with atoi")
+  (util.test:test (atof "2.23") 2.23d0 :test #'eql
+		  :fail-info "Error with atof")
+  )
+  

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.c
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.c	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,91 @@
+/***************************************************************************
+ * FILE IDENTIFICATION
+ *  
+ *  Name:         c-test-fns.c
+ *  Purpose:      Test functions in C for UFFI library
+ *  Programer:    Kevin M. Rosenberg
+ *  Date Started: Mar 2002
+ *
+ *  CVS Id:   $Id: c-test-fns.c 10614 2005-07-06 01:05:14Z kevin $
+ *
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+ *
+ * These variables are correct for GCC
+ * you'll need to modify these for other compilers
+ ***************************************************************************/
+
+#ifdef WIN32
+#include <windows.h>
+
+BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll,
+                          DWORD fdwReason,
+                          LPVOID lpvReserved)
+{
+        return 1;
+}
+       
+#define DLLEXPORT __declspec(dllexport)
+
+#else
+#define DLLEXPORT 
+#endif
+
+#include <ctype.h>
+#include <stdlib.h>
+#include <math.h>
+
+
+/* Test of constant input string */
+DLLEXPORT
+int
+cs_count_upper (char* psz)
+{
+  int count = 0;
+
+  if (psz) {
+    while (*psz) {
+      if (isupper (*psz))
+	++count;
+      ++psz;
+    }
+    return count;
+  } else 
+    return -1;
+}
+
+/* Test of input and output of a string */
+DLLEXPORT
+void
+cs_to_upper (char* psz)
+{
+  if (psz) {
+    while (*psz) {
+      *psz = toupper (*psz);
+      ++psz;
+    }
+  }
+}
+
+/* Test of an output only string */
+DLLEXPORT
+void
+cs_make_random (int size, char* buffer)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    buffer[i] = 'A' + (rand() % 26);
+}
+
+    
+/* Test of input/output vector */
+DLLEXPORT
+void
+half_double_vector (int size, double* vec)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    vec[i] /= 2.;
+}
+
+    
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/c-test-fns.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,118 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          c-test-fns.cl
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: c-test-fns.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(unless (uffi:load-foreign-library 
+	 (uffi:find-foreign-library "c-test-fns" 
+				    (list *load-truename* "/home/kevin/debian/src/uffi/examples/"))
+	 :supporting-libraries '("c"))
+  (warn "Unable to load c-test-fns library"))
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+  ((input (* :unsigned-char)))
+  :returning :void
+  )
+
+(defun string-to-upper (str)
+  (uffi:with-foreign-string (str-foreign str)
+    (cs-to-upper str-foreign)
+    (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+  ((input :cstring))
+  :returning :int
+  )
+
+(defun string-count-upper (str)
+  (uffi:with-cstring (str-cstring str)
+    (cs-count-upper str-cstring)))
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+    ((size :int)
+     (vec (* :double)))
+  :returning :void)
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+  (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+	results)
+    (dotimes (i +double-vec-length+)
+      (setf (uffi:deref-array vec '(:array :double) i) 
+	    (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    (dotimes (i +double-vec-length+)
+      (push (uffi:deref-array vec '(:array :double) i) results))
+    (uffi:free-foreign-object vec)
+    (nreverse results)))
+
+(defun t2 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    vec))
+
+#+(or cmu scl)
+(defun t3 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (system:without-gcing
+     (half-double-vector +double-vec-length+ (system:vector-sap vec)))
+    vec))
+    
+#+examples-uffi
+(format t "~&(string-to-upper \"this is a test\") => ~A" 
+	(string-to-upper "this is a test"))
+
+#+examples-uffi
+(format t "~&(string-to-upper nil) => ~A" 
+	(string-to-upper nil))
+
+#+examples-uffi
+(format t "~&(string-count-upper \"This is a Test\") => ~A" 
+	(string-count-upper "This is a Test"))
+
+#+examples-uffi
+(format t "~&(string-count-upper nil) => ~A" 
+	(string-count-upper nil))
+
+#+examples-uffi
+(format t "~&Half vector: ~S" (test-half-double-vector))
+
+
+
+#+test-uffi
+(progn
+  (util.test:test (string= (string-to-upper "this is a test") "THIS IS A TEST")
+                  t
+		  :test #'eql
+		  :fail-info "Error with string-to-upper")
+  (util.test:test (string-to-upper nil) nil
+		  :fail-info "string-to-upper with nil failed")
+  (util.test:test (string-count-upper "This is a Test")
+		  2
+		  :test #'eql
+		  :fail-info "Error with string-count-upper")
+  (util.test:test (string-count-upper nil) -1
+		  :test #'eql
+		  :fail-info "string-count-upper with nil failed")
+
+  (util.test:test (test-half-double-vector)
+		  '(0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0)
+		  :test #'equal
+		  :fail-info "Error comparing half-double-vector")
+  )

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/compress.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/compress.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,116 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          compress.cl
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: compress.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(eval-when (:load-toplevel :execute)
+  (unless (uffi:load-foreign-library
+	   #-(or macosx darwin)
+	   (uffi:find-foreign-library
+	    "libz"
+	    '("/usr/local/lib/" "/usr/lib/" "/zlib/")
+	    :types '("so" "a"))
+	   #+(or macosx darwin)
+	   (uffi:find-foreign-library "z"
+				      `(,(pathname-directory *load-pathname*)))
+	   :module "zlib" 
+	   :supporting-libraries '("c"))
+    (warn "Unable to load zlib")))
+  
+(uffi:def-function ("compress" c-compress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+  
+(defun compress (source)
+  "Returns two values: array of bytes containing the compressed data
+ and the numbe of compressed bytes"
+  (let* ((sourcelen (length source))
+	 (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+	 (dest (uffi:allocate-foreign-string destsize :unsigned t))
+	 (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-compress dest destlen source-native sourcelen))
+	    (newdestlen (uffi:deref-pointer destlen :long)))
+	(unwind-protect
+	    (if (zerop result)
+		(values (uffi:convert-from-foreign-string 
+			 dest
+			 :length newdestlen
+			 :null-terminated-p nil)
+			newdestlen)
+	      (error "zlib error, code ~D" result))
+	  (progn
+	    (uffi:free-foreign-object destlen)
+	    (uffi:free-foreign-object dest)))))))
+
+(uffi:def-function ("uncompress" c-uncompress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun uncompress (source)
+  (let* ((sourcelen (length source))
+	 (destsize 200000)  ;adjust as needed
+	 (dest (uffi:allocate-foreign-string destsize :unsigned t))
+	 (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-uncompress dest destlen source-native sourcelen))
+	    (newdestlen (uffi:deref-pointer destlen :long)))
+	(unwind-protect
+	     (if (zerop result)
+		 (uffi:convert-from-foreign-string 
+		  dest
+		  :length newdestlen
+		  :null-terminated-p nil)
+		 (error "zlib error, code ~D" result))
+	  (progn
+	    (uffi:free-foreign-object destlen)
+	    (uffi:free-foreign-object dest)))))))
+
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+	   (multiple-value-bind (compressed len) (compress str)
+	     (let ((*print-length* nil))
+	       (format t "~&(compress ~S) => " str)
+	       (format t "~S~%" (map 'list #'char-code compressed))))))
+    (print-results "")
+    (print-results "test")
+    (print-results "test2")))
+
+#+test-uffi
+(progn
+  (flet ((test-compress (str)
+	   (multiple-value-bind (compressed len) (compress str)
+	     (multiple-value-bind (uncompressed len2) (uncompress compressed)
+	       (util.test:test str uncompressed :test #'string=
+			       :fail-info "Error uncompressing a compressed string")))))
+    (test-compress "")
+    (test-compress "test")
+    (test-compress "test2")))
+
+;; Results of the above on my system:
+;; (compress "") => 789c300001,8
+;; (compress "test") => 789c2b492d2e1045d1c1,12
+;; (compress "test2") => 789c2b492d2e31206501f3,13

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/file-socket.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/file-socket.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,39 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          file-socket.cl
+;;;; Purpose:       UFFI Example file to get a socket on a file
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Jul 2002
+;;;;
+;;;; $Id: file-socket.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;; Values for linux
+(uffi:def-constant PF_UNIX 1)
+(uffi:def-constant SOCK_STREAM 1)
+
+(uffi:def-function ("socket" c-socket)
+    ((family :int)
+     (type :int)
+     (protocol :int))
+    :returning :int)
+
+(uffi:def-function ("connect" c-connect)
+    ((sockfd :int)
+     (serv-addr :void-pointer)
+     (addr-len :int))
+    :returning :int)
+		  
+(defun connect-to-file-socket (filename)
+  (let ((socket (c-socket PF_UNIX SOCK_STREAM 0)))
+    (if (plusp socket)
+	(let ((stream (c-connect socket filename (length filename))))
+	  stream)
+      (error "Unable to create socket"))))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getenv.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,44 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv.cl
+;;;; Purpose:       UFFI Example file to get environment variable
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: getenv.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function ("getenv" c-getenv) 
+    ((name :cstring))
+  :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+    
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+	   (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+    (print-results "USER")
+    (print-results "_FOO_")))
+
+
+#+test-uffi
+(progn
+  (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
+  (util.test:test (and (stringp (my-getenv "USER"))
+		       (< 0 (length (my-getenv "USER"))))
+		  t :fail-info "Error retrieving getenv")
+)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gethostname.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gethostname.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,63 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gethostname.cl
+;;;; Purpose:       UFFI Example file to get hostname of system
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: gethostname.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(uffi:def-function ("gethostname" c-gethostname) 
+    ((name (* :unsigned-char))
+     (len :int))
+  :returning :int)
+
+(defun gethostname ()
+  "Returns the hostname"
+  (let* ((name (uffi:allocate-foreign-string 256))
+	 (result-code (c-gethostname name 256))
+	 (hostname (when (zerop result-code)
+		     (uffi:convert-from-foreign-string name))))
+    (uffi:free-foreign-object name)
+    (unless (zerop result-code)
+      (error "gethostname() failed."))
+    hostname))
+
+(defun gethostname2 ()
+  "Returns the hostname"
+  (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+    (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+	(uffi:convert-from-foreign-string name)
+	(error "gethostname() failed."))))
+
+#+examples-uffi
+(progn
+  (format t "~&Hostname (technique 1): ~A" (gethostname))
+  (format t "~&Hostname (technique 2): ~A" (gethostname2)))
+
+#+test-uffi
+(progn
+  (let ((hostname1 (gethostname))
+	(hostname2 (gethostname2)))
+    
+    (util.test:test (and (stringp hostname1) (stringp hostname2)) t
+		    :fail-info "gethostname not string")
+    (util.test:test (and (not (zerop (length hostname1)))
+			 (not (zerop (length hostname2)))) t
+			 :fail-info "gethostname length 0")
+    (util.test:test (string= hostname1 hostname1) t
+		    :fail-info "gethostname techniques don't match"))
+  )
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getshells.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/getshells.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,44 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getshells.cl
+;;;; Purpose:       UFFI Example file to get lisp of legal shells
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: getshells.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+
+(uffi:def-function "setusershell"
+    nil
+  :returning :void)
+
+(uffi:def-function "endusershell"
+    nil
+  :returning :void)
+
+(uffi:def-function "getusershell"
+    nil
+  :returning :cstring)
+
+(defun getshells ()
+  "Returns list of valid shells"
+  (setusershell)
+  (let (shells)
+    (do ((shell (uffi:convert-from-cstring (getusershell))
+                (uffi:convert-from-cstring (getusershell))))
+	((null shell))
+      (push shell shells))
+    (endusershell)
+    (nreverse shells)))
+
+#+examples-uffi
+(format t "~&Shells: ~S" (getshells))
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gettime.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/gettime.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,73 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gettime
+;;;; Purpose:       UFFI Example file to get time, use C structures
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: gettime.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+    (sec :int)
+  (min :int)
+  (hour :int)
+  (mday :int)
+  (mon :int)
+  (year :int)
+  (wday :int)
+  (yday :int)
+  (isdst :int))
+
+(uffi:def-function ("time" c-time) 
+    ((time (* time-t)))
+  :returning time-t)
+
+(uffi:def-function ("localtime" c-localtime)
+    ((time (* time-t)))
+  :returning (* tm))
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (* tm))
+
+(defun gettime ()
+   "Returns the local time"
+   (uffi:with-foreign-object (time 'time-t)
+;;     (declare (type time-t time))
+     (c-time time)
+     (let ((tm-ptr (the tm-pointer (c-localtime time))))
+       (declare (type tm-pointer tm-ptr))
+       (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" 
+				  (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+				  (uffi:get-slot-value tm-ptr 'tm 'mday)
+				  (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+				  (uffi:get-slot-value tm-ptr 'tm 'hour)
+				  (uffi:get-slot-value tm-ptr 'tm 'min)
+				  (uffi:get-slot-value tm-ptr 'tm 'sec)
+				  )))
+	 time-string))))
+
+
+
+
+#+examples-uffi
+(format t "~&~A" (gettime))
+
+#+test-uffi
+(progn
+  (let ((time (gettime)))
+    (util.test:test (stringp time) t :fail-info "Time is not a string")
+    (util.test:test (plusp (parse-integer time :junk-allowed t))
+		    t
+		    :fail-info "time string does not start with a number")))
+
+		    

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/run-examples.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/run-examples.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,36 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          run-examples.cl
+;;;; Purpose:       Load and execute all examples for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: run-examples.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(pushnew :examples-uffi cl:*features*)
+
+(flet ((load-test (name)
+	  (load (make-pathname :defaults *load-truename* :name name))))
+  (load-test "c-test-fns")
+  (load-test "arrays")
+  (load-test "union")
+  (load-test "strtol")
+  (load-test "atoifl")
+  (load-test "gettime")
+  (load-test "getenv")
+  (load-test "gethostname")
+  (load-test "getshells")
+  (load-test "compress"))
+
+(setq cl:*features* (remove :examples-uffi cl:*features*))
+
+
+      

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/strtol.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/strtol.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,80 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strtol.cl
+;;;; Purpose:       UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: strtol.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-foreign-type char-ptr (* :unsigned-char))
+  
+;; This example does not use :cstring to pass the input string since
+;; the routine needs to do pointer arithmetic to see how many characters
+;; were parsed
+
+(uffi:def-function ("strtol" c-strtol) 
+    ((nptr char-ptr)
+     (endptr (* char-ptr))
+     (base :int))
+  :returning :long)
+
+(defun strtol (str &optional (base 10))
+  "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+their was no string at all, or an integer indicating position in string
+of first non-valid character"
+  (let* ((str-native (uffi:convert-to-foreign-string str))
+	 (endptr (uffi:allocate-foreign-object 'char-ptr))
+	 (value (c-strtol str-native endptr base))
+	 (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+
+    (unwind-protect
+	 (if (uffi:null-pointer-p endptr-value)
+	     (values value t)
+	     (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+		   (chars-parsed (- (uffi:pointer-address endptr-value)
+				    (uffi:pointer-address str-native))))
+	       (cond
+		 ((zerop chars-parsed)
+		  (values nil nil))
+		 ((uffi:null-char-p next-char-value)
+		  (values value t))
+		 (t
+		  (values value chars-parsed)))))
+      (progn
+	(uffi:free-foreign-object str-native)
+	(uffi:free-foreign-object endptr)))))
+
+ 
+  
+#+examples-uffi
+(progn
+  (flet ((print-results (str)
+	   (multiple-value-bind (result flag) (strtol str)
+	     (format t "~&(strtol ~S) => ~S,~S" str result flag))))
+    (print-results "55")
+    (print-results "55.3")
+    (print-results "a")))
+
+#+test-uffi
+(progn
+  (flet ((test-strtol (str results)
+	   (util.test:test (multiple-value-list (strtol str)) results
+			   :test #'equal
+			   :fail-info "Error testing strtol")))
+    (test-strtol "123" '(123 t))
+    (test-strtol "0" '(0 t))
+    (test-strtol "55a" '(55 2))
+    (test-strtol "a" '(nil nil))))
+
+			   
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/test-examples.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/test-examples.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,40 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          test-examples.cl
+;;;; Purpose:       Load and execute all examples for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: test-examples.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+#-uffi (asdf:oos 'asdf:load-op :uffi)
+
+(unless (ignore-errors (find-package :util.test))
+  (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*)))
+
+(defun do-tests ()
+  (pushnew :test-uffi cl:*features*)
+  (util.test:with-tests (:name "UFFI-Tests")
+    (setq util.test:*break-on-test-failures* nil)
+    (flet ((load-test (name)
+		      (load (make-pathname :name name :defaults *load-truename*))))
+      (load-test "c-test-fns")
+      (load-test "arrays")
+      (load-test "union")
+      (load-test "strtol")
+      (load-test "atoifl")
+      (load-test "gettime")
+      (load-test "getenv")
+      (load-test "gethostname")
+      (load-test "getshells")
+      (load-test "compress"))
+    (setq cl:*features* (remove :test-uffi cl:*features*))))
+
+(do-tests)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/union.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/examples/union.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,86 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          union.cl
+;;;; Purpose:       UFFI Example file to test unions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: union.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(uffi:def-union tunion1 
+    (char :char)
+  (int :int)
+  (uint :unsigned-int)
+  (sf :float)
+  (df :double))
+
+(defun run-union-1 ()
+  (let ((u (uffi:allocate-foreign-object 'tunion1)))
+    (setf (uffi:get-slot-value u 'tunion1 'uint)
+      ;; little endian
+      #-(or sparc sparc-v9 powerpc ppc big-endian)
+      (+ (* 1 (char-code #\A))
+	 (* 256 (char-code #\B))
+	 (* 65536 (char-code #\C))
+	 (* 16777216 255))
+      ;; big endian
+      #+(or sparc sparc-v9 powerpc ppc big-endian)
+      (+ (* 16777216 (char-code #\A))
+	 (* 65536 (char-code #\B))
+	 (* 256 (char-code #\C))
+	 (* 1 255)))
+    (format *standard-output* "~&Should be #\A: ~S" 
+	    (uffi:ensure-char-character 
+	     (uffi:get-slot-value u 'tunion1 'char)))
+;;    (format *standard-output* "~&Should be negative number: ~D" 
+;;	    (uffi:get-slot-value u 'tunion1 'int))
+    (format *standard-output* "~&Should be positive number: ~D"
+	    (uffi:get-slot-value u 'tunion1 'uint))
+    (uffi:free-foreign-object u))
+  (values))
+
+#+test-uffi
+(defun test-union-1 ()
+  (let ((u (uffi:allocate-foreign-object 'tunion1)))
+    (setf (uffi:get-slot-value u 'tunion1 'uint)
+	  #-(or sparc sparc-v9 powerpc ppc)
+	  (+ (* 1 (char-code #\A))
+	     (* 256 (char-code #\B))
+	     (* 65536 (char-code #\C))
+	     (* 16777216 128))
+	  #+(or sparc sparc-v9 powerpc ppc)
+	  (+ (* 16777216 (char-code #\A))
+	     (* 65536 (char-code #\B))
+	     (* 256 (char-code #\C))
+	     (* 1 128))) ;set signed bit
+    (util.test:test (uffi:ensure-char-character 
+		(uffi:get-slot-value u 'tunion1 'char))
+	       #\A
+	       :test #'eql
+	       :fail-info "Error with union character")
+    #-(or sparc sparc-v9 openmcl digitool)
+;;    (util.test:test (> 0 (uffi:get-slot-value u 'tunion1 'int))
+;;	       t
+;;	       :fail-info
+;;	       "Error with negative int in union")
+    (util.test:test (plusp (uffi:get-slot-value u 'tunion1 'uint))
+	       t
+	       :fail-info
+	       "Error with unsigned int in union")
+    (uffi:free-foreign-object u))
+  (values))
+
+#+examples-uffi
+(run-union-1)
+
+
+#+test-uffi
+(test-union-1)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,6 @@
+SUBDIRS		:= 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,262 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          aggregates.lisp
+;;;; Purpose:       UFFI source to handle aggregate types
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: aggregates.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defmacro def-enum (enum-name args &key (separator-string "#"))
+  "Creates a constants for a C type enum list, symbols are created
+in the created in the current package. The symbol is the concatenation
+of the enum-name name, separator-string, and field-name"
+  (let ((counter 0)
+	(cmds nil)
+	(constants nil))
+    (declare (fixnum counter))
+    (dolist (arg args)
+      (let ((name (if (listp arg) (car arg) arg))
+	    (value (if (listp arg) 
+		       (prog1
+			   (setq counter (cadr arg))
+			 (incf counter))
+		     (prog1 
+			 counter
+		       (incf counter)))))
+	(setq name (intern (concatenate 'string
+			     (symbol-name enum-name)
+			     separator-string
+			     (symbol-name name))))
+	(push `(uffi:def-constant ,name ,value) constants)))
+    (setf cmds (append '(progn)
+		       #+allegro `((ff:def-foreign-type ,enum-name :int))
+		       #+lispworks `((fli:define-c-typedef ,enum-name :int))
+		       #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
+		       #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
+                       #+digitool `((def-mcl-type ,enum-name :integer))
+                       #+openmcl `((ccl::def-foreign-type ,enum-name :int))
+		       (nreverse constants)))
+    cmds))
+
+
+(defmacro def-array-pointer (name-array type)
+  #+allegro
+  `(ff:def-foreign-type ,name-array 
+    (:array ,(convert-from-uffi-type type :array)))
+  #+lispworks
+  `(fli:define-c-typedef ,name-array
+    (:c-array ,(convert-from-uffi-type type :array)))
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name-array 
+    (* ,(convert-from-uffi-type type :array)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name-array 
+    (* ,(convert-from-uffi-type type :array)))
+  #+digitool
+  `(def-mcl-type ,name-array '(:array ,type))
+  #+openmcl
+  `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
+  )
+
+(defun process-struct-fields (name fields &optional (variant nil))
+  (let (processed)
+    (dolist (field fields)
+      (let* ((field-name (car field))
+	     (type (cadr field))
+	     (def (append (list field-name)
+			  (if (eq type :pointer-self)
+			      #+(or cmu scl) `((* (alien:struct ,name)))
+			      #+sbcl `((* (sb-alien:struct ,name)))
+			      #+(or openmcl digitool) `((:* (:struct ,name)))
+			      #+lispworks `((:pointer ,name))
+			      #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
+			      `(,(convert-from-uffi-type type :struct))))))
+	(if variant
+	    (push (list def) processed)
+	  (push def processed))))
+    (nreverse processed)))
+	
+	    
+(defmacro def-struct (name &rest fields)
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
+  #+allegro
+  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+  #+lispworks
+  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+  #+digitool
+  `(ccl:defrecord ,name ,@(process-struct-fields name fields))
+  #+openmcl
+  `(ccl::def-foreign-type
+    nil 
+    (:struct ,name ,@(process-struct-fields name fields)))
+  )
+
+
+(defmacro get-slot-value (obj type slot)
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
+  #+allegro
+  `(ff:fslot-value-typed ,type :c ,obj ,slot)
+  #+lispworks
+  `(fli:foreign-slot-value ,obj ,slot)
+  #+(or cmu scl)
+  `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
+  #+(or openmcl digitool)
+  `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
+  )
+
+#+(or openmcl digitool)
+(defmacro set-slot-value (obj type slot value) ;use setf to set values
+  `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
+
+#+(or openmcl digitool)
+(defsetf get-slot-value set-slot-value)
+
+
+(defmacro get-slot-pointer (obj type slot)
+  #+(or lispworks cmu sbcl scl) (declare (ignore type))
+  #+allegro
+  `(ff:fslot-value-typed ,type :c ,obj ,slot)
+  #+lispworks
+  `(fli:foreign-slot-pointer ,obj ,slot)
+  #+(or cmu scl)
+  `(alien:slot ,obj ,slot)
+  #+sbcl
+  `(sb-alien:slot ,obj ,slot)
+  #+digitool
+  `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
+  #+openmcl
+  `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
+     (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))  
+)
+
+;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
+;; below
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; so we could allow '(:array :long) or deref with other type like :long only
+  #+(or openmcl digitool)
+  (defun array-type (type)
+    (let ((result type))
+      (when (listp type)
+	(let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
+	  (when (and (listp type-list) (eq (car type-list) :array))
+	    (setf result (cadr type-list)))))
+      result))
+  
+  
+  (defmacro deref-array (obj type i)
+    "Returns a field from a row"
+    #+(or lispworks cmu sbcl scl) (declare (ignore type))
+    #+(or cmu scl)  `(alien:deref ,obj ,i)
+    #+sbcl `(sb-alien:deref ,obj ,i)
+    #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
+    #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
+    #+openmcl
+    (let* ((array-type (array-type type))
+	   (local-type (convert-from-uffi-type array-type :allocation))
+	   (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
+      (ccl::%foreign-access-form
+       obj
+       (ccl::%foreign-type-or-record local-type)
+       `(* ,i ,element-size-in-bits)
+       nil))
+    #+digitool
+    (let* ((array-type (array-type type))
+	   (local-type (convert-from-uffi-type array-type :allocation))
+	   (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
+      `(,accessor
+	,obj
+	(* (the fixnum ,i) ,(size-of-foreign-type local-type))))
+    ))
+  
+; this expands to the %set-xx functions which has different params than %put-xx
+#+digitool
+(defmacro deref-array-set (obj type i value)
+  (let* ((array-type (array-type type))
+         (local-type (convert-from-uffi-type array-type :allocation))
+         (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
+         (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
+    `(,settor 
+      ,obj
+      (* (the fixnum ,i) ,(size-of-foreign-type local-type)) 
+      ,value)))
+
+#+digitool
+(defsetf deref-array deref-array-set)
+
+(defmacro def-union (name &rest fields)
+  #+allegro
+  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+  #+lispworks
+  `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+  #+(or cmu scl)
+  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+  #+sbcl
+  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
+  #+digitool
+  `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+  #+openmcl
+  `(ccl::def-foreign-type nil 
+			  (:union ,name ,@(process-struct-fields name fields)))
+)
+
+
+#-(or sbcl cmu)
+(defun convert-from-foreign-usb8 (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+	   (fixnum len))
+  (let ((a (make-array len :element-type '(unsigned-byte 8))))
+    (dotimes (i len a)
+      (declare (fixnum i))
+      (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb-ext:without-package-locks
+      (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+				   (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
+				   (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
+    (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+					  (* sb-vm:vector-data-offset sb-vm:n-word-bits)
+					  0))
+    (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+					      sb-vm:n-byte-bits
+					      1))))
+  
+
+#+sbcl
+(defun convert-from-foreign-usb8 (s len)
+  (let ((sap (sb-alien:alien-sap s)))
+    (declare (type sb-sys:system-area-pointer sap))
+    (locally
+     (declare (optimize (speed 3) (safety 0)))
+     (let ((result (make-array len :element-type '(unsigned-byte 8))))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+		(* len +system-copy-multiplier+))
+       result))))
+
+#+cmu
+(defun convert-from-foreign-usb8 (s len)
+  (let ((sap (alien:alien-sap s)))
+    (declare (type system:system-area-pointer sap))
+    (locally
+	(declare (optimize (speed 3) (safety 0)))
+      (let ((result (make-array len :element-type '(unsigned-byte 8))))
+	(kernel:copy-from-system-area sap 0
+				      result (* vm:vector-data-offset
+						vm:word-bits)
+				      (* len vm:byte-bits))
+	result))))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/corman-notes.txt
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/corman-notes.txt	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,17 @@
+some notes:
+  we need the :pascal (:stdcall) calling conventions for 
+  (def-function names args &key module returning calling-convention)
+  so I added this. calling-convention defaults to :cdecl
+  but on win32 we mostly use :stdcall
+
+  #+corman is invalid, #+cormanlisp instead
+
+  cormanlisp doesn't need to load and register the dll, since the underlying 
+  LoadLibrary() call does this. we need the module keyword for def-function
+instead.
+  (should probably default to kernel32.dll)
+  I'll think about library.cl, but we'll need more real-world win32 examples. 
+  (ideally the complete winapi :)
+  I also have to look at valentina.
+
+patch -p0 < corman.diff

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/getenv-ccl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/corman/getenv-ccl.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,81 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv-ccl.cl
+;;;; Purpose:       cormanlisp version
+;;;; Programmer:    "Joe Marshall" <prunesquallor at attbi.com>
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: getenv-ccl.lisp 10614 2005-07-06 01:05:14Z kevin $
+;;;;
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+(ct:defun-dll c-getenv ((lpname LPSTR)
+			(lpbuffer LPSTR)
+			(nsize LPDWORD))
+  :library-name "kernel32.dll"
+  :return-type DWORD
+  :entry-name "GetEnvironmentVariableA"
+  :linkage-type :pascal)
+
+(defun getenv (name)
+  (let ((nsizebuf (ct:malloc (sizeof :long)))
+        (buffer (ct:malloc 1))
+        (cname (ct:lisp-string-to-c-string name)))
+    (setf (ct:cref lpdword nsizebuf 0) 0)
+    (let* ((needed-size (c-getenv cname buffer nsizebuf))
+           (buffer1 (ct:malloc (1+ needed-size))))
+      (setf (ct:cref lpdword nsizebuf 0) needed-size)
+      (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf)) 
+                 nil
+               (ct:c-string-to-lisp-string buffer1))
+        (ct:free buffer1)
+        (ct:free nsizebuf)))))
+
+(defun cl:user-homedir-pathname (&optional host)
+  (cond ((or (stringp host)
+             (and (consp host)
+                  (every #'stringp host))) nil)
+        ((or (eq host :unspecific)
+             (null host))
+         (let ((homedrive (getenv "HOMEDRIVE"))
+               (homepath  (getenv "HOMEPATH")))
+           (parse-namestring
+             (if (and (stringp homedrive)
+                      (stringp homepath)
+                      (= (length homedrive) 2)
+                      (> (length homepath) 0))
+                 (concatenate 'string homedrive homepath "\\")
+                 "C:\\"))))
+        (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
+
+;|
+(uffi:def-function ("getenv" c-getenv) 
+    ((name :cstring))
+  :returning :cstring)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+    
+#examples-uffi
+(progn
+  (flet ((print-results (str)
+	   (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
+    (print-results "USER")
+    (print-results "_FOO_")))
+
+
+#test-uffi
+(progn
+  (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
+  (util.test:test (and (stringp (my-getenv "USER"))
+		       (< 0 (length (my-getenv "USER"))))
+		  t :fail-info "Error retrieving getenv")
+)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/functions.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/functions.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,239 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          function.lisp
+;;;; Purpose:       UFFI source to C function definitions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: functions.lisp 11615 2007-04-13 05:49:01Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defun process-function-args (args)
+  (if (null args)
+      #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
+      #+allegro '(:void)
+      #+openmcl (values nil nil)
+
+      ;; args not null
+      #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
+      (let (processed)
+	(dolist (arg args)
+	  (push (process-one-function-arg arg) processed))
+	(nreverse processed))
+      #+openmcl
+      (let ((processed nil)
+	    (params nil))
+	(dolist (arg args)
+	  (let ((name (car arg))
+		(type (convert-from-uffi-type (cadr arg) :routine)))
+	    ;;(when (and (listp type) (eq (car type) :address))
+	    ;;(setf type :address))
+	    (push name params)
+	    (push type processed)
+	    (push name processed)))
+	(values (nreverse params) (nreverse processed)))
+    ))
+
+(defun process-one-function-arg (arg)
+  (let ((name (car arg))
+	(type (convert-from-uffi-type (cadr arg) :routine)))
+    #+(or cmu sbcl scl)
+    ;(list name type :in)
+    `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
+    #+(or allegro lispworks digitool)
+    (if (and (listp type) (listp (car type)))
+	(append (list name) type)
+      (list name type))
+    #+openmcl
+    (declare (ignore name type))
+    ))    
+
+
+(defun allegro-convert-return-type (type)
+  (if (and (listp type) (not (listp (car type))))
+      (list type)
+    type))
+
+(defun funcallable-lambda-list (args)
+  (let ((ll nil))
+    (dolist (arg args)
+      (push (car arg) ll))
+    (nreverse ll)))
+
+#|
+(defmacro def-funcallable (name args &key returning)
+  (let ((result-type (convert-from-uffi-type returning :return))
+	(function-args (process-function-args args)))
+    #+lispworks
+    `(fli:define-foreign-funcallable ,name ,function-args
+      :result-type ,result-type
+      :language :ansi-c
+      :calling-convention :cdecl)
+    #+(or cmu scl sbcl)
+    ;; requires the type of the function pointer be declared correctly!
+    (let* ((ptrsym (gensym))
+	   (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+	(alien::alien-funcall ,ptrsym , at ll)))
+    #+openmcl
+    (multiple-value-bind (params args) (process-function-args args)
+      (let ((ptrsym (gensym)))
+	`(defun ,name ,(cons ptrsym params)
+	  (ccl::ff-call ,ptrsym , at args ,result-type))))
+    #+allegro
+    ;; this is most definitely wrong
+    (let* ((ptrsym (gensym))
+	   (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+	(system::ff-funcall ,ptrsym , at ll)))
+    ))
+|#    
+
+(defun convert-lispworks-args (args)
+  (loop for arg in args
+	with processed = nil
+	do
+	(if (and (= (length arg) 3) (eq (third arg) :out))
+	    (push (list (first arg)
+			(list :reference-return (second arg))) processed)
+	    (push (subseq arg 0 2) processed))
+	finally (return (nreverse processed))))
+
+(defun preprocess-names (names)
+  (let ((fname (gensym)))
+    (if (atom names)
+	(values (list names fname) fname (uffi::make-lisp-name names))
+	(values (list (first names) fname) fname (second names)))))
+
+(defun preprocess-args (args)
+  (loop for arg in args
+	with lisp-args = nil and out = nil and processed = nil
+	do
+	(if (= (length arg) 3)
+	    (ecase (third arg)
+	      (:in 
+	       (progn
+		 (push (first arg) lisp-args)
+		 (push (list (first arg) (second arg)) processed)))
+	      (:out
+	       (progn
+		 (push (list (first arg) (second arg)) out)
+		 (push (list (first arg) (list '* (second arg))) processed))))
+	    (progn
+	      (push (first arg) lisp-args)
+	      (push arg processed)))
+	finally (return (values (nreverse lisp-args) 
+				(nreverse out) 
+				(nreverse processed)))))
+
+
+(defmacro def-function (names args &key module returning)
+  (multiple-value-bind (lisp-args out processed)
+      (preprocess-args args)
+    (declare (ignorable lisp-args processed))
+    (if (= (length out) 0)
+	`(%def-function ,names ,args 
+	  ,@(if module (list :module module) (values))
+	  ,@(if returning (list :returning returning) (values)))
+
+	#+(or cmu scl sbcl)
+	`(%def-function ,names ,args 
+	  ,@(if returning (list :returning returning) (values)))
+	#+(and lispworks lispworks5)
+	(multiple-value-bind (name-pair fname lisp-name)
+	    (preprocess-names names)
+	  `(progn
+	       (%def-function ,name-pair ,(convert-lispworks-args args)
+			      ,@(if module (list :module module) (values))
+			      ,@(if returning (list :returning returning) (values)))
+	       (defun ,lisp-name ,lisp-args
+		 (,fname ,@(mapcar 
+			    #'(lambda (arg)
+				(cond ((member (first arg) lisp-args)
+				       (first arg))
+				      ((member (first arg) out :key #'first)
+				       t)))
+			  args)))))
+	#+(and lispworks (not lispworks5))
+	`(%def-function ,names ,(convert-lispworks-args args)
+	  ,@(if module (list :module module) (values))
+	  ,@(if returning (list :returning returning) (values)))
+	#-(or cmu scl sbcl lispworks)
+	(multiple-value-bind (name-pair fname lisp-name)
+	    (preprocess-names names)
+	  `(progn
+	    (%def-function ,name-pair ,processed 
+	     :module ,module :returning ,returning)
+	    ;(declaim (inline ,fname))
+	    (defun ,lisp-name ,lisp-args
+	      (with-foreign-objects ,out
+		(values (,fname ,@(mapcar #'first args))
+		        ,@(mapcar #'(lambda (arg)
+				      (list 'deref-pointer
+					    (first arg)
+					    (second arg))) out))))))
+	)))
+	
+
+;; name is either a string representing foreign name, or a list
+;; of foreign-name as a string and lisp name as a symbol
+(defmacro %def-function (names args &key module returning)
+  #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
+  
+  (let* ((result-type (convert-from-uffi-type returning :return))
+	 (function-args (process-function-args args))
+	 (foreign-name (if (atom names) names (car names)))
+	 (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+    ;; todo: calling-convention :stdcall for cormanlisp
+    #+allegro
+    `(ff:def-foreign-call (,lisp-name ,foreign-name)
+	 ,function-args
+       :returning ,(allegro-convert-return-type result-type)
+       :call-direct t
+       :strings-convert nil)
+    #+(or cmu scl)
+    `(alien:def-alien-routine (,foreign-name ,lisp-name)
+	 ,result-type
+       , at function-args)
+    #+sbcl
+    `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
+	 ,result-type
+       , at function-args)
+    #+lispworks
+    `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
+	 ,function-args
+       ,@(if module (list :module module) (values))
+       :result-type ,result-type
+      :language :ansi-c
+       #+:win32 :calling-convention #+:win32 :cdecl)
+    #+digitool
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (ccl:define-entry-point (,lisp-name ,foreign-name)
+         ,function-args
+         ,result-type))
+    #+openmcl
+    (declare (ignore function-args))
+    #+(and openmcl darwinppc-target)
+    (setf foreign-name (concatenate 'string "_" foreign-name))
+    #+openmcl
+    (multiple-value-bind (params args) (process-function-args args)
+      `(defun ,lisp-name ,params
+         (ccl::external-call ,foreign-name , at args ,result-type)))
+    #+cormanlisp
+    `(ct:defun-dll ,lisp-name (,function-args)
+       :return-type ,result-type
+       ,@(if module (list :library-name module) (values))
+       :entry-name ,foreign-name
+       :linkage-type ,calling-convention) ; we need :pascal
+    ))
+
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/libraries.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/libraries.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,134 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          libraries.lisp
+;;;; Purpose:       UFFI source to load foreign libraries
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: libraries.lisp 11764 2007-07-22 19:09:39Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(defvar *loaded-libraries* nil
+  "List of foreign libraries loaded. Used to prevent reloading a library")
+
+(defun default-foreign-library-type ()
+  "Returns string naming default library type for platform"
+  #+(or win32 cygwin mswindows) "dll"
+  #+(or macosx darwin ccl-5.0) "dylib"
+  #-(or win32 cygwin mswindows macosx darwin ccl-5.0) "so"
+)
+
+(defun foreign-library-types ()
+  "Returns list of string naming possible library types for platform, sorted by preference"
+  #+(or win32 mswindows) '("dll" "lib")
+  #+(or macosx darwin ccl-5.0) '("dylib" "bundle")
+  #-(or win32 mswindows macosx darwin ccl-5.0) '("so" "a" "o")
+)
+
+(defun find-foreign-library (names directories &key types drive-letters)
+  "Looks for a foreign library. directories can be a single
+string or a list of strings of candidate directories. Use default
+library type if type is not specified."
+  (unless types
+    (setq types (foreign-library-types)))
+  (unless (listp types)
+    (setq types (list types)))
+  (unless (listp names)
+    (setq names (list names)))
+  (unless (listp directories)
+    (setq directories (list directories)))
+  #+(or win32 mswindows)
+  (unless (listp drive-letters)
+    (setq drive-letters (list drive-letters)))
+  #-(or win32 mswindows)
+  (setq drive-letters '(nil))
+  (dolist (drive-letter drive-letters)
+    (dolist (name names)
+      (dolist (dir directories)
+	(dolist (type types)
+	  (let ((path (make-pathname
+		       #+lispworks :host
+		       #+lispworks (when drive-letter drive-letter)
+		       #-lispworks :device
+		       #-lispworks (when drive-letter drive-letter)
+		       :name name
+		       :type type
+		       :directory
+		       (etypecase dir
+			 (pathname
+			  (pathname-directory dir))
+			 (list
+			  dir)
+			 (string
+			  (pathname-directory
+			   (parse-namestring dir)))))))
+	    (when (probe-file path)
+	      (return-from find-foreign-library path)))))))
+   nil)
+
+
+(defun load-foreign-library (filename &key module supporting-libraries
+					   force-load)
+  #+(or allegro openmcl digitool sbcl) (declare (ignore module supporting-libraries))
+  #+(or cmu scl) (declare (ignore module))
+  #+lispworks (declare (ignore supporting-libraries))
+
+  (flet ((load-failure ()
+           (error "Unable to load foreign library \"~A\"." filename)))
+    (when (and filename (or (null (pathname-directory filename))
+                            (probe-file filename)))
+      (if (pathnamep filename)    ;; ensure filename is a string to check if already loaded
+          (setq filename (namestring (if (null (pathname-directory filename))
+                                         filename
+                                         ;; lispworks treats as UNC, so use truename
+                                         #+(and lispworks win32) (truename filename)
+                                         #-(and lispworks win32) filename))))
+
+      (if (and (not force-load)
+               (find filename *loaded-libraries* :test #'string-equal))
+          t ;; return T, but don't reload library
+      (progn
+	#+cmu
+	(let ((type (pathname-type (parse-namestring filename))))
+	  (if (string-equal type "so")
+	      (unless
+                  (sys::load-object-file filename)
+                (load-failure))
+	      (alien:load-foreign filename
+				  :libraries
+				  (convert-supporting-libraries-to-string
+				   supporting-libraries))))
+	#+scl
+	(let ((type (pathname-type (parse-namestring filename))))
+	  (alien:load-foreign filename
+			      :libraries
+			      (convert-supporting-libraries-to-string
+			       supporting-libraries)))
+	#+sbcl
+	(handler-case (sb-alien::load-1-foreign filename)
+	  (sb-int:unsupported-operator (c)
+	    (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
+		(funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
+		(error c))))
+
+	#+lispworks (fli:register-module module :real-name filename
+                                         :connection-style :immediate)
+	#+allegro (load filename)
+	#+openmcl (ccl:open-shared-library filename)
+	#+digitool (ccl:add-to-shared-library-search-path filename t)
+
+	(push filename *loaded-libraries*)
+	t)))))
+
+(defun convert-supporting-libraries-to-string (libs)
+  (let (lib-load-list)
+    (dolist (lib libs)
+      (push (format nil "-l~A" lib) lib-load-list))
+    (nreverse lib-load-list)))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/objects.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/objects.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,291 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          objects.lisp
+;;;; Purpose:       UFFI source to handle objects and pointers
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: objects.lisp 11022 2006-08-14 04:26:22Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun size-of-foreign-type (type)
+    #+lispworks (fli:size-of type)
+    #+allegro (ff:sizeof-fobject type)
+    #+(or cmu scl)  (ash (eval `(alien:alien-size ,type)) -3) ;; convert from bits to bytes
+    #+sbcl  (ash (eval `(sb-alien:alien-size ,type)) -3) ;; convert from bits to bytes
+    #+clisp (values (ffi:size-of type))
+    #+digitool
+    (let ((mcl-type (ccl:find-mactype type nil t)))
+      (if mcl-type
+	  (ccl::mactype-record-size mcl-type)
+	  (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record
+    #+openmcl (ccl::%foreign-type-or-record-size type :bytes)
+    ))
+
+(defmacro allocate-foreign-object (type &optional (size :unspecified))
+  "Allocates an instance of TYPE. If size is specified, then allocate
+an array of TYPE with size SIZE. The TYPE parameter is evaluated."
+  (if (eq size :unspecified)
+      (progn
+	#+(or cmu scl)
+	`(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+	#+sbcl
+	`(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation))
+	#+lispworks
+	`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate))
+	#+allegro
+	`(ff:allocate-fobject ',(convert-from-uffi-type type :allocate) :c)
+	#+(or openmcl digitool)
+	`(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+	)
+      (progn
+	#+(or cmu scl)
+	`(alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+	#+sbcl
+	`(sb-alien:make-alien ,(convert-from-uffi-type (eval type) :allocation) ,size)
+	#+lispworks
+	`(fli:allocate-foreign-object :type ',(convert-from-uffi-type type :allocate) :nelems ,size)
+	#+allegro
+	`(ff:allocate-fobject (list :array (quote ,(convert-from-uffi-type type :allocate)) ,size) :c)
+	#+(or openmcl digitool)
+	`(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))
+	)))
+
+(defmacro free-foreign-object (obj)
+  #+(or cmu scl)
+  `(alien:free-alien ,obj)
+  #+sbcl
+  `(sb-alien:free-alien ,obj)
+  #+lispworks
+  `(fli:free-foreign-object ,obj)
+  #+allegro
+  `(ff:free-fobject ,obj)
+  #+(or openmcl digitool)
+  `(dispose-ptr ,obj)
+  )
+
+(defmacro null-pointer-p (obj)
+  #+lispworks `(fli:null-pointer-p ,obj)
+  #+allegro `(zerop ,obj)
+  #+(or cmu scl)   `(alien:null-alien ,obj)
+  #+sbcl   `(sb-alien:null-alien ,obj)
+  #+(or openmcl digitool)   `(ccl:%null-ptr-p ,obj)
+  )
+
+(defmacro make-null-pointer (type)
+  #+(or allegro openmcl digitool) (declare (ignore type))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap 0) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+lispworks `(fli:make-pointer :address 0 :type (quote ,(convert-from-uffi-type (eval type) :type)))
+  #+allegro 0
+  #+(or openmcl digitool) `(ccl:%null-ptr)
+  )
+
+(defmacro make-pointer (addr type)
+  #+(or allegro openmcl digitool) (declare (ignore type))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type)))
+  #+allegro addr
+  #+(or openmcl digitool) `(ccl:%int-to-ptr ,addr)
+  )
+
+
+(defmacro char-array-to-pointer (obj)
+  #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
+  #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
+  #+lispworks `(fli:make-pointer :type '(:unsigned :char)
+				:address (fli:pointer-address ,obj))
+  #+allegro obj
+  #+(or openmcl digitool) obj
+  )
+
+(defmacro deref-pointer (ptr type)
+  "Returns a object pointed"
+  #+(or cmu sbcl lispworks scl) (declare (ignore type))
+  #+(or cmu scl)  `(alien:deref ,ptr)
+  #+sbcl  `(sb-alien:deref ,ptr)
+  #+lispworks `(fli:dereference ,ptr)
+  #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr)
+  #+(or openmcl digitool) `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
+  )
+
+#+digitool
+(defmacro deref-pointer-set (ptr type value)
+  `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
+
+#+digitool
+(defsetf deref-pointer deref-pointer-set)
+
+(defmacro ensure-char-character (obj)
+  #+(or digitool) obj
+  #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj)
+  ;; lispworks varies whether deref'ing array vs. slot access of a char
+  #+lispworks `(if (characterp ,obj) ,obj (code-char ,obj)))
+
+(defmacro ensure-char-integer (obj)
+  #+(or digitool) `(char-code ,obj)
+  #+(or allegro cmu sbcl scl openmcl) obj
+  ;; lispworks varies whether deref'ing array vs. slot access of a char
+  #+lispworks
+  `(if (integerp ,obj) ,obj (char-code ,obj)))
+
+(defmacro ensure-char-storable (obj)
+  #+(or digitool (and lispworks (not lispworks5))) obj
+  #+(or allegro cmu lispworks5 openmcl sbcl scl)
+  `(char-code ,obj))
+
+(defmacro pointer-address (obj)
+  #+(or cmu scl)
+  `(system:sap-int (alien:alien-sap ,obj))
+  #+sbcl
+  `(sb-sys:sap-int (sb-alien:alien-sap ,obj))
+  #+lispworks
+  `(fli:pointer-address ,obj)
+  #+allegro
+  obj
+  #+(or openmcl digitool)
+  `(ccl:%ptr-to-int ,obj)
+  )
+
+;; TYPE is evaluated.
+#-(or openmcl digitool)
+(defmacro with-foreign-object ((var type) &rest body)
+  #-(or cmu sbcl lispworks scl) ; default version
+  `(let ((,var (allocate-foreign-object ,type)))
+    (unwind-protect
+	 (progn , at body)
+      (free-foreign-object ,var)))
+  #+(or cmu scl)
+  (let ((obj (gensym))
+	(ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+	`(alien:with-alien ((,obj ,ctype))
+	  (let* ((,var ,obj))
+	    , at body))
+	`(alien:with-alien ((,obj ,ctype))
+	  (let* ((,var (alien:addr ,obj)))
+	    , at body))))
+  #+sbcl
+  (let ((obj (gensym))
+	(ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+	`(sb-alien:with-alien ((,obj ,ctype))
+	  (let* ((,var ,obj))
+	    , at body))
+	`(sb-alien:with-alien ((,obj ,ctype))
+	  (let* ((,var (sb-alien:addr ,obj)))
+	    , at body))))
+  #+lispworks
+  `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
+					      (eval type) :allocate)))
+    , at body)
+  )
+
+#-(or openmcl digitool)
+(defmacro with-foreign-objects (bindings &rest body)
+  (if bindings
+      `(with-foreign-object ,(car bindings)
+	(with-foreign-objects ,(cdr bindings)
+	  , at body))
+      `(progn , at body)))
+
+#+(or openmcl digitool)
+(defmacro with-foreign-objects (bindings &rest body)
+  (let ((params nil) type count)
+    (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
+      (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
+      (setf count 1)
+      (when (and (listp type) (eq (first type) :array))
+        (setf count (nth 2 type))
+        (unless (integerp count) (error "Invalid size for array: ~a" type))
+        (setf type (nth 1 type)))
+      (push (list (first spec) (* count (size-of-foreign-type type))) params))
+    `(ccl:%stack-block ,params , at body)))
+
+#+(or openmcl digitool)
+(defmacro with-foreign-object ((var type) &rest body)
+  `(with-foreign-objects ((,var ,type))
+     , at body))
+
+#+lispworks
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  `(fli:with-coerced-pointer (,binding-name
+                          :type ',(convert-from-uffi-type (eval type) :type))
+      ,pointer
+    , at body))
+
+#+(or cmu scl sbcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  `(let ((,binding-name
+          (#+(or cmu scl) alien:cast
+           #+sbcl sb-alien:cast
+           ,pointer (* ,(convert-from-uffi-type (eval type) :type)))))
+    , at body))
+
+#+(or allegro openmcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  (declare (ignore type))
+  `(let ((,binding-name ,pointer))
+    , at body))
+
+#-(or lispworks cmu scl sbcl allegro openmcl)
+(defmacro with-cast-pointer ((binding-name pointer type) &body body)
+  (declare (ignore binding-name pointer type body))
+  '(error "WITH-CAST-POINTER not (yet) implemented for ~A"
+          (lisp-implementation-type)))
+
+#+(or allegro openmcl)
+(defun convert-external-name (name)
+  "Add an underscore to NAME if necessary for the ABI."
+  #+(or macosx darwinppc-target) (concatenate 'string "_" name)
+  #-(or macosx darwinppc-target) name)
+
+(defmacro def-foreign-var (names type module)
+  #-lispworks (declare (ignore module))
+  (let ((foreign-name (if (atom names) names (first names)))
+        (lisp-name (if (atom names) (make-lisp-name names) (second names)))
+        #-allegro
+        (var-type (convert-from-uffi-type type :type)))
+    #+(or cmu scl)
+    `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type)
+    #+sbcl
+    `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type)
+    #+allegro
+    `(define-symbol-macro ,lisp-name
+      (ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref))
+                            :c (ff:get-entry-point ,(convert-external-name foreign-name))))
+    #+lispworks
+    `(progn
+      (fli:define-foreign-variable (,lisp-name ,foreign-name)
+                                    :accessor :address-of
+                                    :type ,var-type
+                                    :module ,module)
+      (define-symbol-macro ,lisp-name (fli:dereference (,lisp-name)
+                                                        :copy-foreign-object nil)))
+    #+openmcl
+    `(define-symbol-macro ,lisp-name
+       (deref-pointer (ccl:foreign-symbol-address
+                       ,(convert-external-name foreign-name)) ,var-type))
+    #-(or allegro cmu scl sbcl lispworks openmcl)
+    `(define-symbol-macro ,lisp-name
+      '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
+        (lisp-implementation-type)))))
+
+
+;;; Define a special variable, like DEFVAR, that will be initialized
+;;; to a pointer which may need to be reset when a saved image is
+;;; loaded.  This is needed for OpenMCL, which sets pointers to "dead
+;;; macptrs" when a saved image is loaded.
+;; This may possibly be needed for sbcl's SAVE-LISP-AND-DIE
+(defmacro def-pointer-var (name value &optional doc)
+  #-openmcl `(defvar ,name ,value ,@(if doc (list doc)))
+  #+openmcl `(ccl::defloadvar ,name ,value ,doc))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/os.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/os.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,79 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          os.lisp
+;;;; Purpose:       Operating system interface for UFFI
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Sep 2002
+;;;;
+;;;; $Id: os.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg.
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+(defun getenv (var)
+  "Return the value of the environment variable."
+  #+allegro (sys::getenv (string var))
+  #+clisp (sys::getenv (string var))
+  #+cmu (cdr (assoc (string var) ext:*environment-list* :test #'equalp
+                    :key #'string))
+  #+gcl (si:getenv (string var))
+  #+lispworks (lw:environment-variable (string var))
+  #+lucid (lcl:environment-variable (string var))
+  #+(or openmcl digitool) (ccl::getenv var)
+  #+sbcl (sb-ext:posix-getenv var)
+  #-(or allegro clisp cmu gcl lispworks lucid openmcl digitool sbcl)
+  (error 'not-implemented :proc (list 'getenv var)))
+
+
+;; modified from function ASDF -- Copyright Dan Barlow and Contributors
+
+(defun run-shell-command (control-string  &rest args &key output)
+  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*.  Returns the shell's exit code."
+  (unless output
+    (setq output *trace-output*))
+
+  (let ((command (apply #'format nil control-string args)))
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program
+      "/bin/sh"
+      (list "-c" command)
+      :input nil :output output))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list "-c" command)
+      :input nil :output output))
+
+    #+allegro
+    (excl:run-shell-command command :input nil :output output)
+
+    #+lispworks
+    (system:call-system-showing-output
+     command
+     :shell-type "/bin/sh"
+     :output-stream output)
+
+    #+clisp				;XXX not exactly *trace-output*, I know
+    (ext:run-shell-command  command :output :terminal :wait t)
+
+    #+openmcl
+    (nth-value 1
+	       (ccl:external-process-status
+		(ccl:run-program "/bin/sh" (list "-c" command)
+				 :input nil :output output
+				 :wait t)))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp.")
+    ))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/package.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,84 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Defines UFFI package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:uffi
+  (:use #:cl)
+  (:export
+
+   ;; immediate types
+   #:def-constant
+   #:def-foreign-type
+   #:def-type
+   #:null-char-p
+
+   ;; aggregate types
+   #:def-enum
+   #:def-struct
+   #:get-slot-value
+   #:get-slot-pointer
+   #:def-array-pointer
+   #:deref-array
+   #:def-union
+
+   ;; objects
+   #:allocate-foreign-object
+   #:free-foreign-object
+   #:with-foreign-object
+   #:with-foreign-objects
+   #:size-of-foreign-type
+   #:pointer-address
+   #:deref-pointer
+   #:ensure-char-character
+   #:ensure-char-integer
+   #:ensure-char-storable
+   #:null-pointer-p
+   #:make-null-pointer
+   #:make-pointer
+   #:pointer-address
+   #:+null-cstring-pointer+
+   #:char-array-to-pointer
+   #:with-cast-pointer
+   #:def-foreign-var
+   #:convert-from-foreign-usb8
+   #:def-pointer-var
+
+   ;; string functions
+   #:convert-from-cstring
+   #:convert-to-cstring
+   #:free-cstring
+   #:with-cstring
+   #:with-cstrings
+   #:convert-from-foreign-string
+   #:convert-to-foreign-string
+   #:allocate-foreign-string
+   #:with-foreign-string
+   #:with-foreign-strings
+   #:foreign-string-length
+
+   ;; function call
+   #:def-function
+
+   ;; Libraries
+   #:find-foreign-library
+   #:load-foreign-library
+   #:default-foreign-library-type
+   #:foreign-library-types
+
+   ;; OS
+   #:run-shell-command
+   #:getenv
+   ))
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,311 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          primitives.lisp
+;;;; Purpose:       UFFI source to handle immediate types
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: primitives.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+#+(or openmcl digitool)
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+#+(or openmcl digitool)
+; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
+; So this provides a function to convert any quoted symbols to keywords.
+(defun keyword (obj)
+  (cond ((keywordp obj) 
+         obj)
+        ((null obj)
+         nil)
+        ((symbolp obj)
+         (intern (symbol-name obj) *keyword-package*))
+        ((and (listp obj) (eq (car obj) 'cl:quote))
+         (keyword (cadr obj)))
+        ((stringp obj)
+         (intern obj *keyword-package*))
+        (t 
+         obj)))
+
+; Wrapper for unexported function we have to use
+#+digitool
+(defmacro def-mcl-type (name type)
+  `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
+
+(defmacro def-constant (name value &key (export nil))
+  "Macro to define a constant and to export it"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (defconstant ,name ,value)
+     ,(when export (list 'export `(quote ,name)))
+    ',name))
+
+(defmacro def-type (name type)
+  "Generates a (deftype) statement for CL. Currently, only CMUCL
+supports takes advantage of this optimization."
+  #+(or lispworks allegro openmcl digitool cormanlisp)  (declare (ignore type))
+  #+(or lispworks allegro openmcl digitool cormanlisp) `(deftype ,name () t)
+  #+(or cmu scl)
+  `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
+  #+sbcl
+  `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare)))
+  )
+
+(defmacro null-char-p (val)
+  "Returns T if character is NULL"
+  `(zerop ,val))
+      
+(defmacro def-foreign-type (name type)
+  #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
+  #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
+  #+(or cmu scl) `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
+  #+sbcl `(sb-alien:define-alien-type ,name ,(convert-from-uffi-type type :type))
+  #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
+  #+(or openmcl digitool)
+  (let ((mcl-type (convert-from-uffi-type type :type)))
+    (unless (or (keywordp mcl-type) (consp mcl-type))
+      (setf mcl-type `(quote ,mcl-type)))
+    #+digitool
+    `(def-mcl-type ,(keyword name) ,mcl-type)
+    #+openmcl
+    `(ccl::def-foreign-type ,(keyword name) ,mcl-type))  
+  )
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
+  #+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
+			(make-hash-table :size 20 :test #'eq))
+  )
+
+#+(or cmu scl)
+(defvar *cmu-sbcl-def-type-list*
+    '((:char . (alien:signed 8))
+      (:unsigned-char . (alien:unsigned 8))
+      (:byte . (alien:signed 8))
+      (:unsigned-byte . (alien:unsigned 8))
+      (:short . (alien:signed 16))
+      (:unsigned-short . (alien:unsigned 16))
+      (:int . (alien:signed 32))
+      (:unsigned-int . (alien:unsigned 32))
+      #-x86-64 (:long . (alien:signed 32))
+      #-x86-64 (:unsigned-long . (alien:unsigned 32))
+      #+x86-64 (:long . (alien:signed 64))
+      #+x86-64 (:unsigned-long . (alien:unsigned 64))
+      (:float . alien:single-float)
+      (:double . alien:double-float)
+      (:void . t)
+      )
+  "Conversions in CMUCL for def-foreign-type are different than in def-function")
+
+#+sbcl
+(defvar *cmu-sbcl-def-type-list*
+    '((:char . (sb-alien:signed 8))
+      (:unsigned-char . (sb-alien:unsigned 8))
+      (:byte . (sb-alien:signed 8))
+      (:unsigned-byte . (sb-alien:unsigned 8))
+      (:short . (sb-alien:signed 16))
+      (:unsigned-short . (sb-alien:unsigned 16))
+      (:int . (sb-alien:signed 32))
+      (:unsigned-int . (sb-alien:unsigned 32))
+      #-x86-64 (:long . (sb-alien:signed 32))
+      #-x86-64 (:unsigned-long . (sb-alien:unsigned 32))
+      #+x86-64 (:long . (sb-alien:signed 64))
+      #+x86-64 (:unsigned-long . (sb-alien:unsigned 64))
+      (:float . sb-alien:single-float)
+      (:double . sb-alien:double-float)
+      (:void . t)
+      )
+  "Conversions in SBCL for def-foreign-type are different than in def-function")
+
+(defvar *type-conversion-list* nil)
+
+#+(or cmu scl)
+(setq *type-conversion-list*
+    '((* . *) (:void . c-call:void) 
+      (:pointer-void . (* t))
+      (:cstring . c-call:c-string)
+      (:char . c-call:char) 
+      (:unsigned-char . (alien:unsigned 8))
+      (:byte . (alien:signed 8))
+      (:unsigned-byte . (alien:unsigned 8))
+      (:short . c-call:short)
+      (:unsigned-short . c-call:unsigned-short)
+      (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) 
+      (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
+      (:float . c-call:float) (:double . c-call:double)
+      (:array . alien:array)))
+
+#+sbcl
+(setq *type-conversion-list*
+    '((* . *) (:void . sb-alien:void) 
+      (:pointer-void . (* t))
+      #-sb-unicode(:cstring . sb-alien:c-string)
+      #+sb-unicode(:cstring . sb-alien:utf8-string)
+      (:char . sb-alien:char) 
+      (:unsigned-char . (sb-alien:unsigned 8))
+      (:byte . (sb-alien:signed 8))
+      (:unsigned-byte . (sb-alien:unsigned 8))
+      (:short . sb-alien:short)
+      (:unsigned-short . sb-alien:unsigned-short)
+      (:int . sb-alien:int) (:unsigned-int . sb-alien:unsigned-int) 
+      (:long . sb-alien:long) (:unsigned-long . sb-alien:unsigned-long)
+      (:float . sb-alien:float) (:double . sb-alien:double)
+      (:array . sb-alien:array)))
+
+#+(or allegro cormanlisp)
+(setq *type-conversion-list*
+    '((* . *) (:void . :void)
+      (:short . :short)
+      (:pointer-void . (* :void))
+      (:cstring . (* :unsigned-char))
+      (:byte . :char)
+      (:unsigned-byte . :unsigned-char)
+      (:char . :char)
+      (:unsigned-char . :unsigned-char)
+      (:int . :int) (:unsigned-int . :unsigned-int) 
+      (:long . :long) (:unsigned-long . :unsigned-long)
+      (:float . :float) (:double . :double)
+      (:array . :array)))
+
+#+lispworks
+(setq *type-conversion-list*
+    '((* . :pointer) (:void . :void) 
+      (:short . :short)
+      (:pointer-void . (:pointer :void))
+      (:cstring . (:reference-pass (:ef-mb-string :external-format
+				    (:latin-1 :eol-style :lf))
+		   :allow-null t))
+      (:cstring-returning . (:reference (:ef-mb-string :external-format
+					 (:latin-1 :eol-style :lf))
+			     :allow-null t))
+      (:byte . :byte)
+      (:unsigned-byte . (:unsigned :byte))
+      (:char . :char)
+      (:unsigned-char . (:unsigned :char))
+      (:int . :int) (:unsigned-int . (:unsigned :int))
+      (:long . :long) (:unsigned-long . (:unsigned :long))
+      (:float . :float) (:double . :double)
+      (:array . :c-array)))
+
+#+digitool
+(setq *type-conversion-list*
+     '((* . :pointer) (:void . :void)
+       (:short . :short) (:unsigned-short . :unsigned-short)
+       (:pointer-void . :pointer)
+       (:cstring . :string)
+       (:char . :character)
+       (:unsigned-char . :unsigned-byte)
+       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+       (:int . :long) (:unsigned-int . :unsigned-long)
+       (:long . :long) (:unsigned-long . :unsigned-long)
+       (:float . :single-float) (:double . :double-float)
+       (:array . :array)))
+
+#+openmcl
+(setq *type-conversion-list*
+     '((* . :address) (:void . :void)
+       (:short . :short) (:unsigned-short . :unsigned-short)
+       (:pointer-void . :address)
+       (:cstring . :address)
+       (:char . :signed-char)
+       (:unsigned-char . :unsigned-char)
+       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+       (:int . :int) (:unsigned-int . :unsigned-int)
+       (:long . :long) (:unsigned-long . :unsigned-long)
+       (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
+       (:float . :single-float) (:double . :double-float)
+       (:array . :array)))
+
+(dolist (type *type-conversion-list*)
+  (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
+
+#+(or cmu sbcl scl)
+(dolist (type *cmu-sbcl-def-type-list*)
+  (setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
+
+(defun basic-convert-from-uffi-type (type)
+  (let ((found-type (gethash type +type-conversion-hash+)))
+    (if found-type
+	found-type
+      #-(or openmcl digitool) type
+      #+(or openmcl digitool) (keyword type))))
+
+(defun %convert-from-uffi-type (type context)
+  "Converts from a uffi type to an implementation specific type"
+  (if (atom type)
+      (cond
+       #+(or allegro cormanlisp)
+       ((and (or (eq context :routine) (eq context :return))
+	     (eq type :cstring))
+	(setq type '((* :char) integer)))
+       #+(or cmu sbcl scl)
+       ((eq context :type)
+	(let ((cmu-type (gethash type *cmu-def-type-hash*)))
+	  (if cmu-type
+	      cmu-type
+	      (basic-convert-from-uffi-type type))))
+       #+lispworks
+       ((and (eq context :return)
+	     (eq type :cstring))
+	(basic-convert-from-uffi-type :cstring-returning))
+       #+digitool
+       ((and (eq type :void) (eq context :return)) nil)
+       (t
+	(basic-convert-from-uffi-type type)))
+    (let ((sub-type (car type)))
+      (case sub-type
+	(cl:quote
+	 (convert-from-uffi-type (cadr type) context))
+	(:struct-pointer
+	 #+(or openmcl digitool) `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct)))
+	 #-(or openmcl digitool) (%convert-from-uffi-type (list '* (cadr type)) :struct)
+	 )
+	(:struct
+	 #+(or openmcl digitool) `(:struct ,(%convert-from-uffi-type (cadr type) :struct))
+	 #-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :struct)
+	 )
+       (:union
+	#+(or openmcl digitool) `(:union ,(%convert-from-uffi-type (cadr type) :union))
+	#-(or openmcl digitool) (%convert-from-uffi-type (cadr type) :union)
+	)
+       (t
+	(cons (%convert-from-uffi-type (first type) context) 
+	      (%convert-from-uffi-type (rest type) context)))))))
+
+(defun convert-from-uffi-type (type context)
+  (let ((result (%convert-from-uffi-type type context)))
+    (cond
+     ((atom result) result)
+     #+openmcl
+     ((eq (car result) :address)
+      (if (eq context :struct)
+	  (append '(:*) (cdr result))
+	:address))
+     #+digitool
+     ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
+     (t result))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (char= #\a (schar (symbol-name '#:a) 0))
+    (pushnew :uffi-lowercase-reader *features*))
+  (when (not (string= (symbol-name '#:a)
+		      (symbol-name '#:A)))
+    (pushnew :uffi-case-sensitive *features*)))
+
+(defun make-lisp-name (name)
+  (let ((converted (substitute #\- #\_ name)))
+     (intern 
+      #+uffi-case-sensitive converted
+      #+(and (not uffi-lowercase-reader) (not uffi-case-sensitive)) (string-upcase converted)
+      #+(and uffi-lowercase-reader (not uffi-case-sensitive)) (string-downcase converted))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (setq cl:*features* (delete :uffi-lowercase-reader *features*))
+  (setq cl:*features* (delete :uffi-case-sensitive *features*)))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/readmacros-mcl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/readmacros-mcl.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,35 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          readmacros-mcl.lisp
+;;;; Purpose:       This file holds functions using read macros for MCL
+;;;; Programmer:    Kevin M. Rosenberg/John Desoi
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: readmacros-mcl.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+;; trap macros don't work right directly in the macros
+#+digitool
+(defun new-ptr (size)
+  (#_NewPtr size))
+
+#+digitool
+(defun dispose-ptr (ptr)
+  (#_DisposePtr ptr))
+
+#+openmcl
+(defmacro new-ptr (size)
+  `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+  `(ccl::free ,ptr))
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/strings.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/strings.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,412 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strings.lisp
+;;;; Purpose:       UFFI source to handle strings, cstring and foreigns
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: strings.lisp 11023 2006-08-14 06:25:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;; *************************************************************************
+
+(in-package #:uffi)
+
+
+(def-pointer-var +null-cstring-pointer+
+    #+(or cmu sbcl scl) nil
+    #+allegro 0
+    #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char))
+    #+(or openmcl digitool) (ccl:%null-ptr)
+)
+
+(defmacro convert-from-cstring (obj)
+  "Converts a string from a c-call. Same as convert-from-foreign-string, except
+that LW/CMU automatically converts strings from c-calls."
+  #+(or cmu sbcl lispworks scl) obj
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (zerop ,stored)
+	   nil
+	   (values (excl:native-to-string ,stored)))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (ccl:%null-ptr-p ,stored)
+	   nil
+	 (values (ccl:%get-cstring ,stored)))))
+  )
+
+(defmacro convert-to-cstring (obj)
+  #+(or cmu sbcl scl lispworks) obj
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   0
+	   (values (excl:string-to-native ,stored)))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   +null-cstring-pointer+
+	   (let ((ptr (new-ptr (1+ (length ,stored)))))
+	     (ccl::%put-cstring ptr ,stored)
+	     ptr))))
+  )
+
+(defmacro free-cstring (obj)
+  #+(or cmu sbcl scl lispworks) (declare (ignore obj))
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (zerop ,stored)
+	 (ff:free-fobject ,stored))))
+  #+(or openmcl digitool)
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (unless (ccl:%null-ptr-p ,stored)
+	 (dispose-ptr ,stored))))
+  )
+
+(defmacro with-cstring ((cstring lisp-string) &body body)
+  #+(or cmu sbcl scl lispworks)
+  `(let ((,cstring ,lisp-string)) , at body)
+  #+allegro
+  (let ((acl-native (gensym))
+	(stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (excl:with-native-string (,acl-native ,stored-lisp-string)
+	 (let ((,cstring (if ,stored-lisp-string ,acl-native 0)))
+	   , at body))))
+  #+(or openmcl digitool)
+  (let ((stored-lisp-string (gensym)))
+    `(let ((,stored-lisp-string ,lisp-string))
+       (if (stringp ,stored-lisp-string)
+	   (ccl:with-cstrs ((,cstring ,stored-lisp-string))
+	     , at body)
+	   (let ((,cstring +null-cstring-pointer+))
+	     , at body))))
+  )
+
+(defmacro with-cstrings (bindings &rest body)
+  (if bindings
+      `(with-cstring ,(car bindings)
+	(with-cstrings ,(cdr bindings)
+	  , at body))
+      `(progn , at body)))
+
+;;; Foreign string functions
+
+(defmacro convert-to-foreign-string (obj)
+  #+lispworks
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   +null-cstring-pointer+
+	   (fli:convert-to-foreign-string
+	    ,stored
+	    :external-format '(:latin-1 :eol-style :lf)))))
+  #+allegro
+  (let ((stored (gensym)))
+    `(let ((,stored ,obj))
+       (if (null ,stored)
+	   0
+	   (values (excl:string-to-native ,stored)))))
+  #+(or cmu scl)
+  (let ((size (gensym))
+	(storage (gensym))
+	(stored-obj (gensym))
+	(i (gensym)))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+	 (null
+	  (alien:sap-alien (system:int-sap 0) (* (alien:unsigned 8))))
+	 (string
+	  (let* ((,size (length ,stored-obj))
+		 (,storage (alien:make-alien (alien:unsigned 8) (1+ ,size))))
+	    (setq ,storage (alien:cast ,storage (* (alien:unsigned 8))))
+	    (locally
+		(declare (optimize (speed 3) (safety 0)))
+	      (dotimes (,i ,size)
+		(declare (fixnum ,i))
+		(setf (alien:deref ,storage ,i)
+		      (char-code (char ,stored-obj ,i))))
+	   (setf (alien:deref ,storage ,size) 0))
+	 ,storage)))))
+  #+sbcl
+  (let ((size (gensym))
+	(storage (gensym))
+	(stored-obj (gensym))
+	(i (gensym)))
+    `(let ((,stored-obj ,obj))
+       (etypecase ,stored-obj
+	 (null
+	  (sb-alien:sap-alien (sb-sys:int-sap 0) (* (sb-alien:unsigned 8))))
+	 (string
+	  (let* ((,size (length ,stored-obj))
+		 (,storage (sb-alien:make-alien (sb-alien:unsigned 8) (1+ ,size))))
+	    (setq ,storage (sb-alien:cast ,storage (* (sb-alien:unsigned 8))))
+	    (locally
+		(declare (optimize (speed 3) (safety 0)))
+	      (dotimes (,i ,size)
+		(declare (fixnum ,i))
+		(setf (sb-alien:deref ,storage ,i)
+		      (char-code (char ,stored-obj ,i))))
+	      (setf (sb-alien:deref ,storage ,size) 0))
+	    ,storage)))))
+  #+(or openmcl digitool)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null ,stored-obj)
+	   +null-cstring-pointer+
+	   (let ((ptr (new-ptr (1+ (length ,stored-obj)))))
+	     (ccl::%put-cstring ptr ,stored-obj)
+	     ptr))))
+  )
+
+;; Either length or null-terminated-p must be non-nil
+(defmacro convert-from-foreign-string (obj &key
+					   length
+					   (locale :default)
+					   (null-terminated-p t))
+  #+allegro
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (zerop ,stored-obj)
+	   nil
+	   (if (eq ,locale :none)
+	       (fast-native-to-string ,stored-obj ,length)
+	       (values
+		(excl:native-to-string
+		 ,stored-obj
+		 ,@(when length (list :length length))
+		 :truncate (not ,null-terminated-p)))))))
+  #+lispworks
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (fli:null-pointer-p ,stored-obj)
+	   nil
+	   (if (eq ,locale :none)
+	       (fast-native-to-string ,stored-obj ,length)
+	       (fli:convert-from-foreign-string
+		,stored-obj
+		,@(when length (list :length length))
+		:null-terminated-p ,null-terminated-p
+		:external-format '(:latin-1 :eol-style :lf))))))
+  #+(or cmu scl)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+	   nil
+	   (cmucl-naturalize-cstring (alien:alien-sap ,stored-obj)
+				     :length ,length
+				     :null-terminated-p ,null-terminated-p))))
+
+  #+sbcl
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (null-pointer-p ,stored-obj)
+	    nil
+	    (sbcl-naturalize-cstring (sb-alien:alien-sap ,stored-obj)
+				     :length ,length
+				     :null-terminated-p ,null-terminated-p))))
+  #+(or openmcl digitool)
+  (declare (ignore null-terminated-p))
+  #+(or openmcl digitool)
+  (let ((stored-obj (gensym)))
+    `(let ((,stored-obj ,obj))
+       (if (ccl:%null-ptr-p ,stored-obj)
+	   nil
+	   #+digitool (ccl:%get-cstring
+				      ,stored-obj 0
+				      ,@(if length (list length) nil))
+	   #+openmcl ,@(if length
+			   `((ccl:%str-from-ptr ,stored-obj ,length))
+			   `((ccl:%get-cstring ,stored-obj))))))
+  )
+
+
+(defmacro allocate-foreign-string (size &key (unsigned t))
+  #+ignore
+  (let ((array-def (gensym)))
+    `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
+       (eval `(alien:cast (alien:make-alien ,,array-def)
+			  ,(if ,unsigned
+			       '(* (alien:unsigned 8))
+			     '(* (alien:signed 8)))))))
+
+  #+(or cmu scl)
+  `(alien:make-alien ,(if unsigned
+			     '(alien:unsigned 8)
+			     '(alien:signed 8))
+    ,size)
+
+  #+sbcl
+  `(sb-alien:make-alien ,(if unsigned
+			     '(sb-alien:unsigned 8)
+			     '(sb-alien:signed 8))
+    ,size)
+
+  #+lispworks
+  `(fli:allocate-foreign-object :type
+				,(if unsigned
+				     ''(:unsigned :char)
+				   :char)
+				:nelems ,size)
+  #+allegro
+  (declare (ignore unsigned))
+  #+allegro
+  `(ff:allocate-fobject :char :c ,size)
+  #+(or openmcl digitool)
+  (declare (ignore unsigned))
+  #+(or openmcl digitool)
+  `(new-ptr ,size)
+  )
+
+(defun foreign-string-length (foreign-string)
+  #+allegro `(ff:foreign-strlen ,foreign-string)
+  #-allegro
+  `(loop with size = 0
+    until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
+    do (incf size)
+    finally return size))
+
+
+(defmacro with-foreign-string ((foreign-string lisp-string) &body body)
+  (let ((result (gensym)))
+    `(let* ((,foreign-string (convert-to-foreign-string ,lisp-string))
+	    (,result (progn , at body)))
+      (declare (dynamic-extent ,foreign-string))
+      (free-foreign-object ,foreign-string)
+      ,result)))
+
+(defmacro with-foreign-strings (bindings &body body)
+  `(with-foreign-string ,(car bindings)
+    ,@(if (cdr bindings)
+          `((with-foreign-strings ,(cdr bindings) , at body))
+          body)))
+
+;; Modified from CMUCL's source to handle non-null terminated strings
+#+cmu
+(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((null-terminated-length
+	   (when null-terminated-p
+	     (loop
+		 for offset of-type fixnum upfrom 0
+		 until (zerop (system:sap-ref-8 sap offset))
+		 finally (return offset)))))
+      (if length
+	  (if (and null-terminated-length
+		   (> (the fixnum length) (the fixnum null-terminated-length)))
+	      (setq length null-terminated-length))
+	(setq length null-terminated-length)))
+    (let ((result (make-string length)))
+      (kernel:copy-from-system-area sap 0
+				    result (* vm:vector-data-offset
+					      vm:word-bits)
+				    (* length vm:byte-bits))
+      result)))
+
+#+scl
+;; kernel:copy-from-system-area doesn't work like it does on CMUCL or SBCL,
+;; so have to iteratively copy from sap
+(defun cmucl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((null-terminated-length
+	   (when null-terminated-p
+	     (loop
+		 for offset of-type fixnum upfrom 0
+		 until (zerop (system:sap-ref-8 sap offset))
+		 finally (return offset)))))
+      (if length
+	  (if (and null-terminated-length
+		   (> (the fixnum length) (the fixnum null-terminated-length)))
+	      (setq length null-terminated-length))
+	(setq length null-terminated-length)))
+    (let ((result (make-string length)))
+      (dotimes (i length)
+	(declare (type fixnum i))
+	(setf (char result i) (code-char (system:sap-ref-8 sap i))))
+      result)))
+
+#+(and sbcl (not sb-unicode))
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type sb-sys:system-area-pointer sap)
+	   (type (or null fixnum) length))
+  (locally
+   (declare (optimize (speed 3) (safety 0)))
+   (let ((null-terminated-length
+	  (when null-terminated-p
+	    (loop
+	     for offset of-type fixnum upfrom 0
+	     until (zerop (sb-sys:sap-ref-8 sap offset))
+	     finally (return offset)))))
+     (if length
+	 (if (and null-terminated-length
+		  (> (the fixnum length) (the fixnum null-terminated-length)))
+	     (setq length null-terminated-length))
+       (setq length null-terminated-length)))
+   (let ((result (make-string length)))
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+		(* length +system-copy-multiplier+))
+       result)))
+
+#+(and sbcl sb-unicode)
+(defun sbcl-naturalize-cstring (sap &key length (null-terminated-p t))
+  (declare (type sb-sys:system-area-pointer sap)
+	   (type (or null fixnum) length))
+  (locally
+   (declare (optimize (speed 3) (safety 0)))
+   (cond
+    (null-terminated-p
+     (let ((casted (sb-alien:cast (sb-alien:sap-alien sap (* char))
+				  #+sb-unicode sb-alien:utf8-string
+				  #-sb-unicode sb-alien:c-string)))
+       (if length
+	   (copy-seq (subseq casted 0 length))
+	 (copy-seq casted))))
+    (t
+     (let ((result (make-string length)))
+       ;; this will not work in sb-unicode
+       (funcall *system-copy-fn* sap 0 result +system-copy-offset+
+		(* length +system-copy-multiplier+))
+       result)))))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+   (def-function "strlen"
+     ((str (* :unsigned-char)))
+     :returning :unsigned-int))
+
+(def-type char-ptr-def (* :unsigned-char))
+
+#+(or (and allegro (not ics)) (and lispworks (not lispworks5)))
+(defun fast-native-to-string (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+	   (type char-ptr-def s))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
+    (declare (fixnum len)
+	     (type (simple-array #+lispworks base-char
+                                 #-lispworks (signed-byte 8) (*)) str))
+    (dotimes (i len str)
+      (setf (aref str i)
+	(uffi:deref-array s '(:array :char) i)))))
+
+#+(or (and allegro ics) lispworks5)
+(defun fast-native-to-string (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+	   (type char-ptr-def s))
+  (let* ((len (or len (strlen s)))
+         (str (make-string len)))
+      (dotimes (i len str)
+        (setf (schar str i) (code-char (uffi:deref-array s '(:array :unsigned-byte) i))))))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,30 @@
+# FILE IDENTIFICATION
+#
+#  Name:         Makefile
+#  Purpose:      Makefile for UFFI examples
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile 10614 2005-07-06 01:05:14Z kevin $
+#
+# This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+
+SUBDIRS=
+
+include ../Makefile.common
+
+base=uffi-c-test
+source=$(base).c
+object=$(base).o
+shared_lib=$(base).so
+
+.PHONY: all
+all: $(shared_lib)
+
+$(shared_lib): $(source) Makefile
+	BASE=$(base) OBJECT=$(object) SOURCE=$(source) SHARED_LIB=$(shared_lib) sh make.sh
+	rm $(object)
+
+.PHONY: distclean
+distclean: clean
+	rm -f $(base).dylib $(base).dylib $(base).so $(base).o

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile.msvc
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/Makefile.msvc	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,28 @@
+# FILE IDENTIFICATION
+# 
+#  Name:         Makefile.msvc
+#  Purpose:      Makefile for the CLSQL UFFI helper package (MSVC)
+#  Programer:    Kevin M. Rosenberg
+#  Date Started: Mar 2002
+#
+#  CVS Id:   $Id: Makefile.msvc,v 1.1 2002/03/23 10:26:03 kevin Exp $
+#
+# This file, part of CLSQL, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+#
+
+BASE=c-test-fns
+
+# Nothing to configure beyond here
+
+SRC=$(BASE).c
+OBJ=$(BASE).obj
+DLL=$(BASE).dll
+
+$(DLL): $(SRC)
+	cl /MD /LD -D_MT /DWIN32=1 $(SRC)
+        del $(OBJ) $(BASE).exp
+
+clean:
+        del /q $(DLL)
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/arrays.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/arrays.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,57 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          arrays.lisp
+;;;; Purpose:       UFFI test arrays
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: arrays.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-constant +column-length+ 10)
+(uffi:def-constant +row-length+ 10)
+
+(uffi:def-foreign-type long-ptr (* :long))
+
+(deftest :array.1
+    (let ((a (uffi:allocate-foreign-object :long +column-length+))
+	  (results nil))
+      (dotimes (i +column-length+)
+	(setf (uffi:deref-array a '(:array :long) i) (* i i)))
+      (dotimes (i +column-length+)
+	(push (uffi:deref-array a '(:array :long) i) results))
+      (uffi:free-foreign-object a)
+      (nreverse results))
+  (0 1 4 9 16 25 36 49 64 81))
+
+
+(deftest :array.2
+    (let ((a (uffi:allocate-foreign-object 'long-ptr +row-length+))
+	  (results nil))
+      (dotimes (r +row-length+)
+	(declare (fixnum r))
+	(setf (uffi:deref-array a '(:array (* :long)) r)
+	      (uffi:allocate-foreign-object :long +column-length+))
+	(let ((col (uffi:deref-array a '(:array (* :long)) r)))
+	  (dotimes (c +column-length+)
+	    (declare (fixnum c))
+	    (setf (uffi:deref-array col '(:array :long) c) (+ (* r +column-length+) c)))))
+      
+      (dotimes (r +row-length+)
+	(declare (fixnum r))
+	(let ((col (uffi:deref-array a '(:array (* :long)) r)))
+	  (dotimes (c +column-length+)
+	    (declare (fixnum c))
+	    (push (uffi:deref-array col '(:array :long) c) results))))
+      (uffi:free-foreign-object a)
+      (nreverse results))
+  (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99))
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/atoifl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/atoifl.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,42 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          atoifl.lisp
+;;;; Purpose:       UFFI Example file to atoi/atof/atol
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: atoifl.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("atoi" c-atoi) 
+    ((str :cstring))
+  :returning :int)
+
+(uffi:def-function ("atol" c-atol) 
+    ((str :cstring))
+  :returning :long)
+
+(uffi:def-function ("atof" c-atof) 
+    ((str :cstring))
+  :returning :double)
+
+(defun atoi (str)
+  "Returns a int from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atoi str-cstring)))
+
+(defun atof (str)
+  "Returns a double float from a string."
+  (uffi:with-cstring (str-cstring str)
+    (c-atof str-cstring)))
+  
+(deftest :atoi.1 (atoi "123") 123)
+(deftest :atoi.2 (atoi "") 0)
+(deftest :atof.3 (atof "2.23") 2.23d0)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/casts.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/casts.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,51 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICAION
+;;;;
+;;;; Name:          casts.lisp
+;;;; Purpose:       Tests of with-cast-pointer
+;;;; Programmer:    Kevin M. Rosenberg / Edi Weitz
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id: casts.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("cast_test_int" cast-test-int)
+    ()
+  :module "uffi_tests"
+  :returning :pointer-void)
+
+(uffi:def-function ("cast_test_float" cast-test-float)
+    ()
+  :module "uffi_tests"
+  :returning :pointer-void)
+
+(deftest :cast.1
+  (progn
+    (uffi:with-cast-pointer (temp (cast-test-int) :int)
+      (assert (= (uffi:deref-pointer temp :int) 23)))
+    (let ((result (cast-test-int)))
+      (uffi:with-cast-pointer (result2 result :int)
+	(assert (= (uffi:deref-pointer result2 :int) 23)))
+      (uffi:with-cast-pointer (temp result :int)
+	(assert (= (uffi:deref-pointer temp :int) 23))))
+    t)
+  t)
+
+(deftest :cast.2
+    (progn
+      (uffi:with-cast-pointer (temp (cast-test-float) :double)
+	(assert (= (uffi:deref-pointer temp :double) 3.21d0)))
+      (let ((result (cast-test-float)))
+	(uffi:with-cast-pointer (result2 result :double)
+	  (assert (= (uffi:deref-pointer result2 :double) 3.21d0)))
+	(uffi:with-cast-pointer (temp result :double)
+	  (assert (= (uffi:deref-pointer temp :double) 3.21d0))))
+      t)
+  t)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/compress.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/compress.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,92 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          compress.lisp
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: compress.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-function ("compress" c-compress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+  
+(defun compress (source)
+  "Returns two values: array of bytes containing the compressed data
+ and the numbe of compressed bytes"
+  (let* ((sourcelen (length source))
+	 (destsize (+ 12 (ceiling (* sourcelen 1.01))))
+	 (dest (uffi:allocate-foreign-string destsize :unsigned t))
+	 (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-compress dest destlen source-native sourcelen))
+	    (newdestlen (uffi:deref-pointer destlen :long)))
+	(unwind-protect
+	    (if (zerop result)
+		(values (uffi:convert-from-foreign-usb8 
+			 dest newdestlen)
+			newdestlen)
+	      (error "zlib error, code ~D" result))
+	  (progn
+	    (uffi:free-foreign-object destlen)
+	    (uffi:free-foreign-object dest)))))))
+
+(uffi:def-function ("uncompress" c-uncompress)
+    ((dest (* :unsigned-char))
+     (destlen (* :long))
+     (source :cstring)
+     (source-len :long))
+  :returning :int
+  :module "zlib")
+
+(defun uncompress (source)
+  (let* ((sourcelen (length source))
+	 (destsize 200000)  ;adjust as needed
+	 (dest (uffi:allocate-foreign-string destsize :unsigned t))
+	 (destlen (uffi:allocate-foreign-object :long)))
+    (setf (uffi:deref-pointer destlen :long) destsize)
+    (uffi:with-cstring (source-native source)
+      (let ((result (c-uncompress dest destlen source-native sourcelen))
+	    (newdestlen (uffi:deref-pointer destlen :long)))
+	(unwind-protect
+	     (if (zerop result)
+		 (uffi:convert-from-foreign-string 
+		  dest
+		  :length newdestlen
+		  :null-terminated-p nil)
+		 (error "zlib error, code ~D" result))
+	  (progn
+	    (uffi:free-foreign-object destlen)
+	    (uffi:free-foreign-object dest)))))))
+
+(deftest :compress.1 (compress "")
+  #(120 156 3 0 0 0 0 1) 8)
+(deftest :compress.2  (compress "test")
+  #(120 156 43 73 45 46 1 0 4 93 1 193) 12)
+(deftest :compress.3 (compress "test2")
+  #(120 156 43 73 45 46 49 2 0 6 80 1 243) 13)
+
+(defun compress-uncompress (str)
+  (multiple-value-bind (compressed len) (compress str)
+    (declare (ignore len))
+    (multiple-value-bind (uncompressed len2) (uncompress compressed)
+      (declare (ignore len2))
+      uncompressed)))
+
+
+(deftest :uncompress.1 "" "")
+(deftest :uncompress.2 "test" "test")
+(deftest :uncompress.3 "test2" "test2")

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-loader.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-loader.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,47 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          foreign-loader.lisp
+;;;; Purpose:       Loads foreign libraries
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: foreign-loader.lisp 11021 2006-08-14 04:22:28Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+;;; For CMUCL, it's necessary to load foreign files separate from their
+;;; usage
+
+(in-package uffi-tests)
+
+#+clisp (uffi:load-foreign-library "/usr/lib/libz.so" :module "z")
+#-clisp
+(unless (uffi:load-foreign-library
+	 (uffi:find-foreign-library
+	  #-(or macosx darwin)
+	  "libz"
+	  #+(or macosx darwin)
+	  "z"
+	  (list (pathname-directory *load-pathname*)
+		"/usr/local/lib/" #+(or 64bit x86-64) "/usr/lib64/"
+		"/usr/lib/" "/zlib/"))
+	 :module "zlib"
+	 :supporting-libraries '("c"))
+  (warn "Unable to load zlib"))
+
+#+clisp (uffi:load-foreign-library "/home/kevin/debian/src/uffi/tests/uffi-c-test.so" :module "uffi_tests")
+#-clisp
+(unless (uffi:load-foreign-library
+	 (uffi:find-foreign-library
+	  '(#+(or 64bit x86-64) "uffi-c-test64" "uffi-c-test")
+	  (list (pathname-directory *load-truename*)
+		"/usr/lib/uffi/"
+		"/home/kevin/debian/src/uffi/tests/"))
+	 :supporting-libraries '("c")
+	 :module "uffi_tests")
+  (warn "Unable to load uffi-c-test library"))
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-var.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/foreign-var.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,88 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          foreign-var
+;;;; Purpose:       Tests of foreign variables
+;;;; Authors:       Kevin M. Rosenberg and Edi Weitz
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id: foreign-var.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(def-foreign-var "uchar_13" :unsigned-byte "uffi_tests")
+(def-foreign-var "schar_neg_120" :byte "uffi_tests")
+(def-foreign-var "uword_257" :unsigned-short "uffi_tests")
+(def-foreign-var "sword_neg_321" :short "uffi_tests")
+(def-foreign-var "uint_1234567" :int "uffi_tests")
+(def-foreign-var "sint_neg_123456" :int "uffi_tests")
+(def-foreign-var "float_neg_4_5" :float "uffi_tests")
+(def-foreign-var "double_3_1" :double "uffi_tests")
+
+(deftest :fvar.1 uchar-13 13)
+(deftest :fvar.2 schar-neg-120 -120)
+(deftest :fvar.3 uword-257 257)
+(deftest :fvar.4 sword-neg-321 -321)
+(deftest :fvar.5 uint-1234567 1234567)
+(deftest :fvar.6 sint-neg-123456 -123456)
+(deftest :fvar.7 float-neg-4-5 -4.5f0)
+(deftest :fvar.8 double-3-1 3.1d0)
+
+(uffi:def-foreign-var ("fvar_addend" *fvar-addend*) :int "uffi_tests")
+
+(uffi:def-struct fvar-struct
+    (i :int)
+  (d :double))
+ 
+(uffi:def-foreign-var ("fvar_struct" *fvar-struct*) fvar-struct
+  "uffi_tests")
+
+(uffi:def-function ("fvar_struct_int" fvar-struct-int)
+    ()
+  :returning :int
+  :module "uffi_tests")
+ 
+  (uffi:def-function ("fvar_struct_double" fvar-struct-double)
+      ()
+    :returning :double
+    :module "uffi_tests")
+ 
+(deftest :fvarst.1 *fvar-addend* 3)
+(deftest :fvarst.2 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 42)
+(deftest :fvarst.3 (= (+ *fvar-addend*
+			(uffi:get-slot-value *fvar-struct* 'fvar-struct 'i))
+		     (fvar-struct-int))
+  t)
+(deftest :fvarst.4 (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd) 3.2d0)
+(deftest :fvarst.5 (= (uffi:get-slot-value *fvar-struct* 'fvar-struct 'd)
+		     (fvar-struct-double))
+  t)
+
+(deftest fvarst.6 
+    (let ((orig *fvar-addend*))
+      (incf *fvar-addend* 3)
+      (prog1
+	  *fvar-addend*
+	(setf *fvar-addend* orig)))
+  6)
+
+(deftest fvarst.7 
+    (let ((orig *fvar-addend*))
+      (incf *fvar-addend* 3)
+      (prog1
+	  (fvar-struct-int)
+	(setf *fvar-addend* orig)))
+  48)
+
+(deftest fvarst.8 
+    (let ((orig (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i)))
+      (decf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) 10)
+      (prog1
+	  (fvar-struct-int)
+	(setf (uffi:get-slot-value *fvar-struct* 'fvar-struct 'i) orig)))
+  35)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/getenv.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/getenv.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,64 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          getenv.lisp
+;;;; Purpose:       UFFI Example file to get environment variable
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: getenv.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+(uffi:def-function ("getenv" c-getenv) 
+    ((name :cstring))
+  :returning :cstring)
+
+(uffi:def-function ("setenv" c-setenv) 
+    ((name :cstring)
+     (value :cstring)
+     (overwrite :int))
+  :returning :int)
+
+(uffi:def-function ("unsetenv" c-unsetenv)
+    ((name :cstring))
+  :returning :void)
+
+(defun my-getenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstring (key-native key)
+    (uffi:convert-from-cstring (c-getenv key-native))))
+
+(defun my-setenv (key name &optional (overwrite t))
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (check-type name string)
+  (setq overwrite (if overwrite 1 0))
+  (uffi:with-cstrings ((key-native key)
+		       (name-native name))
+    (c-setenv key-native name-native (if overwrite 1 0))))
+
+(defun my-unsetenv (key)
+  "Returns an environment variable, or NIL if it does not exist"
+  (check-type key string)
+  (uffi:with-cstrings ((key-native key))
+    (c-unsetenv key-native)))
+
+(deftest :getenv.1 (progn
+		    (my-unsetenv "__UFFI_FOO1__")
+		    (my-getenv "__UFFI_FOO1__"))
+  nil)
+(deftest :getenv.2 (progn
+		    (my-setenv "__UFFI_FOO1__" "UFFI-TEST")
+		    (my-getenv "__UFFI_FOO1__"))
+  "UFFI-TEST")
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/gethostname.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/gethostname.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,52 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gethostname.lisp
+;;;; Purpose:       UFFI Example file to get hostname of system
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: gethostname.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+;;; This example is inspired by the example on the CL-Cookbook web site
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (uffi:def-function ("gethostname" c-gethostname) 
+      ((name (* :unsigned-char))
+       (len :int))
+    :returning :int)
+  
+  (defun gethostname ()
+    "Returns the hostname"
+    (let* ((name (uffi:allocate-foreign-string 256))
+	   (result-code (c-gethostname name 256))
+	   (hostname (when (zerop result-code)
+		       (uffi:convert-from-foreign-string name))))
+      (uffi:free-foreign-object name)
+      (unless (zerop result-code)
+	(error "gethostname() failed."))
+      hostname))
+  
+  (defun gethostname2 ()
+    "Returns the hostname"
+    (uffi:with-foreign-object (name '(:array :unsigned-char 256))
+      (if (zerop (c-gethostname (uffi:char-array-to-pointer name) 256))
+	  (uffi:convert-from-foreign-string name)
+	  (error "gethostname() failed.")))))
+
+(deftest :gethostname.1 (stringp (gethostname)) t)
+(deftest :gethostname.2 (stringp (gethostname2)) t)
+(deftest :gethostname.3 (plusp (length (gethostname))) t)
+(deftest :gethostname.4 (plusp (length (gethostname2))) t)
+(deftest :gethostname.5 (string= (gethostname) (gethostname2)) t)
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/make.sh
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/make.sh	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,45 @@
+#!/bin/sh
+
+case "`uname`" in
+    Linux) os_linux=1 ;;
+    FreeBSD) os_freebsd=1 ;;
+    GNU/kFreeBSD) os_gnukfreebsd=1;;
+    Darwin) os_darwin=1 ;;
+    SunOS) os_sunos=1 ;;
+    AIX) os_aix=1 ;;
+    GNU) os_gnu=1 ;;
+    *) echo "Unable to identify uname " `uname`
+       exit 1 ;;
+esac
+
+if [ "$os_linux" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_gnu" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_freebsd" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_gnukfreebsd" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
+elif [ "$os_darwin" ]; then
+    cc -dynamic -c $SOURCE -o $OBJECT
+    ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT
+    ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress /usr/lib/libz.dylib -o z.dylib
+
+elif [ "$os_sunos" ]; then
+    cc -KPIC -c $SOURCE -o $OBJECT
+    cc -G $OBJECT -o $SHARED_LIB
+
+elif [ "$os_aix" ]; then
+    gcc -c -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void $SOURCE
+    make_shared -o $SHARED_LIB $OBJECT
+fi
+
+exit 0

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/objects.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/objects.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,70 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          pointers.lisp
+;;;; Purpose:       Test file for UFFI pointers
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id: objects.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(deftest :chptr.1
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+	(ensure-char-character
+	 (deref-pointer fs :char))))
+  #\t)
+
+(deftest :chptr.2
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+	(ensure-char-character
+	 (deref-pointer fs :unsigned-char))))
+  #\t)
+
+(deftest :chptr.3
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+	(ensure-char-integer
+	 (deref-pointer fs :unsigned-char))))
+  116)
+
+(deftest :chptr.4
+    (let ((native-string "test string"))
+      (uffi:with-foreign-string (fs native-string)
+	(integerp
+	 (ensure-char-integer
+	  (deref-pointer fs :unsigned-char)))))
+  t)
+	
+(deftest :chptr.5
+    (let ((fs (uffi:allocate-foreign-object :unsigned-char 128)))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+	    (uffi:ensure-char-storable #\a))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+	    (uffi:ensure-char-storable (code-char 0)))
+      (uffi:convert-from-foreign-string fs))
+  "a")
+
+;; This produces an array which needs fli:foreign-aref to access
+;; rather than fli:dereference
+
+#-lispworks
+(deftest :chptr.6
+    (uffi:with-foreign-object (fs '(:array :unsigned-char 128))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 0)
+	    (uffi:ensure-char-storable #\a))
+      (setf (uffi:deref-array fs '(:array :unsigned-char) 1)
+	    (uffi:ensure-char-storable (code-char 0)))
+      (uffi:convert-from-foreign-string fs))
+  "a")
+
+      
+				  

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/package.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,20 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          package.lisp
+;;;; Purpose:       Package file uffi testing suite
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2003-2005 by Kevin M. Rosenberg
+;;;;
+;;;; $Id: package.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;; *************************************************************************
+
+(defpackage #:uffi-tests
+  (:use #:asdf #:cl #:uffi #:rtest)
+  (:shadowing-import-from #:uffi #:run-shell-command))
+
+(in-package #:uffi-tests)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/rt.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/rt.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,254 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ |                                                                            |
+ | Permission  to  use,  copy, modify, and distribute this software  and  its |
+ | documentation for any purpose  and without fee is hereby granted, provided |
+ | that this copyright  and  permission  notice  appear  in  all  copies  and |
+ | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
+ | advertising or  publicity  pertaining  to  distribution  of  the  software |
+ | without   specific,   written   prior   permission.      M.I.T.  makes  no |
+ | representations  about  the  suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty.                |
+ |                                                                            |
+ |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
+ |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
+ |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
+ |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
+ |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
+ |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
+ |  SOFTWARE.                                                                 |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+  (:nicknames #:rtest #-lispworks #:rt) 
+  (:use #:cl)
+  (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+	   #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+	   #:rem-all-tests #:rem-test)
+  (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+  "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+  "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+  "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+		  (:type list))
+  pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+  (do ((l (cdr *entries*) (cdr l))
+       (r nil))
+      ((null l) (nreverse r))
+    (when (pend (car l))
+      (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+  (setq *entries* (list nil))
+  nil)
+
+(defun rem-test (&optional (name *test*))
+  (do ((l *entries* (cdr l)))
+      ((null (cdr l)) nil)
+    (when (equal (name (cadr l)) name)
+      (setf (cdr l) (cddr l))
+      (return name))))
+
+(defun get-test (&optional (name *test*))
+  (defn (get-entry name)))
+
+(defun get-entry (name)
+  (let ((entry (find name (cdr *entries*)
+		     :key #'name
+		     :test #'equal)))
+    (when (null entry)
+      (report-error t
+        "~%No test with name ~:@(~S~)."
+	name))
+    entry))
+
+(defmacro deftest (name form &rest values)
+  `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+  (setq entry (copy-list entry))
+  (do ((l *entries* (cdr l))) (nil)
+    (when (null (cdr l))
+      (setf (cdr l) (list entry))
+      (return nil))
+    (when (equal (name (cadr l)) 
+		 (name entry))
+      (setf (cadr l) entry)
+      (report-error nil
+        "Redefining test ~:@(~S~)"
+        (name entry))
+      (return nil)))
+  (when *do-tests-when-defined*
+    (do-entry entry))
+  (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+  (cond (*debug* 
+	 (apply #'format t args)
+	 (if error? (throw '*debug* nil)))
+	(error? (apply #'error args))
+	(t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+  (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+  "Like EQUALP, but doesn't do case conversion of characters."
+  (cond
+   ((eq x y) t)
+   ((consp x)
+    (and (consp y)
+	 (equalp-with-case (car x) (car y))
+	 (equalp-with-case (cdr x) (cdr y))))
+   ((and (typep x 'array)
+	 (= (array-rank x) 0))
+    (equalp-with-case (aref x) (aref y)))
+   ((typep x 'vector)
+    (and (typep y 'vector)
+	 (let ((x-len (length x))
+	       (y-len (length y)))
+	   (and (eql x-len y-len)
+		(loop
+		 for e1 across x
+		 for e2 across y
+		 always (equalp-with-case e1 e2))))))
+   ((and (typep x 'array)
+	 (typep y 'array)
+	 (not (equal (array-dimensions x)
+		     (array-dimensions y))))
+    nil)
+   ((typep x 'array)
+    (and (typep y 'array)
+	 (let ((size (array-total-size x)))
+	   (loop for i from 0 below size
+		 always (equalp-with-case (row-major-aref x i)
+					  (row-major-aref y i))))))
+   (t (eql x y))))
+
+(defun do-entry (entry &optional
+		       (s *standard-output*))
+  (catch '*in-test*
+    (setq *test* (name entry))
+    (setf (pend entry) t)
+    (let* ((*in-test* t)
+	   ;; (*break-on-warnings* t)
+	   (aborted nil)
+	   r)
+      ;; (declare (special *break-on-warnings*))
+
+      (block aborted
+	(setf r
+	      (flet ((%do
+		      ()
+		      (if *compile-tests*
+			  (multiple-value-list
+			   (funcall (compile
+				     nil
+				     `(lambda ()
+					(declare
+					 (optimize ,@*optimization-settings*))
+					,(form entry)))))
+			(multiple-value-list
+			 (eval (form entry))))))
+		(if *catch-errors*
+		    (handler-bind
+			((style-warning #'muffle-warning)
+			 (error #'(lambda (c)
+				    (setf aborted t)
+				    (setf r (list c))
+				    (return-from aborted nil))))
+		      (%do))
+		  (%do)))))
+
+      (setf (pend entry)
+	    (or aborted
+		(not (equalp-with-case r (vals entry)))))
+      
+      (when (pend entry)
+	(let ((*print-circle* *print-circle-on-failure*))
+	  (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+		  *test* (form entry)
+		  (length (vals entry))
+		  (vals entry))
+	  (format s "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+		  (length r) r)))))
+  (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+  (if *in-test*
+      (throw '*in-test* nil)
+      (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+		 (out *standard-output*))
+  (dolist (entry (cdr *entries*))
+    (setf (pend entry) t))
+  (if (streamp out)
+      (do-entries out)
+      (with-open-file 
+	  (stream out :direction :output)
+	(do-entries stream))))
+
+(defun do-entries (s)
+  (format s "~&Doing ~A pending test~:P ~
+             of ~A tests total.~%"
+          (count t (cdr *entries*)
+		 :key #'pend)
+	  (length (cdr *entries*)))
+  (dolist (entry (cdr *entries*))
+    (when (pend entry)
+      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+	      (do-entry entry s))))
+  (let ((pending (pending-tests))
+	(expected-table (make-hash-table :test #'equal)))
+    (dolist (ex *expected-failures*)
+      (setf (gethash ex expected-table) t))
+    (let ((new-failures
+	   (loop for pend in pending
+		 unless (gethash pend expected-table)
+		 collect pend)))
+      (if (null pending)
+	  (format s "~&No tests failed.")
+	(progn
+	  (format s "~&~A out of ~A ~
+                   total tests failed: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		  (length pending)
+		  (length (cdr *entries*))
+		  pending)
+	  (if (null new-failures)
+	      (format s "~&No unexpected failures.")
+	    (when *expected-failures*
+	      (format s "~&~A unexpected failures: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		    (length new-failures)
+		    new-failures)))
+	  ))
+      (null pending))))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/strtol.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/strtol.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,64 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          strtol.lisp
+;;;; Purpose:       UFFI Example file to strtol, uses pointer arithmetic
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: strtol.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-foreign-type char-ptr (* :unsigned-char))
+  
+;; This example does not use :cstring to pass the input string since
+;; the routine needs to do pointer arithmetic to see how many characters
+;; were parsed
+
+(uffi:def-function ("strtol" c-strtol) 
+    ((nptr char-ptr)
+     (endptr (* char-ptr))
+     (base :int))
+  :returning :long)
+
+(defun strtol (str &optional (base 10))
+  "Returns a long int from a string. Returns number and condition flag.
+Condition flag is T if all of string parses as a long, NIL if
+their was no string at all, or an integer indicating position in string
+of first non-valid character"
+  (let* ((str-native (uffi:convert-to-foreign-string str))
+	 (endptr (uffi:allocate-foreign-object 'char-ptr))
+	 (value (c-strtol str-native endptr base))
+	 (endptr-value (uffi:deref-pointer endptr 'char-ptr)))
+
+    (unwind-protect
+	 (if (uffi:null-pointer-p endptr-value)
+	     (values value t)
+	     (let ((next-char-value (uffi:deref-pointer endptr-value :unsigned-char))
+		   (chars-parsed (- (uffi:pointer-address endptr-value)
+				    (uffi:pointer-address str-native))))
+	       (cond
+		 ((zerop chars-parsed)
+		  (values nil nil))
+		 ((uffi:null-char-p next-char-value)
+		  (values value t))
+		 (t
+		  (values value chars-parsed)))))
+      (progn
+	(uffi:free-foreign-object str-native)
+	(uffi:free-foreign-object endptr)))))
+
+(deftest :strtol.1 (strtol "123") 123 t)
+(deftest :strtol.2 (strtol "0") 0 t)
+(deftest :strtol.3 (strtol "55a") 55 2)
+(deftest :strtol.4 (strtol "a") nil nil)
+
+
+			   
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,36 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          structs.lisp
+;;;; Purpose:       Test file for UFFI structures
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: structs.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+;; Compilation failure as reported by Edi Weitz
+
+
+(uffi:def-struct foo
+    (bar :pointer-self))
+
+(uffi:def-foreign-type foo-ptr (* foo))
+
+;; tests that compilation worked
+(deftest :structs.1 
+  (with-foreign-object (p 'foo)
+    t)
+  t)
+
+(deftest :structs.2
+    (progn
+      (uffi:def-foreign-type foo-struct (:struct foo))
+      t)
+  t)

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/time.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/time.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,110 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          time.lisp
+;;;; Purpose:       UFFI test file, time, use C structures
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: time.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-foreign-type time-t :unsigned-long)
+
+(uffi:def-struct tm
+    (sec :int)
+  (min :int)
+  (hour :int)
+  (mday :int)
+  (mon :int)
+  (year :int)
+  (wday :int)
+  (yday :int)
+  (isdst :int)
+  ;; gmoffset present on SusE SLES9
+  (gmoffset :long))
+
+(uffi:def-function ("time" c-time) 
+    ((time (* time-t)))
+  :returning time-t)
+
+(uffi:def-function "gmtime"
+    ((time (* time-t)))
+  :returning (:struct-pointer tm))
+
+(uffi:def-function "asctime"
+    ((time (:struct-pointer tm)))
+  :returning :cstring)
+
+(uffi:def-type time-t :unsigned-long)
+(uffi:def-type tm-pointer (:struct-pointer tm))
+
+(deftest :time.1
+   (uffi:with-foreign-object (time 'time-t)
+     (setf (uffi:deref-pointer time :unsigned-long) 7381)
+     (uffi:deref-pointer time :unsigned-long))
+  7381)
+
+(deftest :time.2
+  (uffi:with-foreign-object (time 'time-t)
+    (setf (uffi:deref-pointer time :unsigned-long) 7381)
+    (let ((tm-ptr (the tm-pointer (gmtime time))))
+      (values (1+ (uffi:get-slot-value tm-ptr 'tm 'mon))
+	      (uffi:get-slot-value tm-ptr 'tm 'mday)
+	      (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year))
+	      (uffi:get-slot-value tm-ptr 'tm 'hour)
+	      (uffi:get-slot-value tm-ptr 'tm 'min)
+	      (uffi:get-slot-value tm-ptr 'tm 'sec)
+	      )))
+  1 1 1970 2 3 1)
+
+
+(uffi:def-struct timeval 
+    (secs :long)
+  (usecs :long))
+
+(uffi:def-struct timezone
+    (minutes-west :int)
+  (dsttime :int))
+
+(uffi:def-function ("gettimeofday" c-gettimeofday) 
+    ((tv (* timeval))
+     (tz (* timezone)))
+  :returning :int)
+		    
+(defun get-utime ()
+  (uffi:with-foreign-object (tv 'timeval)
+    (let ((res (c-gettimeofday tv (uffi:make-null-pointer 'timezone))))
+      (values
+       (+ (* 1000000 (uffi:get-slot-value tv 'timeval 'secs))
+	  (uffi:get-slot-value tv 'timeval 'usecs))
+       res))))
+
+(deftest :timeofday.1
+    (multiple-value-bind (t1 res1) (get-utime)
+      (multiple-value-bind (t2 res2) (get-utime)
+	(and (or (= t2 t1) (> t2 t1))
+	     (> t1 1000000000)
+	     (> t2 1000000000)
+	     (zerop res1)
+	     (zerop res2))))
+  t)
+	     
+(defun posix-time-to-asctime (secs)
+  "Converts number of seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal Time (UTC)"
+  (string-right-trim
+   '(#\newline #\return)
+   (uffi:convert-from-cstring
+    (uffi:with-foreign-object (time 'time-t)
+      (setf (uffi:deref-pointer time :unsigned-long) secs)
+      (asctime (gmtime time))))))
+
+(deftest :time.3
+    (posix-time-to-asctime 0)
+  "Thu Jan  1 00:00:00 1970")

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test-lib.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test-lib.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,98 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi-c-test-lib.lisp
+;;;; Purpose:       UFFI Example file for zlib compression
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: uffi-c-test-lib.lisp 10608 2005-07-01 00:39:48Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+
+(uffi:def-function ("cs_to_upper" cs-to-upper)
+  ((input (* :unsigned-char)))
+  :returning :void
+  :module "uffi_tests")
+
+(defun string-to-upper (str)
+  (uffi:with-foreign-string (str-foreign str)
+    (cs-to-upper str-foreign)
+    (uffi:convert-from-foreign-string str-foreign)))
+
+(uffi:def-function ("cs_count_upper" cs-count-upper)
+  ((input :cstring))
+  :returning :int
+  :module "uffi_tests")
+
+(defun string-count-upper (str)
+  (uffi:with-cstring (str-cstring str)
+    (cs-count-upper str-cstring))) 
+
+(uffi:def-function ("half_double_vector" half-double-vector)
+    ((size :int)
+     (vec (* :double)))
+  :returning :void
+  :module "uffi_tests")
+
+(uffi:def-function ("return_long_negative_one" return-long-negative-one)
+    ()
+  :returning :long
+  :module "uffi_tests")
+
+(uffi:def-function ("return_int_negative_one" return-int-negative-one)
+    ()
+  :returning :int
+  :module "uffi_tests")
+
+(uffi:def-function ("return_short_negative_one" return-short-negative-one)
+    ()
+  :returning :short
+  :module "uffi_tests")
+
+
+(uffi:def-constant +double-vec-length+ 10)
+(defun test-half-double-vector ()
+  (let ((vec (uffi:allocate-foreign-object :double +double-vec-length+))
+	results)
+    (dotimes (i +double-vec-length+)
+      (setf (uffi:deref-array vec '(:array :double) i) 
+	    (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    (dotimes (i +double-vec-length+)
+      (push (uffi:deref-array vec '(:array :double) i) results))
+    (uffi:free-foreign-object vec)
+    (nreverse results)))
+
+(defun t2 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (half-double-vector +double-vec-length+ vec)
+    vec))
+
+#+(or cmu scl)
+(defun t3 ()
+  (let ((vec (make-array +double-vec-length+ :element-type 'double-float)))
+    (dotimes (i +double-vec-length+)
+      (setf (aref vec i) (coerce i 'double-float)))
+    (system:without-gcing
+     (half-double-vector +double-vec-length+ (system:vector-sap vec)))
+    vec))
+    
+(deftest :c-test.1 (string-to-upper "this is a test") "THIS IS A TEST")
+(deftest :c-test.2 (string-to-upper nil) nil)
+(deftest :c-test.3 (string-count-upper "This is a Test") 2)
+(deftest :c-test.4 (string-count-upper nil) -1)
+(deftest :c-test.5 (test-half-double-vector)
+  (0.0d0 0.5d0 1.0d0 1.5d0 2.0d0 2.5d0 3.0d0 3.5d0 4.0d0 4.5d0))
+(deftest :c-test.6 (return-long-negative-one) -1)
+(deftest :c-test.7 (return-int-negative-one) -1)
+(deftest :c-test.8 (return-short-negative-one) -1)
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test.c
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/uffi-c-test.c	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,158 @@
+/***************************************************************************
+ * FILE IDENTIFICATION
+ *  
+ *  Name:         c-test-fns.c
+ *  Purpose:      Test functions in C for UFFI library
+ *  Programer:    Kevin M. Rosenberg
+ *  Date Started: Mar 2002
+ *
+ *  CVS Id:   $Id: uffi-c-test.c 10614 2005-07-06 01:05:14Z kevin $
+ *
+ * This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+ *
+ * These variables are correct for GCC
+ * you'll need to modify these for other compilers
+ ***************************************************************************/
+
+#ifdef WIN32
+#include <windows.h>
+
+BOOL WINAPI DllEntryPoint(HINSTANCE hinstdll,
+                          DWORD fdwReason,
+                          LPVOID lpvReserved)
+{
+        return 1;
+}
+       
+#define DLLEXPORT __declspec(dllexport)
+
+#else
+#define DLLEXPORT 
+#endif
+
+#include <ctype.h>
+#include <stdlib.h>
+#include <math.h>
+
+
+DLLEXPORT unsigned char uchar_13 = 13;
+DLLEXPORT signed char schar_neg_120 = -120;
+DLLEXPORT unsigned short uword_257 = 257;
+DLLEXPORT signed short sword_neg_321 = -321;
+DLLEXPORT unsigned int uint_1234567 = 1234567;
+DLLEXPORT signed int sint_neg_123456 = -123456;
+DLLEXPORT double double_3_1 = 3.1;
+DLLEXPORT float float_neg_4_5 = -4.5;
+
+/* Test of constant input string */
+DLLEXPORT
+int
+cs_count_upper (char* psz)
+{
+  int count = 0;
+
+  if (psz) {
+    while (*psz) {
+      if (isupper (*psz))
+	++count;
+      ++psz;
+    }
+    return count;
+  } else 
+    return -1;
+}
+
+/* Test of input and output of a string */
+DLLEXPORT
+void
+cs_to_upper (char* psz)
+{
+  if (psz) {
+    while (*psz) {
+      *psz = toupper (*psz);
+      ++psz;
+    }
+  }
+}
+
+/* Test of an output only string */
+DLLEXPORT
+void
+cs_make_random (int size, char* buffer)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    buffer[i] = 'A' + (rand() % 26);
+}
+
+    
+/* Test of input/output vector */
+DLLEXPORT
+void
+half_double_vector (int size, double* vec)
+{
+  int i;
+  for (i = 0; i < size; i++)
+    vec[i] /= 2.;
+}
+
+    
+
+DLLEXPORT
+void *
+cast_test_int () {
+  int *x = (int *) malloc(sizeof(int));
+  *x = 23;
+  return x;
+}
+
+DLLEXPORT
+void *
+cast_test_float ()
+{
+  double *y = (double *) malloc(sizeof(double));
+  *y = 3.21;
+  return y;
+}
+
+DLLEXPORT
+long
+return_long_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT
+int
+return_int_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT
+short
+return_short_negative_one ()
+{
+  return -1;
+}
+
+DLLEXPORT int fvar_addend = 3;
+
+typedef struct {
+  int i;
+  double d;
+} fvar_struct_type;
+
+fvar_struct_type fvar_struct = {42, 3.2};
+
+DLLEXPORT
+int fvar_struct_int () {
+  return (fvar_addend + fvar_struct.i);
+}
+
+DLLEXPORT
+double fvar_struct_double () {
+  return fvar_struct.d;
+}
+
+     

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/union.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/union.lisp	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,71 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          union.lisp
+;;;; Purpose:       UFFI Example file to test unions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Mar 2002
+;;;;
+;;;; $Id: union.lisp 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:uffi-tests)
+
+(uffi:def-union tunion1 
+    (char :char)
+  (int :int)
+  (uint :unsigned-int)
+  (sf :float)
+  (df :double))
+
+(defvar *u* (uffi:allocate-foreign-object 'tunion1))
+(setf (uffi:get-slot-value *u* 'tunion1 'uint)
+      #-(or sparc sparc-v9 powerpc ppc)
+      (+ (* 1 (char-code #\A))
+	 (* 256 (char-code #\B))
+	 (* 65536 (char-code #\C))
+	 (* 16777216 128))
+      #+(or sparc sparc-v9 powerpc ppc)
+      (+ (* 16777216 (char-code #\A))
+	 (* 65536 (char-code #\B))
+	 (* 256 (char-code #\C))
+	 (* 1 128)))
+
+(deftest :union.1 
+    (uffi:ensure-char-character 
+     (uffi:get-slot-value *u* 'tunion1 'char))
+  #\A)
+
+(deftest :union.2 
+    (uffi:ensure-char-integer 
+     (uffi:get-slot-value *u* 'tunion1 'char))
+  65)
+
+#-(or sparc sparc-v9 openmcl digitool)
+(deftest :union.3 (plusp (uffi:get-slot-value *u* 'tunion1 'uint)) t)
+
+
+(uffi:def-union foo-u
+    (bar :pointer-self))
+
+(uffi:def-foreign-type foo-u-ptr (* foo-u))
+
+;; tests that compilation worked
+(deftest :unions.4 
+  (with-foreign-object (p 'foo-u)
+    t)
+  t)
+
+(deftest :unions.5
+    (progn
+      (uffi:def-foreign-type foo-union (:union foo-u))
+      t)
+  t)
+
+
+
+

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi-tests.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi-tests.asd	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,95 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi-tests.asd
+;;;; Purpose:       ASDF system definitionf for uffi testing package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id: uffi-tests.asd 10586 2005-06-08 21:51:30Z kevin $
+;;;; *************************************************************************
+
+(defpackage #:uffi-tests-system
+  (:use #:asdf #:cl))
+(in-package #:uffi-tests-system)
+
+(operate 'load-op 'uffi)
+
+(defvar *library-file-dir* (append (pathname-directory *load-truename*)
+				   (list "tests")))
+
+(defclass uffi-test-source-file (c-source-file)
+  ())
+
+(defmethod output-files ((o compile-op) (c uffi-test-source-file))
+  (let* ((library-file-type
+	  (funcall (intern (symbol-name'#:default-foreign-library-type)
+			   (symbol-name '#:uffi))))
+	 (found
+	  (some #'(lambda (dir)
+		    (probe-file (make-pathname
+				 :directory dir
+				 :name (component-name c)
+				 :type library-file-type)))
+		'((:absolute "usr" "lib" "uffi")))))
+    (list (if found
+	      found
+	      (make-pathname :name (component-name c)
+			     :type library-file-type
+			     :directory *library-file-dir*)))))
+
+(defmethod perform ((o load-op) (c uffi-test-source-file))
+  nil) ;;; library will be loaded by a loader file
+
+(defmethod operation-done-p ((o load-op) (c uffi-test-source-file))
+  (and (symbol-function (intern (symbol-name '#:cs-count-upper)
+				(find-package '#:uffi-tests)))
+       t))
+
+(defmethod perform ((o compile-op) (c uffi-test-source-file))
+  (unless (operation-done-p o c)
+    #-(or win32 mswindows)
+    (unless (zerop (run-shell-command
+		    #-freebsd "cd ~A; make"
+		    #+freebsd "cd ~A; gmake"
+		    (namestring (make-pathname :name nil
+					       :type nil
+					       :directory *library-file-dir*))))
+      (error 'operation-error :component c :operation o))))
+
+(defmethod operation-done-p ((o compile-op) (c uffi-test-source-file))
+  (or (and (probe-file #p"/usr/lib/uffi/uffi-c-test.so") t)
+      (let ((lib (make-pathname :defaults (component-pathname c)
+				:type (uffi:default-foreign-library-type))))
+	(and (probe-file lib)
+	     (> (file-write-date lib) (file-write-date (component-pathname c)))))))
+
+(defsystem uffi-tests
+    :depends-on (:uffi)
+    :components
+    ((:module tests
+	      :components
+	      ((:file "rt")
+	       (:file "package" :depends-on ("rt"))
+	       (:uffi-test-source-file "uffi-c-test" :depends-on ("package"))
+	       (:file "strtol" :depends-on ("package"))
+	       (:file "atoifl" :depends-on ("package"))
+	       (:file "getenv" :depends-on ("package"))
+	       (:file "gethostname" :depends-on ("package"))
+	       (:file "union" :depends-on ("package"))
+	       (:file "arrays" :depends-on ("package"))
+	       (:file "structs" :depends-on ("package"))
+	       (:file "objects" :depends-on ("package"))
+	       (:file "time" :depends-on ("package"))
+	       (:file "foreign-loader" :depends-on ("package" "uffi-c-test"))
+	       (:file "uffi-c-test-lib" :depends-on ("foreign-loader"))
+	       (:file "compress" :depends-on ("foreign-loader"))
+	       (:file "casts" :depends-on ("foreign-loader"))
+	       (:file "foreign-var" :depends-on ("foreign-loader"))
+	       ))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :uffi-tests))))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package '#:regression-test)))
+      (error "test-op failed")))

Added: branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/uffi.asd	Mon Feb 11 09:23:05 2008
@@ -0,0 +1,48 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          uffi.asd
+;;;; Purpose:       ASDF system definition file for UFFI package
+;;;; Author:        Kevin M. Rosenberg
+;;;; Date Started:  Aug 2002
+;;;;
+;;;; $Id: uffi.asd 10917 2006-04-18 00:07:09Z kevin $
+;;;;
+;;;; This file, part of UFFI, is Copyright (c) 2002-2005 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(defpackage #:uffi-system (:use #:asdf #:cl))
+(in-package #:uffi-system)
+
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
+(defsystem uffi
+  :name "uffi"
+  :author "Kevin Rosenberg <kevin at rosenberg.net>"
+  :version "1.2.x"
+  :maintainer "Kevin M. Rosenberg <kmr at debian.org>"
+  :licence "Lessor Lisp General Public License"
+  :description "Universal Foreign Function Library for Common Lisp"
+  :long-description "UFFI provides a universal foreign function interface (FFI) for Common Lisp. UFFI supports CMUCL, Lispworks, and AllegroCL."
+
+  :components
+  ((:module :src
+	    :components
+	    ((:file "package")
+	     (:file "primitives" :depends-on ("package"))
+	     #+(or openmcl digitool) (:file "readmacros-mcl" :depends-on ("package"))
+	     (:file "objects" :depends-on ("primitives"))
+	     (:file "aggregates" :depends-on ("primitives"))
+	     (:file "strings" :depends-on ("primitives" "functions" "aggregates" "objects"))
+	     (:file "functions" :depends-on ("primitives"))
+	     (:file "libraries" :depends-on ("package"))
+	     (:file "os" :depends-on ("package"))))
+   ))
+
+#+(or allegro lispworks cmu openmcl digitool cormanlisp sbcl scl)
+(defmethod perform ((o test-op) (c (eql (find-system 'uffi))))
+  (oos 'load-op 'uffi-tests)
+  (oos 'test-op 'uffi-tests :force t))
+
+


From hhubner at common-lisp.net  Mon Feb 11 14:25:00 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 09:25:00 -0500 (EST)
Subject: [bknr-cvs] r2475 - in branches/trunk-reorg/thirdparty/slime: . CVS
	contrib contrib/CVS
Message-ID: <20080211142500.2D6EA7A00B@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 09:24:55 2008
New Revision: 2475

Modified:
   branches/trunk-reorg/thirdparty/slime/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/ChangeLog
   branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
   branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el
   branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el
   branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
   branches/trunk-reorg/thirdparty/slime/slime.el
   branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
   branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
   branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
   branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
   branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
   branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
   branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
   branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
update slime from cvs

Modified: branches/trunk-reorg/thirdparty/slime/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/CVS/Entries	Mon Feb 11 09:24:55 2008
@@ -1,7 +1,6 @@
 D/contrib////
 D/doc////
 /.cvsignore/1.5/Thu Oct 11 14:10:25 2007//
-/ChangeLog/1.1282/Thu Feb  7 08:07:30 2008//
 /HACKING/1.8/Thu Oct 11 14:10:25 2007//
 /NEWS/1.9/Sun Dec  2 04:22:09 2007//
 /PROBLEMS/1.8/Thu Oct 11 14:10:25 2007//
@@ -12,24 +11,25 @@
 /nregex.lisp/1.4/Thu Oct 11 14:10:25 2007//
 /sbcl-pprint-patch.lisp/1.1/Thu Oct 11 14:10:25 2007//
 /slime-autoloads.el/1.4/Thu Feb  7 08:07:30 2008//
-/slime.el/1.901/Thu Feb  7 08:07:31 2008//
-/swank-abcl.lisp/1.45/Thu Feb  7 08:07:31 2008//
-/swank-allegro.lisp/1.99/Thu Feb  7 08:07:31 2008//
-/swank-backend.lisp/1.127/Thu Feb  7 08:07:31 2008//
-/swank-clisp.lisp/1.65/Thu Feb  7 08:07:31 2008//
-/swank-cmucl.lisp/1.176/Thu Feb  7 08:07:31 2008//
-/swank-corman.lisp/1.13/Thu Feb  7 08:07:31 2008//
-/swank-ecl.lisp/1.12/Thu Feb  7 08:07:31 2008//
 /swank-gray.lisp/1.10/Thu Oct 11 14:10:25 2007//
-/swank-lispworks.lisp/1.94/Thu Feb  7 08:07:31 2008//
 /swank-loader.lisp/1.77/Thu Feb  7 08:07:31 2008//
-/swank-openmcl.lisp/1.122/Thu Feb  7 08:07:31 2008//
-/swank-sbcl.lisp/1.189/Thu Feb  7 08:07:31 2008//
-/swank-scl.lisp/1.15/Thu Feb  7 08:07:31 2008//
 /swank-source-file-cache.lisp/1.8/Thu Oct 11 14:10:25 2007//
 /swank-source-path-parser.lisp/1.18/Thu Feb  7 07:59:36 2008//
 /swank.asd/1.5/Thu Oct 11 14:10:25 2007//
-/swank.lisp/1.527/Thu Feb  7 08:07:31 2008//
 /test-all.sh/1.2/Thu Oct 11 14:10:25 2007//
 /test.sh/1.9/Thu Oct 11 14:10:25 2007//
 /xref.lisp/1.2/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.1289/Mon Feb 11 14:20:11 2008//
+/slime.el/1.904/Mon Feb 11 14:20:11 2008//
+/swank-abcl.lisp/1.47/Mon Feb 11 14:20:11 2008//
+/swank-allegro.lisp/1.101/Mon Feb 11 14:20:11 2008//
+/swank-backend.lisp/1.129/Mon Feb 11 14:20:11 2008//
+/swank-clisp.lisp/1.67/Mon Feb 11 14:20:11 2008//
+/swank-cmucl.lisp/1.178/Mon Feb 11 14:20:11 2008//
+/swank-corman.lisp/1.15/Mon Feb 11 14:20:11 2008//
+/swank-ecl.lisp/1.14/Mon Feb 11 14:20:11 2008//
+/swank-lispworks.lisp/1.97/Mon Feb 11 14:20:11 2008//
+/swank-openmcl.lisp/1.124/Mon Feb 11 14:20:11 2008//
+/swank-sbcl.lisp/1.191/Mon Feb 11 14:20:11 2008//
+/swank-scl.lisp/1.18/Mon Feb 11 14:20:11 2008//
+/swank.lisp/1.531/Mon Feb 11 14:20:11 2008//

Modified: branches/trunk-reorg/thirdparty/slime/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/ChangeLog	(original)
+++ branches/trunk-reorg/thirdparty/slime/ChangeLog	Mon Feb 11 09:24:55 2008
@@ -1,3 +1,78 @@
+2008-02-10  Helmut Eller  <heller at common-lisp.net>
+
+	Remove remaining traces of make-default-inspector.
+
+	* swank-scl.lisp (make-default-inspector, scl-inspector): Deleted.
+	* swank-lispworks.lisp (make-default-inspector)
+	(lispworks-inspector): Deleted.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Drop the first return value of emacs-inspect.
+
+	* swank.lisp (emacs-inspect): Drop the first return value. It
+	wasn't used anymore.  Update all methods and callers.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Remove obsolete *slime-inspect-contents-limit*.
+
+	* swank.lisp (*slime-inspect-contents-limit*): Deleted and all its
+	uses.  The new implementation isn't specific to hash-tables or
+	arrays.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Limit the length of the inspector content.
+	That's similar to the limitation of the length of backtraces in
+	the debugger.
+
+	* swank.lisp (*inspectee-content*): New variable.
+	(content-range): New function.
+	(inspect-object): Use it with a length of 1000.
+	(inspector-range): New function. Called from Emacs.
+
+	* slime.el (slime-inspector-insert-content)
+	(slime-inspector-insert-range, slime-inspector-insert-range-button)
+	(slime-inspector-fetch-range): New functions.
+	(slime-inspector-operate-on-point): Handle range-buttons.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Make slime-property-bounds more useful.
+
+	* slime.el (slime-property-bounds): Remove special casing for
+	whitespace at the end.
+	(slime-repl-send-input): Don't mark the newline with the
+	slime-repl-old-input property.
+	(sldb-frame-region): Use slime-property-bounds.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Inspector cleanups.
+
+	* swank.lisp (emacs-inspect): Renamed from inspect-for-emacs.
+	Changed all method-defs accordingly.
+	(common-seperated-spec, inspector-princ): Moved to
+	swank-fancy-inspector.lisp.
+	(inspector-content): Renamed from inspector-content-for-emacs.
+	(value-part): Renamed from value-part-for-emacs.
+	(action-part): Renamed from action-part-for-emacs.
+	(inspect-list): Renamed from inspect-for-emacs-list.
+	(inspect-list-aux): New.
+	(inspect-cons): Renamed from inspect-for-emacs-simple-cons.
+	(*inspect-length*): Deleted.
+	(inspect-list): Ignore max-length stuff.
+	(inspector-content): Don't allow nil elements.
+	(emacs-inspect array): Make the label of element type more
+	consistent with the others.
+
+2008-02-09  Helmut Eller  <heller at common-lisp.net>
+
+	Cleanup slime-repl-set-package.
+
+	* slime.el (slime-repl-set-package): Make it fit within 80 columns.
+
 2008-02-05  Marco Baringer  <mb at bese.it>
 
 	* slime.el (slime-search-buffer-package): Ask the lisp to read the

Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	Mon Feb 11 09:24:55 2008
@@ -1,4 +1,3 @@
-/ChangeLog/1.87/Thu Feb  7 08:07:31 2008//
 /README/1.3/Thu Oct 11 14:10:25 2007//
 /bridge.el/1.1/Thu Oct 11 14:10:25 2007//
 /inferior-slime.el/1.2/Thu Oct 11 14:10:25 2007//
@@ -7,8 +6,6 @@
 /slime-banner.el/1.4/Thu Oct 11 14:10:25 2007//
 /slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007//
 /slime-editing-commands.el/1.6/Thu Feb  7 07:59:35 2008//
-/slime-fancy-inspector.el/1.2/Thu Oct 11 14:10:25 2007//
-/slime-fancy.el/1.4/Thu Oct 11 14:10:25 2007//
 /slime-fuzzy.el/1.6/Thu Feb  7 07:59:35 2008//
 /slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007//
 /slime-indentation.el/1.1/Sun Feb  3 18:45:14 2008//
@@ -25,7 +22,6 @@
 /swank-arglists.lisp/1.20/Thu Feb  7 08:07:31 2008//
 /swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007//
 /swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007//
-/swank-fancy-inspector.lisp/1.7/Thu Feb  7 08:07:32 2008//
 /swank-fuzzy.lisp/1.7/Thu Feb  7 07:59:35 2008//
 /swank-goo.goo/1.1/Thu Feb  7 08:07:32 2008//
 /swank-indentation.lisp/1.1/Sun Feb  3 18:45:14 2008//
@@ -34,4 +30,8 @@
 /swank-motd.lisp/1.1/Sun Feb  3 18:39:23 2008//
 /swank-presentation-streams.lisp/1.5/Thu Feb  7 08:07:32 2008//
 /swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007//
+/ChangeLog/1.89/Mon Feb 11 14:20:11 2008//
+/slime-fancy-inspector.el/1.3/Mon Feb 11 14:20:11 2008//
+/slime-fancy.el/1.5/Mon Feb 11 14:20:11 2008//
+/swank-fancy-inspector.lisp/1.11/Mon Feb 11 14:20:11 2008//
 D

Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	Mon Feb 11 09:24:55 2008
@@ -1,3 +1,16 @@
+2008-02-10  Helmut Eller  <heller at common-lisp.net>
+
+	Fix some bugs introduced by the recent reorganization.
+
+	* swank-fancy-inspector.lisp (emacs-inspect pathname): Fix it
+	again.
+
+	* slime-fancy-inspector.el: Use slime-require.
+
+	* slime-fancy.el: slime-fancy-inspector-init no longer exists, so
+	don't call it.  Once loaded, it's also no longer possible to turn
+	the fancy inspector off.
+	
 2008-02-04  Marco Baringer  <mb at bese.it>
 
 	* swank-presentation-streams.lisp (presenting-object-1): Add

Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy-inspector.el	Mon Feb 11 09:24:55 2008
@@ -3,26 +3,7 @@
 ;; Author: Marco Baringer <mb at bese.it> and others
 ;; License: GNU GPL (same license as Emacs)
 ;;
-;;; Installation
-;;
-;; Add this to your .emacs: 
-;;
-;;   (add-to-list 'load-path "<directory-of-this-file>")
-;;   (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector)))
-;;   (add-hook 'slime-connected-hook 'slime-install-fancy-inspector)
-
-(defun slime-install-fancy-inspector ()
-  (slime-eval-async '(swank:swank-require :swank-fancy-inspector)
-		    (lambda (_) 
-		      (slime-eval-async '(swank:fancy-inspector-init)))))
-
-(defun slime-deinstall-fancy-inspector ()
-  (slime-eval-async '(swank:fancy-inspector-unload)))
-
-(defun slime-fancy-inspector-init ()
-  (add-hook 'slime-connected-hook 'slime-install-fancy-inspector))
 
-(defun slime-fancy-inspector-unload ()
-  (remove-hook 'slime-connected-hook 'slime-install-fancy-inspector))
+(slime-require :swank-fancy-inspector)
 
 (provide 'slime-fancy-inspector)
\ No newline at end of file

Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-fancy.el	Mon Feb 11 09:24:55 2008
@@ -31,9 +31,8 @@
 (require 'slime-editing-commands)
 (slime-editing-commands-init)
 
-;; Makes the inspector fancier.
+;; Makes the inspector fancier.  (Once loaded, can't be turned off.)
 (require 'slime-fancy-inspector)
-(slime-fancy-inspector-init)
 
 ;; Just adds the command C-c M-i.  We do not make fuzzy completion the
 ;; default completion invoked by TAB. --mkoeppe

Modified: branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/swank-fancy-inspector.lisp	Mon Feb 11 09:24:55 2008
@@ -6,14 +6,12 @@
 
 (in-package :swank)
 
-(defmethod inspect-for-emacs ((symbol symbol))
+(defmethod emacs-inspect ((symbol symbol))
   (let ((package (symbol-package symbol)))
     (multiple-value-bind (_symbol status) 
 	(and package (find-symbol (string symbol) package))
       (declare (ignore _symbol))
-      (values 
-       "A symbol."
-       (append
+      (append
 	(label-value-line "Its name is" (symbol-name symbol))
 	;;
 	;; Value 
@@ -77,7 +75,7 @@
 	;; More package
 	(if (find-package symbol)
 	    (label-value-line "It names the package" (find-package symbol)))
-	)))))
+	))))
 
 (defun docstring-ispec (label object kind)
   "Return a inspector spec if OBJECT has a docstring of of kind KIND."
@@ -89,16 +87,15 @@
 	  (t 
 	   (list label ": " '(:newline) "  " docstring '(:newline))))))
 
-(defmethod inspect-for-emacs ((f function))
-  (values "A function."
-	  (append 
+(defmethod emacs-inspect ((f function))
+  (append 
 	   (label-value-line "Name" (function-name f))
 	   `("Its argument list is: " 
 	     ,(inspector-princ (arglist f)) (:newline))
 	   (docstring-ispec "Documentation" f t)
 	   (if (function-lambda-expression f)
 	       (label-value-line "Lambda Expression"
-				 (function-lambda-expression f))))))
+				 (function-lambda-expression f)))))
 
 (defun method-specializers-for-inspect (method)
   "Return a \"pretty\" list of the method's specializers. Normal
@@ -122,11 +119,10 @@
 	  (swank-mop:method-qualifiers method)
 	  (method-specializers-for-inspect method)))
 
-(defmethod inspect-for-emacs ((object standard-object))
+(defmethod emacs-inspect ((object standard-object))
   (let ((class (class-of object)))
-    (values "An object."
             `("Class: " (:value ,class) (:newline)
-              ,@(all-slots-for-inspector object)))))
+              ,@(all-slots-for-inspector object))))
 
 (defvar *gf-method-getter* 'methods-by-applicability
   "This function is called to get the methods of a generic function.
@@ -224,11 +220,9 @@
                   append slot-presentation
                   collect '(:newline))))))
 
-(defmethod inspect-for-emacs ((gf standard-generic-function)) 
+(defmethod emacs-inspect ((gf standard-generic-function)) 
   (flet ((lv (label value) (label-value-line label value)))
-    (values 
-     "A generic function."
-     (append 
+    (append 
       (lv "Name" (swank-mop:generic-function-name gf))
       (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
       (docstring-ispec "Documentation" gf t)
@@ -247,10 +241,9 @@
                             (remove-method gf m))))
 	      (:newline)))
       `((:newline))
-      (all-slots-for-inspector gf)))))
+      (all-slots-for-inspector gf))))
 
-(defmethod inspect-for-emacs ((method standard-method))
-  (values "A method." 
+(defmethod emacs-inspect ((method standard-method))
           `("Method defined on the generic function " 
 	    (:value ,(swank-mop:method-generic-function method)
 		    ,(inspector-princ
@@ -267,10 +260,9 @@
             (:newline)
             "Method function: " (:value ,(swank-mop:method-function method))
             (:newline)
-            ,@(all-slots-for-inspector method))))
+            ,@(all-slots-for-inspector method)))
 
-(defmethod inspect-for-emacs ((class standard-class))
-  (values "A class."
+(defmethod emacs-inspect ((class standard-class))
           `("Name: " (:value ,(class-name class))
             (:newline)
             "Super classes: "
@@ -326,10 +318,9 @@
                                `(:value ,(swank-mop:class-prototype class))
                                '"#<N/A (class not finalized)>")
             (:newline)
-            ,@(all-slots-for-inspector class))))
+            ,@(all-slots-for-inspector class)))
 
-(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition))
-  (values "A slot."
+(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition))
           `("Name: " (:value ,(swank-mop:slot-definition-name slot))
             (:newline)
             ,@(when (swank-mop:slot-definition-documentation slot)
@@ -342,7 +333,7 @@
                              "#<unspecified>") (:newline)
             "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))            
             (:newline)
-            ,@(all-slots-for-inspector slot))))
+            ,@(all-slots-for-inspector slot)))
 
 
 ;; Wrapper structure over the list of symbols of a package that should
@@ -434,10 +425,10 @@
                         (:newline)
                         )))))
 
-(defmethod inspect-for-emacs ((%container %package-symbols-container))
+(defmethod emacs-inspect ((%container %package-symbols-container))
   (with-struct (%container. title description symbols grouping-kind) %container
-    (values title
-            `(, at description
+            `(,title (:newline) 
+	      , at description
               (:newline)
               "  " ,(ecase grouping-kind
                            (:symbol
@@ -449,9 +440,9 @@
                                       ,(lambda () (setf grouping-kind :symbol))
                                       :refreshp t)))
               (:newline) (:newline)
-              ,@(make-symbols-listing grouping-kind symbols)))))
+              ,@(make-symbols-listing grouping-kind symbols))))
 
-(defmethod inspect-for-emacs ((package package))
+(defmethod emacs-inspect ((package package))
   (let ((package-name         (package-name package))
         (package-nicknames    (package-nicknames package))
         (package-use-list     (package-use-list package))
@@ -479,8 +470,6 @@
           external-symbols     (sort external-symbols #'string<)) ; SBCL 0.9.18.
 
     
-    (values
-     "A package."
      `(""                               ; dummy to preserve indentation.
        "Name: " (:value ,package-name) (:newline)
                        
@@ -542,27 +531,27 @@
             (:newline)
             ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
                            :title (format nil "All shadowed symbols of package \"~A\"" package-name)
-                           :description nil)))))))
+                           :description nil))))))
 
 
-(defmethod inspect-for-emacs ((pathname pathname))
-  (values (if (wild-pathname-p pathname)
-              "A wild pathname."
-              "A pathname.")
-          (append (label-value-line*
-                   ("Namestring" (namestring pathname))
-                   ("Host"       (pathname-host pathname))
-                   ("Device"     (pathname-device pathname))
-                   ("Directory"  (pathname-directory pathname))
-                   ("Name"       (pathname-name pathname))
-                   ("Type"       (pathname-type pathname))
-                   ("Version"    (pathname-version pathname)))
-                  (unless (or (wild-pathname-p pathname)
-                              (not (probe-file pathname)))
-                    (label-value-line "Truename" (truename pathname))))))
+(defmethod emacs-inspect ((pathname pathname))
+  `(,(if (wild-pathname-p pathname)
+	 "A wild pathname."
+	 "A pathname.")
+     (:newline)
+     ,@(label-value-line*
+	("Namestring" (namestring pathname))
+	("Host"       (pathname-host pathname))
+	("Device"     (pathname-device pathname))
+	("Directory"  (pathname-directory pathname))
+	("Name"       (pathname-name pathname))
+	("Type"       (pathname-type pathname))
+	("Version"    (pathname-version pathname)))
+     ,@ (unless (or (wild-pathname-p pathname)
+		    (not (probe-file pathname)))
+	  (label-value-line "Truename" (truename pathname)))))
 
-(defmethod inspect-for-emacs ((pathname logical-pathname))
-  (values "A logical pathname."
+(defmethod emacs-inspect ((pathname logical-pathname))
           (append 
            (label-value-line*
             ("Namestring" (namestring pathname))
@@ -579,10 +568,10 @@
             ("Type" (pathname-type pathname))
             ("Version" (pathname-version pathname))
             ("Truename" (if (not (wild-pathname-p pathname))
-                            (probe-file pathname)))))))
+                            (probe-file pathname))))))
 
-(defmethod inspect-for-emacs ((n number))
-  (values "A number." `("Value: " ,(princ-to-string n))))
+(defmethod emacs-inspect ((n number))
+  `("Value: " ,(princ-to-string n)))
 
 (defun format-iso8601-time (time-value &optional include-timezone-p)
     "Formats a universal time TIME-VALUE in ISO 8601 format, with
@@ -604,8 +593,7 @@
               year month day hour minute second
               include-timezone-p (format-iso8601-timezone zone)))))
 
-(defmethod inspect-for-emacs ((i integer))
-  (values "A number."
+(defmethod emacs-inspect ((i integer))
           (append
            `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
                       i i i i (ignore-errors (coerce i 'float)))
@@ -614,23 +602,20 @@
              (label-value-line "Code-char" (code-char i)))
            (label-value-line "Integer-length" (integer-length i))           
            (ignore-errors
-             (label-value-line "Universal-time" (format-iso8601-time i t))))))
+             (label-value-line "Universal-time" (format-iso8601-time i t)))))
 
-(defmethod inspect-for-emacs ((c complex))
-  (values "A complex number."
+(defmethod emacs-inspect ((c complex))
           (label-value-line* 
            ("Real part" (realpart c))
-           ("Imaginary part" (imagpart c)))))
+           ("Imaginary part" (imagpart c))))
 
-(defmethod inspect-for-emacs ((r ratio))
-  (values "A non-integer ratio."
+(defmethod emacs-inspect ((r ratio))
           (label-value-line*
            ("Numerator" (numerator r))
            ("Denominator" (denominator r))
-           ("As float" (float r)))))
+           ("As float" (float r))))
 
-(defmethod inspect-for-emacs ((f float))
-  (values "A floating point number."
+(defmethod emacs-inspect ((f float))
           (cond
             ((> f most-positive-long-float)
              (list "Positive infinity."))
@@ -647,13 +632,11 @@
                                  (:value ,significand) " * " 
                                  (:value ,(float-radix f)) "^" (:value ,exponent) (:newline))
                 (label-value-line "Digits" (float-digits f))
-                (label-value-line "Precision" (float-precision f))))))))
+                (label-value-line "Precision" (float-precision f)))))))
 
-(defmethod inspect-for-emacs ((stream file-stream))
-  (multiple-value-bind (title content)
+(defmethod emacs-inspect ((stream file-stream))
+  (multiple-value-bind (content)
       (call-next-method)
-    (declare (ignore title))
-    (values "A file stream."
             (append
              `("Pathname: "
                (:value ,(pathname stream))
@@ -665,14 +648,13 @@
                              (ed-in-emacs `(,pathname :charpos ,position))))
                         :refreshp nil)
                (:newline))
-             content))))
+             content)))
 
-(defmethod inspect-for-emacs ((condition stream-error))
-  (multiple-value-bind (title content)
+(defmethod emacs-inspect ((condition stream-error))
+  (multiple-value-bind (content)
       (call-next-method)
     (let ((stream (stream-error-stream condition)))
       (if (typep stream 'file-stream)
-          (values "A stream error."
                   (append
                    `("Pathname: "
                      (:value ,(pathname stream))
@@ -684,16 +666,22 @@
                                       (ed-in-emacs `(,pathname :charpos ,position))))
                               :refreshp nil)
                      (:newline))
-                   content))
-          (values title content)))))
+                   content)
+          content))))
 
-(defvar *fancy-inpector-undo-list* nil)
-
-(defslimefun fancy-inspector-init ()
-  t)
-
-(defslimefun fancy-inspector-unload ()
-  (loop while *fancy-inpector-undo-list* do
-	(funcall (pop *fancy-inpector-undo-list*))))
+(defun common-seperated-spec (list &optional (callback (lambda (v) 
+							 `(:value ,v))))
+  (butlast
+   (loop
+      for i in list
+      collect (funcall callback i)
+      collect ", ")))
+
+(defun inspector-princ (list)
+  "Like princ-to-string, but don't rewrite (function foo) as #'foo. 
+Do NOT pass circular lists to this function."
+  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+    (set-pprint-dispatch '(cons (member function)) nil)
+    (princ-to-string list)))
 
 (provide :swank-fancy-inspector)

Modified: branches/trunk-reorg/thirdparty/slime/slime.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/slime.el	Mon Feb 11 09:24:55 2008
@@ -2267,11 +2267,7 @@
     (save-excursion
       (when (or (re-search-backward regexp nil t)
                 (re-search-forward regexp nil t))
-        ;; package name can be a string designator, convert it to a string.
-        ;;(slime-eval `(cl:string (cl:second (cl:read-from-string ,(match-string-no-properties 0))))
-        ;;            "COMMON-LISP-USER")
-        (match-string-no-properties 2)
-        ))))
+        (match-string-no-properties 2)))))
 
 ;;; Synchronous requests are implemented in terms of asynchronous
 ;;; ones. We make an asynchronous request with a continuation function
@@ -3176,14 +3172,14 @@
   (let ((end (point))) ; end of input, without the newline
     (slime-repl-add-to-input-history 
      (buffer-substring slime-repl-input-start-mark end))
-    (when newline 
-      (insert "\n")
-      (slime-repl-show-maximum-output))
     (let ((inhibit-read-only t))
       (add-text-properties slime-repl-input-start-mark 
                            (point)
                            `(slime-repl-old-input
                              ,(incf slime-repl-old-input-counter))))
+    (when newline 
+      (insert "\n")
+      (slime-repl-show-maximum-output))
     (let ((overlay (make-overlay slime-repl-input-start-mark end)))
       ;; These properties are on an overlay so that they won't be taken
       ;; by kill/yank.
@@ -3216,25 +3212,9 @@
 (defun slime-property-bounds (prop)
   "Return two the positions of the previous and next changes to PROP.
 PROP is the name of a text property."
-  (let* ((beg (save-excursion
-                ;; previous-single-char-property-change searches for a
-                ;; property change from the previous character, but we
-                ;; want to look for a change from the point. We step
-                ;; forward one char to avoid doing the wrong thing if
-                ;; we're at the beginning of the old input. -luke
-                ;; (18/Jun/2004)
-                (unless (not (get-text-property (point) prop)) 
-                  ;; alanr unless we are sitting right after it May 19, 2005
-                  (ignore-errors (forward-char)))
-                (previous-single-char-property-change (point) prop)))
-         (end (save-excursion
-                (if (get-text-property (point) prop)
-                    (progn (goto-char (next-single-char-property-change 
-                                       (point) prop))
-                           (skip-chars-backward "\n \t\r" beg)
-                           (point))
-                  (point)))))
-    (values beg end)))
+  (assert (get-text-property (point) prop))
+  (let ((end (next-single-char-property-change (point) prop)))
+    (list (previous-single-char-property-change end prop) end)))
 
 (defun slime-repl-closing-return ()
   "Evaluate the current input string after closing all open lists."
@@ -3321,12 +3301,11 @@
 
 (defun slime-repl-set-package (package)
   "Set the package of the REPL buffer to PACKAGE."
-  (interactive (list (slime-read-package-name "Package: "
-                                              (if (string= (slime-current-package)
-                                                           (with-current-buffer (slime-repl-buffer)
-                                                             (slime-current-package)))
-                                                nil
-                                                (slime-pretty-find-buffer-package)))))
+  (interactive (list (slime-read-package-name 
+                      "Package: "
+                      (if (equal (slime-current-package) (slime-lisp-package))
+                          nil
+                        (slime-pretty-find-buffer-package)))))
   (with-current-buffer (slime-output-buffer)
     (let ((unfinished-input (slime-repl-current-input)))
       (destructuring-bind (name prompt-string)
@@ -6821,11 +6800,7 @@
        (get-text-property (point) 'details-visible-p)))
 
 (defun sldb-frame-region ()
-  (save-excursion
-    (goto-char (next-single-property-change (point) 'frame nil (point-max)))
-    (backward-char)
-    (values (previous-single-property-change (point) 'frame)
-	    (next-single-property-change (point) 'frame nil (point-max)))))
+  (slime-property-bounds 'frame))
 
 (defun sldb-forward-frame ()
   (goto-char (next-single-char-property-change (point) 'frame)))
@@ -7540,8 +7515,8 @@
           (while (eq (char-before) ?\n)
             (backward-delete-char 1))
           (insert "\n" (fontify label "--------------------") "\n")
-          (save-excursion 
-            (mapc slime-inspector-insert-ispec-function content))
+          (save-excursion
+            (slime-inspector-insert-content content))
           (pop-to-buffer (current-buffer))
           (when point
             (check-type point cons)
@@ -7549,6 +7524,22 @@
               (goto-line (car point))
               (move-to-column (cdr point)))))))))
 
+(defun slime-inspector-insert-content (content)
+  (destructuring-bind (ispecs len start end) content
+    (slime-inspector-insert-range ispecs len start end t t)))
+
+(defun slime-inspector-insert-range (ispecs len start end prev next)
+  "Insert ISPECS at point.
+LEN is the length of the entire content on the Lisp side.
+START and END are the positions of the subsequnce that ISPECS represents.
+If PREV resp. NEXT are true insert range-buttons as needed."
+  (let ((limit 2000))
+    (when (and prev (> start 0))
+      (slime-inspector-insert-range-button (max 0 (- start limit)) start t))
+    (mapc #'slime-inspector-insert-ispec ispecs)
+    (when (and next (< end len))
+      (slime-inspector-insert-range-button end (min len (+ end limit)) nil))))
+
 (defun slime-inspector-insert-ispec (ispec)
   (if (stringp ispec)
       (insert ispec)
@@ -7580,10 +7571,14 @@
           (current-column))))
 
 (defun slime-inspector-operate-on-point ()
-  "If point is on a value then recursivly call the inspector on
-  that value. If point is on an action then call that action."
+  "Invoke the command for the text at point.
+1. If point is on a value then recursivly call the inspector on
+that value.  
+2. If point is on an action then call that action.
+3. If point is on a range-button fetch and insert the range."
   (interactive)
   (let ((part-number (get-text-property (point) 'slime-part-number))
+        (range-button (get-text-property (point) 'slime-range-button))
         (action-number (get-text-property (point) 'slime-action-number))
         (opener (lexical-let ((point (slime-inspector-position)))
                   (lambda (parts)
@@ -7593,6 +7588,8 @@
            (slime-eval-async `(swank:inspect-nth-part ,part-number)
                              opener)
            (push (slime-inspector-position) slime-inspector-mark-stack))
+          (range-button
+           (slime-inspector-fetch-range range-button))
           (action-number 
            (slime-eval-async `(swank::inspector-call-nth-action ,action-number)
                              opener)))))
@@ -7693,7 +7690,6 @@
                 (progn (goto-char maxpos) (setq previously-wrapped-p t))
                 (error "No inspectable objects")))))))
 
-
 (defun slime-inspector-previous-inspectable-object (arg)
   "Move point to the previous inspectable object.
 With optional ARG, move across that many objects.
@@ -7717,6 +7713,25 @@
                       (lambda (parts)
                         (slime-open-inspector parts point)))))
 
+(defun slime-inspector-insert-range-button (start end previous)
+  (slime-insert-propertized 
+   (list 'slime-range-button (list start end previous)
+         'mouse-face 'highlight
+         'face 'slime-inspector-action-face)
+   (if previous " [--more--]\n" " [--more--]")))
+
+(defun slime-inspector-fetch-range (button)
+  (destructuring-bind (start end previous) button
+    (slime-eval-async 
+     `(swank:inspector-range ,start ,end)
+     (slime-rcurry
+      (lambda (content prev)
+        (let ((inhibit-read-only t))
+          (apply #'delete-region (slime-property-bounds 'slime-range-button))
+          (destructuring-bind (i l s e) content
+            (slime-inspector-insert-range i l s e prev (not prev)))))
+      previous))))
+
 (slime-define-keys slime-inspector-mode-map
   ([return] 'slime-inspector-operate-on-point)
   ((kbd "M-RET") 'slime-inspector-copy-down)
@@ -9630,7 +9645,7 @@
 ;; Local Variables: 
 ;; outline-regexp: ";;;;+"
 ;; indent-tabs-mode: nil
-;; coding: latin-1-unix!
+;; coding: latin-1-unix
 ;; unibyte: t
 ;; compile-command: "emacs -batch -L . -eval '(byte-compile-file \"slime.el\")' ; rm -v slime.elc"
 ;; End:

Modified: branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-abcl.lisp	Mon Feb 11 09:24:55 2008
@@ -421,8 +421,7 @@
 
 ;;;; Inspecting
 
-(defmethod inspect-for-emacs ((slot mop::slot-definition))
-  (values "A slot." 
+(defmethod emacs-inspect ((slot mop::slot-definition))
           `("Name: " (:value ,(mop::%slot-definition-name slot))
             (:newline)
             "Documentation:" (:newline)
@@ -434,10 +433,9 @@
                              `(:value ,(mop::%slot-definition-initform slot))
                              "#<unspecified>") (:newline)
             "  Function: " (:value ,(mop::%slot-definition-initfunction slot))
-            (:newline))))
+            (:newline)))
 
-(defmethod inspect-for-emacs ((f function))
-  (values "A function."
+(defmethod emacs-inspect ((f function))
           `(,@(when (function-name f)
                     `("Name: " 
                       ,(princ-to-string (function-name f)) (:newline)))
@@ -449,19 +447,18 @@
                          `("Documentation:" (:newline) ,(documentation f t) (:newline)))
             ,@(when (function-lambda-expression f)
                     `("Lambda expression:" 
-                      (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline))))))
+                      (:newline) ,(princ-to-string (function-lambda-expression f)) (:newline)))))
 
 #|
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (let* ((class (class-of o))
          (slots (mop::class-slots class)))
-    (values (format nil "~A~%   is a ~A" o class)
             (mapcar (lambda (slot)
                       (let ((name (mop::slot-definition-name slot)))
                         (cons (princ-to-string name)
                               (slot-value o name))))
-                    slots))))
+                    slots)))
 |#
 
 ;;;; Multithreading

Modified: branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-allegro.lisp	Mon Feb 11 09:24:55 2008
@@ -564,23 +564,22 @@
 
 ;;;; Inspecting
 
-(defmethod inspect-for-emacs ((f function))
-  (values "A function."
+(defmethod emacs-inspect ((f function))
           (append
            (label-value-line "Name" (function-name f))
            `("Formals" ,(princ-to-string (arglist f)) (:newline))
            (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
              (when doc
-               `("Documentation:" (:newline) ,doc))))))
+               `("Documentation:" (:newline) ,doc)))))
 
-(defmethod inspect-for-emacs ((o t))
-  (values "A value." (allegro-inspect o)))
+(defmethod emacs-inspect ((o t))
+  (allegro-inspect o))
 
-(defmethod inspect-for-emacs ((o function))
-  (values "A function." (allegro-inspect o)))
+(defmethod emacs-inspect ((o function))
+  (allegro-inspect o))
 
-(defmethod inspect-for-emacs ((o standard-object))
-  (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
+(defmethod emacs-inspect ((o standard-object))
+  (allegro-inspect o))
 
 (defun allegro-inspect (o)
   (loop for (d dd) on (inspect::inspect-ctl o)

Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	Mon Feb 11 09:24:55 2008
@@ -33,11 +33,7 @@
            #:declaration-arglist
            #:type-specifier-arglist
            ;; inspector related symbols
-           #:inspector
-           #:backend-inspector
-           #:inspect-for-emacs
-           #:raw-inspection
-           #:fancy-inspection
+           #:emacs-inspect
            #:label-value-line
            #:label-value-line*
            #:with-struct
@@ -840,13 +836,11 @@
 

 ;;;; Inspector
 
-(defgeneric inspect-for-emacs (object)
+(defgeneric emacs-inspect (object)
   (:documentation
    "Explain to Emacs how to inspect OBJECT.
 
-Returns two values: a string which will be used as the title of
-the inspector buffer and a list specifying how to render the
-object for inspection.
+Returns a list specifying how to render the object for inspection.
 
 Every element of the list must be either a string, which will be
 inserted into the buffer as is, or a list of the form:
@@ -861,20 +855,17 @@
  string) which when clicked will call LAMBDA. If REFRESH is
  non-NIL the currently inspected object will be re-inspected
  after calling the lambda.
+"))
 
- NIL - do nothing."))
-
-(defmethod inspect-for-emacs ((object t))
+(defmethod emacs-inspect ((object t))
   "Generic method for inspecting any kind of object.
 
 Since we don't know how to deal with OBJECT we simply dump the
 output of CL:DESCRIBE."
-  (values 
-   "A value."
    `("Type: " (:value ,(type-of object)) (:newline)
      "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
      (:newline) (:newline)
-     ,(with-output-to-string (desc) (describe object desc)))))
+     ,(with-output-to-string (desc) (describe object desc))))
 
 ;;; Utilities for inspector methods.
 ;;; 

Modified: branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-clisp.lisp	Mon Feb 11 09:24:55 2008
@@ -627,7 +627,7 @@
 
 ;;;; Inspecting
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (let* ((*print-array* nil) (*print-pretty* t)
          (*print-circle* t) (*print-escape* t)
          (*print-lines* custom:*inspect-print-lines*)
@@ -638,9 +638,10 @@
          (*package* tmp-pack)
          (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
     (let ((inspection (sys::inspect-backend o)))
-      (values (format nil "~S~% ~A~{~%~A~}" o
+      (append (list
+               (format nil "~S~% ~A~{~%~A~}~%" o
                       (sys::insp-title inspection)
-                      (sys::insp-blurb inspection))
+                      (sys::insp-blurb inspection)))
               (loop with count = (sys::insp-num-slots inspection)
                     for i below count
                     append (multiple-value-bind (value name)

Modified: branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-cmucl.lisp	Mon Feb 11 09:24:55 2008
@@ -1822,11 +1822,6 @@
 

 ;;;; Inspecting
 
-(defclass cmucl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'cmucl-inspector))
-
 (defconstant +lowtag-symbols+ 
   '(vm:even-fixnum-type
     vm:function-pointer-type
@@ -1869,10 +1864,9 @@
                                   :key #'symbol-value)))
           (format t ", type: ~A" type-symbol))))))
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (cond ((di::indirect-value-cell-p o)
-         (values (format nil "~A is a value cell." o)
-                 `("Value: " (:value ,(c:value-cell-ref o)))))
+         `("Value: " (:value ,(c:value-cell-ref o))))
         ((alien::alien-value-p o)
          (inspect-alien-value o))
 	(t
@@ -1880,63 +1874,59 @@
 
 (defun cmucl-inspect (o)
   (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
-    (values (format nil "~A~%" text)
-            (if labeledp
-                (loop for (label . value) in parts
-                      append (label-value-line label value))
-                (loop for value in parts  for i from 0 
-                      append (label-value-line i value))))))
+    (list* (format nil "~A~%" text)
+           (if labeledp
+               (loop for (label . value) in parts
+                     append (label-value-line label value))
+               (loop for value in parts  for i from 0 
+                     append (label-value-line i value))))))
 
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
   (let ((header (kernel:get-type o)))
     (cond ((= header vm:function-header-type)
-           (values (format nil "~A is a function." o)
-                   (append (label-value-line*
-                            ("Self" (kernel:%function-self o))
-                            ("Next" (kernel:%function-next o))
-                            ("Name" (kernel:%function-name o))
-                            ("Arglist" (kernel:%function-arglist o))
-                            ("Type" (kernel:%function-type o))
-                            ("Code" (kernel:function-code-header o)))
-                           (list 
-                            (with-output-to-string (s)
-                              (disassem:disassemble-function o :stream s))))))
+           (append (label-value-line*
+                    ("Self" (kernel:%function-self o))
+                    ("Next" (kernel:%function-next o))
+                    ("Name" (kernel:%function-name o))
+                    ("Arglist" (kernel:%function-arglist o))
+                    ("Type" (kernel:%function-type o))
+                    ("Code" (kernel:function-code-header o)))
+                   (list 
+                    (with-output-to-string (s)
+                      (disassem:disassemble-function o :stream s)))))
           ((= header vm:closure-header-type)
-           (values (format nil "~A is a closure" o)
-                   (append 
-                    (label-value-line "Function" (kernel:%closure-function o))
-                    `("Environment:" (:newline))
-                    (loop for i from 0 below (1- (kernel:get-closure-length o))
-                          append (label-value-line 
-                                  i (kernel:%closure-index-ref o i))))))
+           (list* (format nil "~A is a closure.~%" o)
+                  (append 
+                   (label-value-line "Function" (kernel:%closure-function o))
+                   `("Environment:" (:newline))
+                   (loop for i from 0 below (1- (kernel:get-closure-length o))
+                         append (label-value-line 
+                                 i (kernel:%closure-index-ref o i))))))
           ((eval::interpreted-function-p o)
            (cmucl-inspect o))
           (t
            (call-next-method)))))
 
-(defmethod inspect-for-emacs ((o kernel:funcallable-instance))
-  (values 
-   (format nil "~A is a funcallable-instance." o)
-   (append (label-value-line* 
-            (:function (kernel:%funcallable-instance-function o))
-            (:lexenv  (kernel:%funcallable-instance-lexenv o))
-            (:layout  (kernel:%funcallable-instance-layout o)))
-           (nth-value 1 (cmucl-inspect o)))))
-
-(defmethod inspect-for-emacs ((o kernel:code-component))
-  (values (format nil "~A is a code data-block." o)
-          (append 
-           (label-value-line* 
-            ("code-size" (kernel:%code-code-size o))
-            ("entry-points" (kernel:%code-entry-points o))
-            ("debug-info" (kernel:%code-debug-info o))
-            ("trace-table-offset" (kernel:code-header-ref 
-                                   o vm:code-trace-table-offset-slot)))
-           `("Constants:" (:newline))
-           (loop for i from vm:code-constants-offset 
-                 below (kernel:get-header-data o)
-                 append (label-value-line i (kernel:code-header-ref o i)))
-           `("Code:" (:newline)
+(defmethod emacs-inspect ((o kernel:funcallable-instance))
+  (append (label-value-line* 
+           (:function (kernel:%funcallable-instance-function o))
+           (:lexenv  (kernel:%funcallable-instance-lexenv o))
+           (:layout  (kernel:%funcallable-instance-layout o)))
+          (cmucl-inspect o)))
+
+(defmethod emacs-inspect ((o kernel:code-component))
+  (append 
+   (label-value-line* 
+    ("code-size" (kernel:%code-code-size o))
+    ("entry-points" (kernel:%code-entry-points o))
+    ("debug-info" (kernel:%code-debug-info o))
+    ("trace-table-offset" (kernel:code-header-ref 
+                           o vm:code-trace-table-offset-slot)))
+   `("Constants:" (:newline))
+   (loop for i from vm:code-constants-offset 
+         below (kernel:get-header-data o)
+         append (label-value-line i (kernel:code-header-ref o i)))
+   `("Code:" (:newline)
              , (with-output-to-string (s)
                  (cond ((kernel:%code-debug-info o)
                         (disassem:disassemble-code-component o :stream s))
@@ -1948,63 +1938,57 @@
                              (* vm:code-constants-offset vm:word-bytes))
                           (ash 1 vm:lowtag-bits))
                          (ash (kernel:%code-code-size o) vm:word-shift)
-                         :stream s))))))))
+                         :stream s)))))))
 
-(defmethod inspect-for-emacs ((o kernel:fdefn))
-  (values (format nil "~A is a fdenf object." o)
-          (label-value-line*
-           ("name" (kernel:fdefn-name o))
-           ("function" (kernel:fdefn-function o))
-           ("raw-addr" (sys:sap-ref-32
-                        (sys:int-sap (kernel:get-lisp-obj-address o))
-                        (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+(defmethod emacs-inspect ((o kernel:fdefn))
+  (label-value-line*
+   ("name" (kernel:fdefn-name o))
+   ("function" (kernel:fdefn-function o))
+   ("raw-addr" (sys:sap-ref-32
+                (sys:int-sap (kernel:get-lisp-obj-address o))
+                (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
 
-(defmethod inspect-for-emacs ((o array))
+#+(or)
+(defmethod emacs-inspect ((o array))
   (if (typep o 'simple-array)
       (call-next-method)
-      (values (format nil "~A is an array." o)
-              (label-value-line*
-               (:header (describe-primitive-type o))
-               (:rank (array-rank o))
-               (:fill-pointer (kernel:%array-fill-pointer o))
-               (:fill-pointer-p (kernel:%array-fill-pointer-p o))
-               (:elements (kernel:%array-available-elements o))           
-               (:data (kernel:%array-data-vector o))
-               (:displacement (kernel:%array-displacement o))
-               (:displaced-p (kernel:%array-displaced-p o))
-               (:dimensions (array-dimensions o))))))
-
-(defmethod inspect-for-emacs ((o simple-vector))
-  (values (format nil "~A is a simple-vector." o)
-          (append 
-           (label-value-line*
-            (:header (describe-primitive-type o))
-            (:length (c::vector-length o)))
-           (loop for i below (length o)
-                 append (label-value-line i (aref o i))))))
+      (label-value-line*
+       (:header (describe-primitive-type o))
+       (:rank (array-rank o))
+       (:fill-pointer (kernel:%array-fill-pointer o))
+       (:fill-pointer-p (kernel:%array-fill-pointer-p o))
+       (:elements (kernel:%array-available-elements o))           
+       (:data (kernel:%array-data-vector o))
+       (:displacement (kernel:%array-displacement o))
+       (:displaced-p (kernel:%array-displaced-p o))
+       (:dimensions (array-dimensions o)))))
+
+(defmethod emacs-inspect ((o simple-vector))
+  (append 
+   (label-value-line*
+    (:header (describe-primitive-type o))
+    (:length (c::vector-length o)))
+   (loop for i below (length o)
+         append (label-value-line i (aref o i)))))
 
 (defun inspect-alien-record (alien)
-  (values
-   (format nil "~A is an alien value." alien)
-   (with-struct (alien::alien-value- sap type) alien
-     (with-struct (alien::alien-record-type- kind name fields) type
-       (append
-        (label-value-line*
-         (:sap sap)
-         (:kind kind)
-         (:name name))
-        (loop for field in fields 
-              append (let ((slot (alien::alien-record-field-name field)))
-                       (label-value-line slot (alien:slot alien slot)))))))))
+  (with-struct (alien::alien-value- sap type) alien
+    (with-struct (alien::alien-record-type- kind name fields) type
+      (append
+       (label-value-line*
+        (:sap sap)
+        (:kind kind)
+        (:name name))
+       (loop for field in fields 
+             append (let ((slot (alien::alien-record-field-name field)))
+                      (label-value-line slot (alien:slot alien slot))))))))
 
 (defun inspect-alien-pointer (alien)
-  (values
-   (format nil "~A is an alien value." alien)
-   (with-struct (alien::alien-value- sap type) alien
-     (label-value-line* 
-      (:sap sap)
-      (:type type)
-      (:to (alien::deref alien))))))
+  (with-struct (alien::alien-value- sap type) alien
+    (label-value-line* 
+     (:sap sap)
+     (:type type)
+     (:to (alien::deref alien)))))
   
 (defun inspect-alien-value (alien)
   (typecase (alien::alien-value-type alien)

Modified: branches/trunk-reorg/thirdparty/slime/swank-corman.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-corman.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-corman.lisp	Mon Feb 11 09:24:55 2008
@@ -393,8 +393,7 @@
               collect (funcall callback e)
               collect ", ")))
 
-(defmethod inspect-for-emacs ((class standard-class))
-  (values "A class."
+(defmethod emacs-inspect ((class standard-class))
           `("Name: " (:value ,(class-name class))
             (:newline)
             "Super classes: "
@@ -428,12 +427,11 @@
                                          (lambda (class)
                                            `(:value ,class ,(princ-to-string (class-name class)))))
                   '("#<N/A (class not finalized)>"))
-            (:newline))))
+            (:newline)))
 
-(defmethod inspect-for-emacs ((slot cons))
+(defmethod emacs-inspect ((slot cons))
   ;; Inspects slot definitions
   (if (eq (car slot) :name)
-      (values "A slot." 
               `("Name: " (:value ,(swank-mop:slot-definition-name slot))
                          (:newline)
                          ,@(when (swank-mop:slot-definition-documentation slot)
@@ -445,13 +443,14 @@
                                              `(:value ,(swank-mop:slot-definition-initform slot))
                                              "#<unspecified>") (:newline)
                                              "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
-                                             (:newline)))
+                                             (:newline))
       (call-next-method)))
   
-(defmethod inspect-for-emacs ((pathname pathnames::pathname-internal))
-  (values (if (wild-pathname-p pathname)
+(defmethod emacs-inspect ((pathname pathnames::pathname-internal))
+  (list*  (if (wild-pathname-p pathname)
               "A wild pathname."
               "A pathname.")
+	  '(:newline)
           (append (label-value-line*
                    ("Namestring" (namestring pathname))
                    ("Host"       (pathname-host pathname))
@@ -464,13 +463,11 @@
                               (not (probe-file pathname)))
                     (label-value-line "Truename" (truename pathname))))))
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (cond ((cl::structurep o) (inspect-structure o))
 	(t (call-next-method))))
 
 (defun inspect-structure (o)
-  (values 
-   (format nil "~A is a structure" o)
    (let* ((template (cl::uref o 1))
 	  (num-slots (cl::struct-template-num-slots template)))
      (cond ((symbolp template)
@@ -479,7 +476,7 @@
 	   (t
 	    (loop for i below num-slots
 		  append (label-value-line (elt template (+ 6 (* i 5)))
-					   (cl::uref o (+ 2 i)))))))))
+					   (cl::uref o (+ 2 i))))))))
 
 

 ;;; Threads

Modified: branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-ecl.lisp	Mon Feb 11 09:24:55 2008
@@ -248,12 +248,12 @@
 
 ;;;; Inspector
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   ; ecl clos support leaves some to be desired
   (cond
     ((streamp o)
-     (values
-      (format nil "~S is an ordinary stream" o)
+     (list*
+      (format nil "~S is an ordinary stream~%" o)
       (append
        (list
         "Open for "
@@ -285,7 +285,7 @@
     (t
      (let* ((cl (si:instance-class o))
             (slots (clos:class-slots cl)))
-       (values (format nil "~S is an instance of class ~A"
+       (list* (format nil "~S is an instance of class ~A~%"
                        o (clos::class-name cl))
                (loop for x in slots append
                     (let* ((name (clos:slot-definition-name x))

Modified: branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-lispworks.lisp	Mon Feb 11 09:24:55 2008
@@ -624,32 +624,27 @@
           append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
 
 ;;; Inspector
-(defclass lispworks-inspector (backend-inspector) ())
 
-(defimplementation make-default-inspector ()
-  (make-instance 'lispworks-inspector))
-
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (lispworks-inspect o))
 
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
   (lispworks-inspect o))
 
 ;; FIXME: slot-boundp-using-class in LW works with names so we can't
 ;; use our method in swank.lisp.
-(defmethod inspect-for-emacs ((o standard-object))
+(defmethod emacs-inspect ((o standard-object))
   (lispworks-inspect o))
 
 (defun lispworks-inspect (o)
   (multiple-value-bind (names values _getter _setter type)
       (lw:get-inspector-values o nil)
     (declare (ignore _getter _setter))
-    (values "A value."
             (append 
              (label-value-line "Type" type)
              (loop for name in names
                    for value in values
-                   append (label-value-line name value))))))
+                   append (label-value-line name value)))))
 
 ;;; Miscellaneous
 

Modified: branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-openmcl.lisp	Mon Feb 11 09:24:55 2008
@@ -802,7 +802,7 @@
 	(string (gethash typecode *value2tag*))
 	(string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (let* ((i (inspector::make-inspector o))
 	 (count (inspector::compute-line-count i))
 	 (lines 
@@ -814,24 +814,16 @@
              collect " = "
              collect `(:value ,value)
              collect '(:newline))))
-    (values (with-output-to-string (s)
-              (let ((*print-lines* 1)
-                    (*print-right-margin* 80))
-                (pprint o s)))
-            lines)))
+    lines))
 
-(defmethod inspect-for-emacs :around ((o t))
+(defmethod emacs-inspect :around ((o t))
   (if (or (uvector-inspector-p o)
           (not (ccl:uvectorp o)))
       (call-next-method)
-      (multiple-value-bind (title content)
-          (call-next-method)
-        (values
-         title
-         (append content
+      (append (call-next-method)
                  `((:newline)
                    (:value ,(make-instance 'uvector-inspector :object o)
-                           "Underlying UVECTOR")))))))
+                           "Underlying UVECTOR")))))
 
 (defclass uvector-inspector ()
   ((object :initarg :object)))
@@ -840,15 +832,14 @@
   (:method ((object t)) nil)
   (:method ((object uvector-inspector)) t))
 
-(defmethod inspect-for-emacs ((uv uvector-inspector))
+(defmethod emacs-inspect ((uv uvector-inspector))
   (with-slots (object)
       uv
-    (values (format nil "The UVECTOR for ~S." object)
             (loop
                for index below (ccl::uvsize object)
                collect (format nil "~D: " index)
                collect `(:value ,(ccl::uvref object index))
-               collect `(:newline)))))
+               collect `(:newline))))
 
 (defun closure-closed-over-values (closure)
   (let ((howmany (nth-value 8 (ccl::function-args (ccl::closure-function closure)))))
@@ -860,9 +851,9 @@
 		(cellp (ccl::closed-over-value-p value)))
 	   (list label (if cellp (ccl::closed-over-value value) value))))))
 
-(defmethod inspect-for-emacs ((c ccl::compiled-lexical-closure))
-  (values
-   (format nil "A closure: ~a" c)
+(defmethod emacs-inspect ((c ccl::compiled-lexical-closure))
+  (list*
+   (format nil "A closure: ~a~%" c)
    `(,@(if (arglist c)
 	   (list "Its argument list is: " 
 		 (funcall (intern "INSPECTOR-PRINC" 'swank) (arglist c))) 

Modified: branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-sbcl.lisp	Mon Feb 11 09:24:55 2008
@@ -1001,41 +1001,38 @@
 

 ;;;; Inspector
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (cond ((sb-di::indirect-value-cell-p o)
-         (values "A value cell." (label-value-line*
-                                  (:value (sb-kernel:value-cell-ref o)))))
+         (label-value-line* (:value (sb-kernel:value-cell-ref o))))
 	(t
 	 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
-           (if label
-               (values text (loop for (l . v) in parts
-                                  append (label-value-line l v)))
-               (values text (loop for value in parts  for i from 0
-                                  append (label-value-line i value))))))))
+           (list* (format nil "~a~%" text)
+                  (if label
+                      (loop for (l . v) in parts
+                            append (label-value-line l v))
+                      (loop for value in parts  for i from 0
+                            append (label-value-line i value))))))))
 
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
   (let ((header (sb-kernel:widetag-of o)))
     (cond ((= header sb-vm:simple-fun-header-widetag)
-	   (values "A simple-fun."
                    (label-value-line*
                     (:name (sb-kernel:%simple-fun-name o))
                     (:arglist (sb-kernel:%simple-fun-arglist o))
                     (:self (sb-kernel:%simple-fun-self o))
                     (:next (sb-kernel:%simple-fun-next o))
                     (:type (sb-kernel:%simple-fun-type o))
-                    (:code (sb-kernel:fun-code-header o)))))
+                    (:code (sb-kernel:fun-code-header o))))
 	  ((= header sb-vm:closure-header-widetag)
-	   (values "A closure."
                    (append
                     (label-value-line :function (sb-kernel:%closure-fun o))
                     `("Closed over values:" (:newline))
                     (loop for i below (1- (sb-kernel:get-closure-length o))
                           append (label-value-line
-                                  i (sb-kernel:%closure-index-ref o i))))))
+                                  i (sb-kernel:%closure-index-ref o i)))))
 	  (t (call-next-method o)))))
 
-(defmethod inspect-for-emacs ((o sb-kernel:code-component))
-  (values (format nil "~A is a code data-block." o)
+(defmethod emacs-inspect ((o sb-kernel:code-component))
           (append
            (label-value-line*
             (:code-size (sb-kernel:%code-code-size o))
@@ -1060,28 +1057,24 @@
                                 sb-vm:n-word-bytes))
                           (ash 1 sb-vm:n-lowtag-bits))
                          (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
-                         :stream s))))))))
+                         :stream s)))))))
 
-(defmethod inspect-for-emacs ((o sb-ext:weak-pointer))
-  (values "A weak pointer."
+(defmethod emacs-inspect ((o sb-ext:weak-pointer))
           (label-value-line*
-           (:value (sb-ext:weak-pointer-value o)))))
+           (:value (sb-ext:weak-pointer-value o))))
 
-(defmethod inspect-for-emacs ((o sb-kernel:fdefn))
-  (values "A fdefn object."
+(defmethod emacs-inspect ((o sb-kernel:fdefn))
           (label-value-line*
            (:name (sb-kernel:fdefn-name o))
-           (:function (sb-kernel:fdefn-fun o)))))
+           (:function (sb-kernel:fdefn-fun o))))
 
-(defmethod inspect-for-emacs :around ((o generic-function))
-  (multiple-value-bind (title contents) (call-next-method)
-    (values title
+(defmethod emacs-inspect :around ((o generic-function))
             (append
-             contents
+             (call-next-method)
              (label-value-line*
               (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
               (:initial-methods (sb-pcl::generic-function-initial-methods o))
-              )))))
+              )))
 
 

 ;;;; Multiprocessing

Modified: branches/trunk-reorg/thirdparty/slime/swank-scl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-scl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-scl.lisp	Mon Feb 11 09:24:55 2008
@@ -1693,11 +1693,6 @@
 

 ;;;; Inspecting
 
-(defclass scl-inspector (backend-inspector) ())
-
-(defimplementation make-default-inspector ()
-  (make-instance 'scl-inspector))
-
 (defconstant +lowtag-symbols+ 
   '(vm:even-fixnum-type
     vm:instance-pointer-type
@@ -1740,10 +1735,9 @@
                                   :key #'symbol-value)))
           (format t ", type: ~A" type-symbol))))))
 
-(defmethod inspect-for-emacs ((o t))
+(defmethod emacs-inspect ((o t))
   (cond ((di::indirect-value-cell-p o)
-         (values (format nil "~A is a value cell." o)
-                 `("Value: " (:value ,(c:value-cell-ref o)))))
+                 `("Value: " (:value ,(c:value-cell-ref o))))
         ((alien::alien-value-p o)
          (inspect-alien-value o))
 	(t
@@ -1752,17 +1746,17 @@
 (defun scl-inspect (o)
   (destructuring-bind (text labeledp . parts)
       (inspect::describe-parts o)
-    (values (format nil "~A~%" text)
+    (list*  (format nil "~A~%" text)
             (if labeledp
                 (loop for (label . value) in parts
                       append (label-value-line label value))
                 (loop for value in parts  for i from 0 
                       append (label-value-line i value))))))
 
-(defmethod inspect-for-emacs ((o function))
+(defmethod emacs-inspect ((o function))
   (let ((header (kernel:get-type o)))
     (cond ((= header vm:function-header-type)
-           (values (format nil "~A is a function." o)
+           (list*  (format nil "~A is a function.~%" o)
                    (append (label-value-line*
                             ("Self" (kernel:%function-self o))
                             ("Next" (kernel:%function-next o))
@@ -1774,7 +1768,7 @@
                             (with-output-to-string (s)
                               (disassem:disassemble-function o :stream s))))))
           ((= header vm:closure-header-type)
-           (values (format nil "~A is a closure" o)
+           (list* (format nil "~A is a closure.~%" o)
                    (append 
                     (label-value-line "Function" (kernel:%closure-function o))
                     `("Environment:" (:newline))
@@ -1788,8 +1782,7 @@
            (call-next-method)))))
 
 
-(defmethod inspect-for-emacs ((o kernel:code-component))
-  (values (format nil "~A is a code data-block." o)
+(defmethod emacs-inspect ((o kernel:code-component))
           (append 
            (label-value-line* 
             ("code-size" (kernel:%code-code-size o))
@@ -1813,20 +1806,19 @@
                              (* vm:code-constants-offset vm:word-bytes))
                           (ash 1 vm:lowtag-bits))
                          (ash (kernel:%code-code-size o) vm:word-shift)
-                         :stream s))))))))
+                         :stream s)))))))
 
-(defmethod inspect-for-emacs ((o kernel:fdefn))
-  (values (format nil "~A is a fdenf object." o)
-          (label-value-line*
+(defmethod emacs-inspect ((o kernel:fdefn))
+  (label-value-line*
            ("name" (kernel:fdefn-name o))
            ("function" (kernel:fdefn-function o))
            ("raw-addr" (sys:sap-ref-32
                         (sys:int-sap (kernel:get-lisp-obj-address o))
-                        (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
+                        (* vm:fdefn-raw-addr-slot vm:word-bytes)))))
 
-(defmethod inspect-for-emacs ((o array))
+(defmethod emacs-inspect ((o array))
   (cond ((kernel:array-header-p o)
-         (values (format nil "~A is an array." o)
+         (list*  (format nil "~A is an array.~%" o)
                  (label-value-line*
                   (:header (describe-primitive-type o))
                   (:rank (array-rank o))
@@ -1838,13 +1830,13 @@
                   (:displaced-p (kernel:%array-displaced-p o))
                   (:dimensions (array-dimensions o)))))
         (t
-         (values (format nil "~A is an simple-array." o)
+         (list*  (format nil "~A is an simple-array.~%" o)
                  (label-value-line*
                   (:header (describe-primitive-type o))
                   (:length (length o)))))))
 
-(defmethod inspect-for-emacs ((o simple-vector))
-  (values (format nil "~A is a vector." o)
+(defmethod emacs-inspect ((o simple-vector))
+  (list*  (format nil "~A is a vector.~%" o)
           (append 
            (label-value-line*
             (:header (describe-primitive-type o))
@@ -1854,8 +1846,6 @@
                    append (label-value-line i (aref o i)))))))
 
 (defun inspect-alien-record (alien)
-  (values
-   (format nil "~A is an alien value." alien)
    (with-struct (alien::alien-value- sap type) alien
      (with-struct (alien::alien-record-type- kind name fields) type
        (append
@@ -1865,16 +1855,14 @@
          (:name name))
         (loop for field in fields 
               append (let ((slot (alien::alien-record-field-name field)))
-                       (label-value-line slot (alien:slot alien slot)))))))))
+                       (label-value-line slot (alien:slot alien slot))))))))
 
 (defun inspect-alien-pointer (alien)
-  (values
-   (format nil "~A is an alien value." alien)
-   (with-struct (alien::alien-value- sap type) alien
+  (with-struct (alien::alien-value- sap type) alien
      (label-value-line* 
       (:sap sap)
       (:type type)
-      (:to (alien::deref alien))))))
+      (:to (alien::deref alien)))))
   
 (defun inspect-alien-value (alien)
   (typecase (alien::alien-value-type alien)

Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp	Mon Feb 11 09:24:55 2008
@@ -13,7 +13,7 @@
 ;;; available to us here via the `SWANK-BACKEND' package.
 
 (defpackage :swank
-  (:use :common-lisp :swank-backend)
+  (:use :cl :swank-backend)
   (:export #:startup-multiprocessing
            #:start-server 
            #:create-server
@@ -24,8 +24,8 @@
            #:print-indentation-lossage
            #:swank-debugger-hook
            #:run-after-init-hook
-           #:inspect-for-emacs
-           #:inspect-slot-for-emacs
+           #:emacs-inspect
+           ;;#:inspect-slot-for-emacs
            ;; These are user-configurable variables:
            #:*communication-style*
            #:*dont-close*
@@ -2677,176 +2677,19 @@
 

 ;;;; Inspecting
 
-(defun common-seperated-spec (list &optional (callback (lambda (v) 
-							 `(:value ,v))))
-  (butlast
-   (loop
-      for i in list
-      collect (funcall callback i)
-      collect ", ")))
-
-(defun inspector-princ (list)
-  "Like princ-to-string, but don't rewrite (function foo) as #'foo. 
-Do NOT pass circular lists to this function."
-  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
-    (set-pprint-dispatch '(cons (member function)) nil)
-    (princ-to-string list)))
-
-(defmethod inspect-for-emacs ((object cons))
-  (if (consp (cdr object))
-      (inspect-for-emacs-list object)
-      (inspect-for-emacs-simple-cons object)))
-
-(defun inspect-for-emacs-simple-cons (cons)
-  (values "A cons cell."
-          (label-value-line* 
-           ('car (car cons))
-           ('cdr (cdr cons)))))
-
-(defun inspect-for-emacs-list (list)
-  (let ((maxlen 40))
-    (multiple-value-bind (length tail) (safe-length list)
-      (flet ((frob (title list)
-               (let (lines)
-                 (loop for i from 0 for rest on list do
-                       (if (consp (cdr rest))     ; e.g. (A . (B . ...))
-                           (push (label-value-line i (car rest)) lines)
-                           (progn                 ; e.g. (A . NIL) or (A . B)
-                             (push (label-value-line i (car rest) :newline nil) lines)
-                             (when (cdr rest)
-                               (push '((:newline)) lines)
-                               (push (label-value-line ':tail () :newline nil) lines))
-                             (loop-finish)))
-                       finally
-                       (setf lines (reduce #'append (nreverse lines) :from-end t)))
-                 (values title (append '("Elements:" (:newline)) lines)))))
-                               
-        (cond ((not length)             ; circular
-               (frob "A circular list."
-                     (cons (car list)
-                           (ldiff (cdr list) list))))
-              ((and (<= length maxlen) (not tail))
-               (frob "A proper list." list))
-              (tail
-               (frob "An improper list." list))
-              (t
-               (frob "A proper list." list)))))))
-
-;; (inspect-for-emacs-list '#1=(a #1# . #1# ))
-
-(defun safe-length (list)
-  "Similar to `list-length', but avoid errors on improper lists.
-Return two values: the length of the list and the last cdr.
-NIL is returned if the list is circular."
-  (do ((n 0 (+ n 2))                    ;Counter.
-       (fast list (cddr fast))          ;Fast pointer: leaps by 2.
-       (slow list (cdr slow)))          ;Slow pointer: leaps by 1.
-      (nil)
-    (cond ((null fast) (return (values n nil)))
-          ((not (consp fast)) (return (values n fast)))
-          ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
-          ((and (eq fast slow) (> n 0)) (return nil))
-          ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
-
-(defvar *slime-inspect-contents-limit* nil "How many elements of
- a hash table or array to show by default. If table has more than
- this then offer actions to view more. Set to nil for no limit." )
-
-(defmethod inspect-for-emacs ((ht hash-table))
-  (values (prin1-to-string ht)
-          (append
-           (label-value-line*
-            ("Count" (hash-table-count ht))
-            ("Size" (hash-table-size ht))
-            ("Test" (hash-table-test ht))
-            ("Rehash size" (hash-table-rehash-size ht))
-            ("Rehash threshold" (hash-table-rehash-threshold ht)))
-           (let ((weakness (hash-table-weakness ht)))
-             (when weakness
-               `("Weakness: " (:value ,weakness) (:newline))))
-           (unless (zerop (hash-table-count ht))
-             `((:action "[clear hashtable]" ,(lambda () (clrhash ht))) (:newline)
-               "Contents: " (:newline)))
-	   (if (and *slime-inspect-contents-limit*
-		    (>= (hash-table-count ht) *slime-inspect-contents-limit*))
-	       (inspect-bigger-piece-actions ht (hash-table-count ht))
-	       nil)
-           (loop for key being the hash-keys of ht
-                 for value being the hash-values of ht
-                 repeat (or *slime-inspect-contents-limit* most-positive-fixnum)
-                 append `((:value ,key) " = " (:value ,value)
-                          " " (:action "[remove entry]"
-                               ,(let ((key key))
-                                  (lambda () (remhash key ht))))
-                          (:newline))))))
-
-(defun inspect-bigger-piece-actions (thing size)
-  (append 
-   (if (> size *slime-inspect-contents-limit*)
-       (list (inspect-show-more-action thing)
-	     '(:newline))
-       nil)
-   (list (inspect-whole-thing-action thing  size)
-	 '(:newline))))
-
-(defun inspect-whole-thing-action (thing size)
-  `(:action ,(format nil "Inspect all ~a elements." 
-		      size)
-	    ,(lambda() 
-	       (let ((*slime-inspect-contents-limit* nil))
-		 (swank::inspect-object thing)))))
-
-(defun inspect-show-more-action (thing)
-  `(:action ,(format nil "~a elements shown. Prompt for how many to inspect..." 
-		     *slime-inspect-contents-limit* )
-	    ,(lambda() 
-	       (let ((*slime-inspect-contents-limit* 
-		      (progn (format t "How many elements should be shown? ") (read))))
-		 (swank::inspect-object thing)))))
-
-(defmethod inspect-for-emacs ((array array))
-  (values "An array."
-          (append
-           (label-value-line*
-            ("Dimensions" (array-dimensions array))
-            ("Its element type is" (array-element-type array))
-            ("Total size" (array-total-size array))
-            ("Adjustable" (adjustable-array-p array)))
-           (when (array-has-fill-pointer-p array)
-             (label-value-line "Fill pointer" (fill-pointer array)))
-           '("Contents:" (:newline))
-           (if (and *slime-inspect-contents-limit*
-		    (>= (array-total-size array) *slime-inspect-contents-limit*))
-	       (inspect-bigger-piece-actions array  (length array))
-	       nil)
-           (loop for i below (or *slime-inspect-contents-limit* (array-total-size array))
-                 append (label-value-line i (row-major-aref array i))))))
-
-(defmethod inspect-for-emacs ((char character))
-  (values "A character."
-          (append 
-           (label-value-line*
-            ("Char code" (char-code char))
-            ("Lower cased" (char-downcase char))
-            ("Upper cased" (char-upcase char)))
-           (if (get-macro-character char)
-               `("In the current readtable (" 
-                 (:value ,*readtable*) ") it is a macro character: "
-                 (:value ,(get-macro-character char)))))))
-
 (defvar *inspectee*)
+(defvar *inspectee-content*)
 (defvar *inspectee-parts*) 
 (defvar *inspectee-actions*)
-(defvar *inspector-stack* '())
-(defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
-(declaim (type vector *inspector-history*))
-(defvar *inspect-length* 30)
+(defvar *inspector-stack*)
+(defvar *inspector-history*)
 
 (defun reset-inspector ()
   (setq *inspectee* nil
-        *inspector-stack* nil
+        *inspectee-content* nil
         *inspectee-parts* (make-array 10 :adjustable t :fill-pointer 0)
         *inspectee-actions* (make-array 10 :adjustable t :fill-pointer 0)
+        *inspector-stack* '()
         *inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
 
 (defslimefun init-inspector (string)
@@ -2854,54 +2697,57 @@
     (reset-inspector)
     (inspect-object (eval (read-from-string string)))))
 
-(defun print-part-to-string (value)
-  (let ((string (to-string value))
-        (pos (position value *inspector-history*)))
-    (if pos
-        (format nil "#~D=~A" pos string)
-        string)))
+(defun inspect-object (o)
+  (push (setq *inspectee* o) *inspector-stack*)
+  (unless (find o *inspector-history*)
+    (vector-push-extend o *inspector-history*))
+  (let ((*print-pretty* nil) ; print everything in the same line
+        (*print-circle* t)
+        (*print-readably* nil))
+    (setq *inspectee-content* (inspector-content (emacs-inspect o))))
+  (list :title (with-output-to-string (s)
+                 (print-unreadable-object (o s :type t :identity t)))
+        :id (assign-index o *inspectee-parts*)
+        :content (content-range *inspectee-content* 0 500)))
 
-(defun inspector-content-for-emacs (specs)
+(defun inspector-content (specs)
   (loop for part in specs collect 
         (etypecase part
-          (null ; XXX encourages sloppy programming
-           nil)
+          ;;(null ; XXX encourages sloppy programming
+          ;; nil)
           (string part)
           (cons (destructure-case part
                   ((:newline) 
-                   (string #\newline))
+                   '#.(string #\newline))
                   ((:value obj &optional str) 
-                   (value-part-for-emacs obj str))
+                   (value-part obj str))
                   ((:action label lambda &key (refreshp t)) 
-                   (action-part-for-emacs label lambda refreshp)))))))
+                   (action-part label lambda refreshp)))))))
 
 (defun assign-index (object vector)
   (let ((index (fill-pointer vector)))
     (vector-push-extend object vector)
     index))
 
-(defun value-part-for-emacs (object string)
+(defun value-part (object string)
   (list :value 
         (or string (print-part-to-string object))
         (assign-index object *inspectee-parts*)))
 
-(defun action-part-for-emacs (label lambda refreshp)
+(defun action-part (label lambda refreshp)
   (list :action label (assign-index (list lambda refreshp)
                                     *inspectee-actions*)))
 
-(defun inspect-object (object)
-  (push (setq *inspectee* object) *inspector-stack*)
-  (unless (find object *inspector-history*)
-    (vector-push-extend object *inspector-history*))
-  (let ((*print-pretty* nil)            ; print everything in the same line
-        (*print-circle* t)
-        (*print-readably* nil))
-    (multiple-value-bind (_ content) (inspect-for-emacs object)
-      (declare (ignore _))
-      (list :title (with-output-to-string (s)
-                     (print-unreadable-object (object s :type t :identity t)))
-            :id (assign-index object *inspectee-parts*)
-            :content (inspector-content-for-emacs content)))))
+(defun print-part-to-string (value)
+  (let ((string (to-string value))
+        (pos (position value *inspector-history*)))
+    (if pos
+        (format nil "#~D=~A" pos string)
+        string)))
+
+(defun content-range (list start end)
+  (let* ((len (length list)) (end (min len end)))
+    (list (subseq list start end) len start end)))
 
 (defslimefun inspector-nth-part (index)
   (aref *inspectee-parts* index))
@@ -2910,18 +2756,20 @@
   (with-buffer-syntax ()
     (inspect-object (inspector-nth-part index))))
 
+(defslimefun inspector-range (from to)
+  (content-range *inspectee-content* from to))
+
 (defslimefun inspector-call-nth-action (index &rest args)
-  (destructuring-bind (action-lambda refreshp)
-      (aref *inspectee-actions* index)
-    (apply action-lambda args)
+  (destructuring-bind (fun refreshp) (aref *inspectee-actions* index)
+    (apply fun args)
     (if refreshp
         (inspect-object (pop *inspector-stack*))
         ;; tell emacs that we don't want to refresh the inspector buffer
         nil)))
 
 (defslimefun inspector-pop ()
-  "Drop the inspector stack and inspect the second element.  Return
-nil if there's no second element."
+  "Drop the inspector stack and inspect the second element.
+Return nil if there's no second element."
   (with-buffer-syntax ()
     (cond ((cdr *inspector-stack*)
            (pop *inspector-stack*)
@@ -2931,10 +2779,10 @@
 (defslimefun inspector-next ()
   "Inspect the next element in the *inspector-history*."
   (with-buffer-syntax ()
-    (let ((position (position *inspectee* *inspector-history*)))
-      (cond ((= (1+ position) (length *inspector-history*))
+    (let ((pos (position *inspectee* *inspector-history*)))
+      (cond ((= (1+ pos) (length *inspector-history*))
              nil)
-            (t (inspect-object (aref *inspector-history* (1+ position))))))))
+            (t (inspect-object (aref *inspector-history* (1+ pos))))))))
 
 (defslimefun inspector-reinspect ()
   (inspect-object *inspectee*))
@@ -2968,6 +2816,111 @@
     (reset-inspector)
     (inspect-object (frame-var-value frame var))))
 
+;;;;; Lists
+
+(defmethod emacs-inspect ((o cons))
+  (if (consp (cdr o))
+      (inspect-list o)
+      (inspect-cons o)))
+
+(defun inspect-cons (cons)
+  (label-value-line* 
+   ('car (car cons))
+   ('cdr (cdr cons))))
+
+;; (inspect-list '#1=(a #1# . #1# ))
+;; (inspect-list (list* 'a 'b 'c))
+;; (inspect-list (make-list 10000))
+
+(defun inspect-list (list)
+  (multiple-value-bind (length tail) (safe-length list)
+    (flet ((frob (title list)
+             (list* title '(:newline) (inspect-list-aux list))))
+      (cond ((not length)
+             (frob "A circular list:"
+                   (cons (car list)
+                         (ldiff (cdr list) list))))
+            ((not tail)
+             (frob "A proper list:" list))
+            (t
+             (frob "An improper list:" list))))))
+
+(defun inspect-list-aux (list)
+  (loop for i from 0  for rest on list  while (consp rest)  append 
+        (cond ((consp (cdr rest))
+               (label-value-line i (car rest)))
+              ((cdr rest)
+               (label-value-line* (i (car rest))
+                                  (:tail (cdr rest))))
+              (t 
+               (label-value-line i (car rest))))))
+
+(defun safe-length (list)
+  "Similar to `list-length', but avoid errors on improper lists.
+Return two values: the length of the list and the last cdr.
+Return NIL if LIST is circular."
+  (do ((n 0 (+ n 2))                    ;Counter.
+       (fast list (cddr fast))          ;Fast pointer: leaps by 2.
+       (slow list (cdr slow)))          ;Slow pointer: leaps by 1.
+      (nil)
+    (cond ((null fast) (return (values n nil)))
+          ((not (consp fast)) (return (values n fast)))
+          ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+          ((and (eq fast slow) (> n 0)) (return nil))
+          ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+
+;;;;; Hashtables
+
+(defmethod emacs-inspect ((ht hash-table))
+  (append
+   (label-value-line*
+    ("Count" (hash-table-count ht))
+    ("Size" (hash-table-size ht))
+    ("Test" (hash-table-test ht))
+    ("Rehash size" (hash-table-rehash-size ht))
+    ("Rehash threshold" (hash-table-rehash-threshold ht)))
+   (let ((weakness (hash-table-weakness ht)))
+     (when weakness
+       (label-value-line "Weakness:" weakness)))
+   (unless (zerop (hash-table-count ht))
+     `((:action "[clear hashtable]" 
+                ,(lambda () (clrhash ht))) (:newline)
+       "Contents: " (:newline)))
+   (loop for key being the hash-keys of ht
+         for value being the hash-values of ht
+         append `((:value ,key) " = " (:value ,value)
+                  " " (:action "[remove entry]"
+                               ,(let ((key key))
+                                     (lambda () (remhash key ht))))
+                  (:newline)))))
+
+;;;;; Arrays
+
+(defmethod emacs-inspect ((array array))
+  (append
+   (label-value-line*
+    ("Dimensions" (array-dimensions array))
+    ("Element type" (array-element-type array))
+    ("Total size" (array-total-size array))
+    ("Adjustable" (adjustable-array-p array)))
+   (when (array-has-fill-pointer-p array)
+     (label-value-line "Fill pointer" (fill-pointer array)))
+   '("Contents:" (:newline))
+   (loop for i below (array-total-size array)
+         append (label-value-line i (row-major-aref array i)))))
+
+;;;;; Chars
+
+(defmethod emacs-inspect ((char character))
+  (append 
+   (label-value-line*
+    ("Char code" (char-code char))
+    ("Lower cased" (char-downcase char))
+    ("Upper cased" (char-upcase char)))
+   (if (get-macro-character char)
+       `("In the current readtable (" 
+         (:value ,*readtable*) ") it is a macro character: "
+         (:value ,(get-macro-character char))))))
 

 ;;;; Thread listing
 


From hhubner at common-lisp.net  Mon Feb 11 14:27:46 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 11 Feb 2008 09:27:46 -0500 (EST)
Subject: [bknr-cvs] r2476 - branches/trunk-reorg/thirdparty/cl-gd-0.5.6
Message-ID: <20080211142746.23D081603B@common-lisp.net>

Author: hhubner
Date: Mon Feb 11 09:27:45 2008
New Revision: 2476

Modified:
   branches/trunk-reorg/thirdparty/cl-gd-0.5.6/   (props changed)
   branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
Log:
ignore .so file, fix conflict

Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	(original)
+++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd	Mon Feb 11 09:27:45 2008
@@ -54,9 +54,5 @@
                (:file "drawing")
                (:file "strings")
                (:file "misc"))
-<<<<<<< .mine
   :depends-on (#-clisp :uffi
                #+clisp :cffi-uffi-compat))
-=======
-  :depends-on (:uffi))
->>>>>>> .r2473


From ksprotte at common-lisp.net  Mon Feb 11 17:22:23 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 12:22:23 -0500 (EST)
Subject: [bknr-cvs] r2477 - branches/trunk-reorg/thirdparty/kmrcl-1.97
Message-ID: <20080211172223.D90EB68223@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 12:22:22 2008
New Revision: 2477

Modified:
   branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp
Log:
kmrcl removed two offending symbols from export list


Modified: branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp	(original)
+++ branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp	Mon Feb 11 12:22:22 2008
@@ -119,7 +119,7 @@
    #:cwd
    #:quit
    #:command-line-arguments
-   #:copy-file
+   ;; #:copy-file
    #:run-shell-command
 
    ;; lists.lisp
@@ -253,7 +253,7 @@
    #:init/repl
 
    ;; From web-utils
-   #:*base-url*
+   ;; #:*base-url*
    #:base-url!
    #:make-url
    #:*standard-html-header*


From ksprotte at common-lisp.net  Mon Feb 11 17:22:52 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 12:22:52 -0500 (EST)
Subject: [bknr-cvs] r2478 - branches/trunk-reorg/thirdparty/arnesi
Message-ID: <20080211172252.41E1268243@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 12:22:52 2008
New Revision: 2478

Modified:
   branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
Log:
removed slime dependency


Modified: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/arnesi/arnesi.asd	(original)
+++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd	Mon Feb 11 12:22:52 2008
@@ -35,7 +35,7 @@
 			     (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk"))
                              (:file "lexenv" :depends-on ("packages" "one-liners"))
                              (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control"))
-                             (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
+                             ;; (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
                              (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners"))
                              (:file "mop" :depends-on ("packages" "mopp"))
 			     (:file "mopp" :depends-on ("packages" "list" "flow-control"))
@@ -63,7 +63,7 @@
 		:components ((:file "accumulation" :depends-on ("suite"))
                              (:file "call-cc" :depends-on ("suite"))
                              (:file "http" :depends-on ("suite"))
-                             (:file "log" :depends-on ("suite"))
+                             ;; (:file "log" :depends-on ("suite"))
                              (:file "matcher" :depends-on ("suite"))
                              (:file "numbers" :depends-on ("suite"))
                              (:file "queue" :depends-on ("suite"))


From ksprotte at common-lisp.net  Mon Feb 11 17:24:44 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 11 Feb 2008 12:24:44 -0500 (EST)
Subject: [bknr-cvs] r2479 - in branches/trunk-reorg/projects/bos: m2 web
Message-ID: <20080211172444.B4E3A1603F@common-lisp.net>

Author: ksprotte
Date: Mon Feb 11 12:24:41 2008
New Revision: 2479

Modified:
   branches/trunk-reorg/projects/bos/m2/m2.lisp
   branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
   branches/trunk-reorg/projects/bos/m2/packages.lisp
   branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
   branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp
   branches/trunk-reorg/projects/bos/web/boi-handlers.lisp
   branches/trunk-reorg/projects/bos/web/bos.web.asd
   branches/trunk-reorg/projects/bos/web/contract-handlers.lisp
   branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
   branches/trunk-reorg/projects/bos/web/kml-handlers.lisp
   branches/trunk-reorg/projects/bos/web/languages-handler.lisp
   branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp
   branches/trunk-reorg/projects/bos/web/map-handlers.lisp
   branches/trunk-reorg/projects/bos/web/news-handlers.lisp
   branches/trunk-reorg/projects/bos/web/packages.lisp
   branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
   branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
   branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
   branches/trunk-reorg/projects/bos/web/web-macros.lisp
   branches/trunk-reorg/projects/bos/web/web-utils.lisp
   branches/trunk-reorg/projects/bos/web/webserver.lisp
Log:
bos changes for trunk-reorg; unfinished, committed for backup


Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/m2.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/m2.lisp	Mon Feb 11 12:24:41 2008
@@ -189,8 +189,8 @@
 (defclass editor-only-handler ()
   ())
 
-(defmethod bknr.web:authorized-p ((handler editor-only-handler) req)
-  (editor-p (bknr-request-user req)))
+(defmethod bknr.web:authorized-p ((handler editor-only-handler))
+  (editor-p bknr.web:*user*))
 
 ;;;; CONTRACT
 
@@ -446,11 +446,12 @@
       (incf retval (length (contract-m2s contract))))
     retval))
 
-(defun string-safe (string)
-  (if string
-      (escape-nl (with-output-to-string (s)
-		   (net.html.generator::emit-safe s string)))
-      ""))
+;; trunk-reorg adaption
+;; (defun string-safe (string)
+;;   (if string
+;;       (escape-nl (with-output-to-string (s)
+;; 		   (net.html.generator::emit-safe s string)))
+;;       ""))
 
 (defun make-m2-javascript (sponsor)
   "Erzeugt das Quadratmeter-Javascript f?r die angegebenen Contracts"

Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp	Mon Feb 11 12:24:41 2008
@@ -251,8 +251,8 @@
   (ignore-errors
     (delete-file (contract-pdf-pathname contract :print t))))
 
-(defun mail-backoffice-sponsor-data (contract req)
-  (with-query-params (req numsqm country email name address date language)
+(defun mail-backoffice-sponsor-data (contract)
+  (with-query-params (numsqm country email name address date language)
     (let ((parts (list (make-html-part (format nil "
 <html>
  <body>
@@ -294,7 +294,7 @@
       (mail-contract-data contract "Manually entered sponsor" parts))))
 
 (defun mail-manual-sponsor-data (req)
-  (with-query-params (req contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly)
+  (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
 	   (sponsor-id (store-object-id (contract-sponsor contract)))
 	   (parts (list (make-html-part (format nil "
@@ -363,7 +363,7 @@
       (error "cannot find WorldPay callback params for contract ~A~%" contract-id)))
 
 (defun mail-worldpay-sponsor-data (req)
-  (with-query-params (req contract-id)
+  (with-query-params (contract-id)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
 	   (params (get-worldpay-params contract-id))
 	   (parts (list (make-html-part (format nil "

Modified: branches/trunk-reorg/projects/bos/m2/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/packages.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/packages.lisp	Mon Feb 11 12:24:41 2008
@@ -54,7 +54,7 @@
 	:bknr.statistics
 	:bknr.rss
 	:bos.m2.config
-	:net.post-office
+	:cl-smtp
 	:kmrcl
 	:cxml
 	:cl-mime

Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -6,8 +6,8 @@
 (defclass allocation-area-handler (admin-only-handler edit-object-handler)
   ())
 
-(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)) req)
-  (with-bos-cms-page (req :title "Allocation Areas")
+(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)))
+  (with-bos-cms-page (:title "Allocation Areas")
     (html
      (:h2 "Defined allocation areas")
      ((:table :border "1")
@@ -27,8 +27,8 @@
 		 (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%")))))
      (:p (cmslink "create-allocation-area" "Create new allocation area")))))
 
-(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req)
-  (with-bos-cms-page (req :title "Allocation Area")
+(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area)
+  (with-bos-cms-page (:title "Allocation Area")
     (with-slots (active-p left top width height) allocation-area
       (html
        ((:table :border "1")
@@ -75,15 +75,15 @@
 			      do (html (:td ((:a :href #?"/enlarge-overview/$(tile-x)/$(tile-y)")
 					     ((:img :width "90" :height "90" :border "0" :src #?"/overview/$(tile-x)/$(tile-y)"))))))))))))))
 
-(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area req)
+(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area)
   (delete-object allocation-area)
-  (with-bos-cms-page (req :title "Allocation area has been deleted")
+  (with-bos-cms-page (:title "Allocation area has been deleted")
     (:h2 "The allocation area has been deleted")))
 
 (defclass allocation-area-gfx-handler (editor-only-handler object-handler)
   ())
 
-(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req)
+(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area)
   (cl-gd:with-image* ((allocation-area-width allocation-area)
 		      (allocation-area-height allocation-area) t)
     (with-slots (left top width height) allocation-area
@@ -128,29 +128,27 @@
 (defclass create-allocation-area-handler (admin-only-handler form-handler)
   ())
 
-(defmethod handle-form ((handler create-allocation-area-handler) action req)
-  (with-query-params (req x y left top)
+(defmethod handle-form ((handler create-allocation-area-handler) action)
+  (with-query-params (x y left top)
     (cond
       ((and x y left top)
        (destructuring-bind (x y left top) (mapcar #'parse-integer (list x y left top))
 	 (if (or (some (complement #'plusp) (list x y left top))
 		   (<= x left)
 		   (<= y top))
-	     (with-bos-cms-page (req :title "Invalid area selected")
+	     (with-bos-cms-page (:title "Invalid area selected")
 	       (:h2 "Choose upper left corner first, then lower-right corner"))
 	     (redirect (format nil "/allocation-area/~D" (store-object-id
-							  (make-allocation-rectangle left top (- x left) (- y top))))
-		   req))))
+							  (make-allocation-rectangle left top (- x left) (- y top))))))))
       ((and x y)
        (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&"
 			 x y
 			 (uriencode-string "Choose lower right point of allocation area")
 			 (uriencode-string (format nil "~A?left=~A&top=~A&"
-						   (uri-path (request-uri req))
-						   x y)))
-		 req))
+						   (uri-path (hunchentoot:request-uri))
+						   x y)))))
       (t
-       (with-bos-cms-page (req :title "Create allocation area")
+       (with-bos-cms-page (:title "Create allocation area")
 	 ((:form :method "POST" :enctype "multipart/form-data"))
 	 ((:table :border "0")
 	  (:tr ((:td :colspan "2")
@@ -163,23 +161,22 @@
 	  (:tr (:td "Start-Y") (:td (text-field "start-y" :value 0 :size 5)))
 	  (:tr (:td (submit-button "rectangle" "rectangle")))))))))
 
-(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)) req)
-  (with-query-params (req start-x start-y)
+(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)))
+  (with-query-params (start-x start-y)
     (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&"
 		      start-x start-y
 		      (uriencode-string "Choose upper left point of allocation area")
-		      (uriencode-string (format nil "~A?" (uri-path (request-uri req)))))
-	      req)))
+		      (uriencode-string (format nil "~A?" (uri-path (hunchentoot:request-uri))))))))
 
-(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req)
-  (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car))))
+(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)))
+  (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car))))
     (cond
       ((not uploaded-text-file)
-       (with-bos-cms-page (req :title "No Text file uploaded")
+       (with-bos-cms-page (:title "No Text file uploaded")
 	 (:h2 "File not uploaded")
 	 (:p "Please upload your text file containing the allocation polygon UTM coordinates")))
       (t
-       (with-bos-cms-page (req :title #?"Importing allocation polygons from text file $(uploaded-text-file)")
+       (with-bos-cms-page (:title #?"Importing allocation polygons from text file $(uploaded-text-file)")
 	 (handler-case
 	     (let* ((vertices (polygon-from-text-file uploaded-text-file))
 		    (existing-area (find (coerce vertices 'list)

Modified: branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -5,8 +5,8 @@
 (defclass allocation-cache-handler (admin-only-handler page-handler)
   ())
 
-(defmethod handle ((handler allocation-cache-handler) req)
-  (with-bos-cms-page (req :title "Allocation Cache")
+(defmethod handle ((handler allocation-cache-handler))
+  (with-bos-cms-page (:title "Allocation Cache")
     (html
      (:pre (:princ
 	    (with-output-to-string (*standard-output*)

Modified: branches/trunk-reorg/projects/bos/web/boi-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/boi-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/boi-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -6,8 +6,8 @@
 (defclass boi-handler (page-handler)
   ())
 
-(defmethod authorized-p ((handler boi-handler) req)
-  (bos.m2:editor-p (bknr-request-user req)))
+(defmethod authorized-p ((handler boi-handler))
+  (bos.m2:editor-p bknr.web:*user*))
 
 (defclass create-contract-handler (boi-handler)
   ())
@@ -20,9 +20,9 @@
       (error "Invalid sponsor ID (wrong type)"))
     sponsor))
 
-(defmethod handle ((handler create-contract-handler) req)
-  (with-xml-error-handler (req)
-    (with-query-params (req num-sqm country sponsor-id name paid expires)
+(defmethod handle ((handler create-contract-handler))
+  (with-xml-error-handler ()
+    (with-query-params (num-sqm country sponsor-id name paid expires)
       (setf num-sqm (ignore-errors (parse-integer num-sqm :junk-allowed t)))
       (unless num-sqm
 	(error "missing or invalid num-sqm parameter"))
@@ -53,9 +53,9 @@
 (defclass pay-contract-handler (boi-handler)
   ())
 
-(defmethod handle ((handler pay-contract-handler) req)
-  (with-xml-error-handler (req)
-    (with-query-params (req contract-id name)
+(defmethod handle ((handler pay-contract-handler))
+  (with-xml-error-handler ()
+    (with-query-params (contract-id name)
       (unless contract-id
 	(error "missing contract-id parameter"))
       (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id))
@@ -65,7 +65,7 @@
 	(with-transaction (:contract-paid)
 	  (contract-set-paidp contract (format nil "~A: manually set paid by ~A"
 					       (format-date-time)
-					       (user-login (bknr-request-user req))))
+					       (user-login bknr.web:*user*)))
 	  (when name
 	    (setf (user-full-name (contract-sponsor contract)) name))))
       (with-xml-response ()
@@ -77,9 +77,9 @@
 (defclass cancel-contract-handler (boi-handler)
   ())
 
-(defmethod handle ((handler cancel-contract-handler) req)
-  (with-xml-error-handler (req)
-    (with-query-params (req contract-id)
+(defmethod handle ((handler cancel-contract-handler))
+  (with-xml-error-handler ()
+    (with-query-params (contract-id)
       (unless contract-id
 	(error "missing contract-id parameter"))
       (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id))

Modified: branches/trunk-reorg/projects/bos/web/bos.web.asd
==============================================================================
--- branches/trunk-reorg/projects/bos/web/bos.web.asd	(original)
+++ branches/trunk-reorg/projects/bos/web/bos.web.asd	Mon Feb 11 12:24:41 2008
@@ -16,7 +16,7 @@
   :description "worldpay test web server"
   :long-description ""
 
-  :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml)
+  :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml :acl-compat)
 
   :components ((:file "packages")
 	       (:file "utf-8" :depends-on ("packages"))

Modified: branches/trunk-reorg/projects/bos/web/contract-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/contract-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/contract-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -9,8 +9,8 @@
 
 (defparameter *show-m2s* 5)
 
-(defmethod handle-object ((handler contract-handler) contract req)
-  (with-bos-cms-page (req :title "Displaying contract details")
+(defmethod handle-object ((handler contract-handler) contract)
+  (with-bos-cms-page (:title "Displaying contract details")
     ((:table :border "0")
      (:tr (:td "sponsor")
 	  (:td (html-edit-link (contract-sponsor contract))))

Modified: branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp	Mon Feb 11 12:24:41 2008
@@ -17,7 +17,7 @@
 	;; We manipulate pixels in a temporary array which is copied to the GD image as
 	;; a whole for performance reasons.  The FFI is way too slow to manipulate individual pixels.
 	(let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0))
-	      (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00"))))
+	      (color (parse-color (or (second (decoded-handler-path handler)) "ffff00"))))
 	  (flet ((set-pixel (x y)
 		   (decf x left)
 		   (decf y top)

Modified: branches/trunk-reorg/projects/bos/web/kml-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/kml-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/kml-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -40,7 +40,7 @@
 (defclass contract-kml-handler (object-handler)
   ())
 
-(defmethod handle-object ((handler contract-kml-handler) (contract contract) req)
+(defmethod handle-object ((handler contract-kml-handler) (contract contract))
   (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml")
     ;; when name is xmlns, the attribute does not show up - why (?)
     ;; (attribute "xmlns" "http://earth.google.com/kml/2.2")
@@ -77,5 +77,5 @@
 		(with-element "coordinates"
 		  (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))
 
-(defmethod handle-object ((handle-object contract-kml-handler) (object null) req)
+(defmethod handle-object ((handle-object contract-kml-handler) (object null))
   (error "Contract not found."))

Modified: branches/trunk-reorg/projects/bos/web/languages-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/languages-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/languages-handler.lisp	Mon Feb 11 12:24:41 2008
@@ -5,11 +5,11 @@
 (defclass languages-handler (admin-only-handler form-handler)
   ())
 
-(defmethod handle-form ((handler languages-handler) action req)
-  (with-bos-cms-page (req :title "Languages")
+(defmethod handle-form ((handler languages-handler) action)
+  (with-bos-cms-page (:title "Languages")
     (case action
       (:add (handler-case
-		(with-query-params (req code name)
+		(with-query-params (code name)
 		  (when (and code name)
 		    (make-object 'website-language :code code :name name)
 		    (html (:h2 "Language " (:princ-safe code) " (" (:princ-safe name) ") created"))))
@@ -17,7 +17,7 @@
 		(html (:h2 "Error creating language")
 		      (:pre (:princ-safe e))))))
       (:delete (handler-case
-		   (with-query-params (req delete-code)
+		   (with-query-params (delete-code)
 		     (when delete-code
 		       (delete-object (language-with-code delete-code))
 		       (html (:h2 "Language " (:princ-safe delete-code) " deleted"))))

Modified: branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp	Mon Feb 11 12:24:41 2008
@@ -18,7 +18,7 @@
 (defclass map-browser-handler (prefix-handler)
   ())
 
-(defun decode-coords-in-handler-path (handler req)
+(defun decode-coords-in-handler-path (handler)
   (labels ((ensure-valid-coordinates (x y)
 	     (setq x (parse-integer x))
 	     (setq y (parse-integer y))
@@ -30,30 +30,29 @@
 			  (<= 0 y 10800))
 	       (error "invalid coordinates ~A/~A" x y))
 	     (list x y)))
-    (with-query-params (req xcoord ycoord)
+    (with-query-params (xcoord ycoord)
       (when (and xcoord ycoord)
 	(return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord))))
-    (let ((handler-arguments (decoded-handler-path handler req)))
+    (let ((handler-arguments (decoded-handler-path handler)))
       (when (and handler-arguments
 		 (< 1 (length handler-arguments)))
 	(apply #'ensure-valid-coordinates handler-arguments)))))
 
-(defmethod handle ((handler map-browser-handler) req)
-  (with-query-params (req chosen-url)
+(defmethod handle ((handler map-browser-handler))
+  (with-query-params (chosen-url)
     (when chosen-url
       (setf (session-variable :chosen-url) chosen-url)))
-  (with-query-params (req view-x view-y)
-    (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string req)
-      (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler req)
-	(with-query-params (req action)
+  (with-query-params (view-x view-y)
+    (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string)
+      (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler)
+	(with-query-params (action)
 	  (when (equal action "save")
 	    (if (session-variable :chosen-url)
 		(redirect (format nil "~Ax=~D&y=~D"
 				  (session-variable :chosen-url)
 				  point-x
-				  point-y)
-			  req)
-		(with-bos-cms-page (req :title "Map Point Chooser")
+				  point-y))
+		(with-bos-cms-page (:title "Map Point Chooser")
 		  (html (:princ-safe "You chose " point-x " / " point-y))))
 	    (return-from handle t)))
 	(cond
@@ -71,14 +70,14 @@
 		  (click-coord-y (+ (tile-nw-y start-tile) click-y)))
 	      (setq point-x click-coord-x
 		    point-y click-coord-y)
-	      (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y) req)
+	      (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y))
 	      (return-from handle t)))
 	  (cond
 	    ((and click-y (not point-y))
-	     (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)) req))
+	     (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y))))
 	    (point-y
-	     (with-bos-cms-page (req :title "Map Point Chooser")
-	       (with-query-params (req heading)
+	     (with-bos-cms-page (:title "Map Point Chooser")
+	       (with-query-params (heading)
 		 (when heading
 		   (html (:h2 (:princ-safe heading)))))
 	       (html
@@ -133,7 +132,7 @@
 			  ((:img :src "/images/map-cursor.png")))))))
 	       (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
 	    (t
-	     (with-bos-cms-page (req :title "Map Point Chooser")
+	     (with-bos-cms-page (:title "Map Point Chooser")
 	       (html
 		((:a :href "/map-browser/")
 		 ((:img :ismap "ismap" :src "/image/sl_all"))))))))))))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -34,7 +34,7 @@
 	      (:tr (:td "Y:") (:td (text-field "ycoord" :size "5" :value y)))
 	      (:tr )))
 	    (:td
-	     (with-query-params (req background areas contracts)
+	     (with-query-params (background areas contracts)
 	       ;; xxx should use tile-layers
 	       (unless (or background areas contracts)
 		 (setq background t
@@ -52,15 +52,15 @@
 (defclass image-tile-handler (object-handler)
   ())
 
-(defmethod object-handler-get-object ((handler image-tile-handler) req)
-  (destructuring-bind (x y &rest operations) (decoded-handler-path handler req)
+(defmethod object-handler-get-object ((handler image-tile-handler))
+  (destructuring-bind (x y &rest operations) (decoded-handler-path handler)
     (declare (ignore operations))
     (setf x (parse-integer x))
     (setf y (parse-integer y))
     (ensure-map-tile x y)))
 
-(defmethod handle-object ((handler image-tile-handler) (tile (eql nil)) req)
-  (error-404 req))
+(defmethod handle-object ((handler image-tile-handler) (tile (eql nil)))
+  (error-404))
 
 (defun parse-operations (&rest operation-strings)
   (mapcar #'(lambda (operation-string)
@@ -68,32 +68,33 @@
 		(apply #'list (make-keyword-from-string operation) arguments)))
 	  operation-strings))
 
-(defmethod handle-object ((handler image-tile-handler) tile req)
-  ;; xxx parse url another time - the parse result of
-  ;; object-handler-get-object should really be kept in the request
-  (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler req)
-    (declare (ignore x y))
-    (let ((changed-time (image-tile-changed-time tile))
-	  (ims (header-slot-value req :if-modified-since)))
-      (setf (net.aserve::last-modified *ent*) changed-time)
-      #+(or)
-      (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims)
-      (if (or (not ims)
-	      (> changed-time (date-to-universal-time ims)))
-	  (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
-	    (emit-image-to-browser req image :png
-				   :date changed-time
-				   :max-age 60)
-	    (cl-gd:destroy-image image))
-	  (with-http-response (req *ent*)
-	    (with-http-body (req *ent*)
-	      ; do nothing
-	      ))))))
+;; trunk-reorg adaption
+;; (defmethod handle-object ((handler image-tile-handler) tile)
+;;   ;; xxx parse url another time - the parse result of
+;;   ;; object-handler-get-object should really be kept in the request
+;;   (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler)
+;;     (declare (ignore x y))
+;;     (let ((changed-time (image-tile-changed-time tile))
+;; 	  (ims (header-slot-value req :if-modified-since)))
+;;       (format t "Warning: not setting last-modified of *ent* to changed-time")
+;;       #+(or)
+;;       (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims)
+;;       (if (or (not ims)
+;; 	      (> changed-time (date-to-universal-time ims)))
+;; 	  (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
+;; 	    (emit-image-to-browser req image :png
+;; 				   :date changed-time
+;; 				   :max-age 60)
+;; 	    (cl-gd:destroy-image image))
+;; 	  (with-http-response (*ent*)
+;; 	    (with-http-body ()
+;; 	      ; do nothing
+;; 	      ))))))
 
 (defclass enlarge-tile-handler (image-tile-handler)
   ())
 
-(defun tile-active-layers-from-request-params (tile req)
+(defun tile-active-layers-from-request-params (tile)
   (let (active-layers
 	(all-layer-names (mapcar #'symbol-name (image-tile-layers tile))))
     (dolist (layer-name all-layer-names)
@@ -101,25 +102,27 @@
 	(push layer-name active-layers)))
     (or (reverse active-layers) all-layer-names)))
 
-(defun tile-url (tile x y req)
+(defun tile-url (tile x y)
   (format nil "/overview/~D/~D~(~{/~A~}~)"
 	  x y
-	  (tile-active-layers-from-request-params tile req)))
+	  (tile-active-layers-from-request-params tile)))
+
+;; trunk-reorg adaption
+;; (defmethod handle-object ((handler enlarge-tile-handler) tile)
+;;   (let ((ismap-coords (decode-ismap-query-string req))
+;; 	(tile-x (tile-nw-x tile))
+;; 	(tile-y (tile-nw-y tile)))
+;;     (if ismap-coords
+;; 	(let* ((x (+ (floor (first ismap-coords) 4) tile-x))
+;; 	       (y (+ (floor (second ismap-coords) 4) tile-y))
+;; 	       (m2 (get-m2 x y))
+;; 	       (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2)))))
+;; 	  (if contract-id
+;; 	      (redirect #?"/contract/$(contract-id)")
+;; 	      (with-bos-cms-page (:title "Not sold")
+;; 		(html (:h2 "this square meter has not been sold yet")))))
+;; 	(with-bos-cms-page (:title "Browsing tile")
+;; 	  (:a ((:a :href (uri-path (hunchentoot:request-uri)))
+;; 	       ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req)))))
+;; 	  (map-navigator req tile-x tile-y "/enlarge-overview/")))))
 
-(defmethod handle-object ((handler enlarge-tile-handler) tile req)
-  (let ((ismap-coords (decode-ismap-query-string req))
-	(tile-x (tile-nw-x tile))
-	(tile-y (tile-nw-y tile)))
-    (if ismap-coords
-	(let* ((x (+ (floor (first ismap-coords) 4) tile-x))
-	       (y (+ (floor (second ismap-coords) 4) tile-y))
-	       (m2 (get-m2 x y))
-	       (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2)))))
-	  (if contract-id
-	      (redirect #?"/contract/$(contract-id)" req)
-	      (with-bos-cms-page (req :title "Not sold")
-		(html (:h2 "this square meter has not been sold yet")))))
-	(with-bos-cms-page (req :title "Browsing tile")
-	  (:a ((:a :href (uri-path (request-uri req)))
-	       ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req)))))
-	  (map-navigator req tile-x tile-y "/enlarge-overview/")))))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/web/news-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/news-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/news-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -9,10 +9,10 @@
 (defclass edit-news-handler (editor-only-handler edit-object-handler)
   ())
 
-(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req)
+(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)))
   (let ((language (session-variable :language)))
-    (with-bos-cms-page (req :title "Edit news items")
-      (content-language-chooser req)
+    (with-bos-cms-page (:title "Edit news items")
+      (content-language-chooser)
       (:h2 "Create new item")
       ((:form :method "post")
        (submit-button "new" "new"))
@@ -29,13 +29,13 @@
 	  (html
 	   (:h2 "No news items created yet"))))))
 
-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req)
-  (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req))
+(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)))
+  (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item)))))
 
-(defmethod handle-object-form ((handler edit-news-handler) action news-item req)
+(defmethod handle-object-form ((handler edit-news-handler) action news-item)
   (let ((language (session-variable :language)))
-    (with-bos-cms-page (req :title "Edit news item")
-      (content-language-chooser req)
+    (with-bos-cms-page (:title "Edit news item")
+      (content-language-chooser)
       ((:script :type "text/javascript")
        "tinyMCE.init({ mode : 'textareas', theme : 'advanced' });")
       ((:form :method "post")
@@ -48,15 +48,15 @@
 				   :value (news-item-text news-item language))))
 	 (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?"))))))))
 
-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item req)
+(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item)
   (let ((language (session-variable :language)))
-    (with-query-params (req title text)
+    (with-query-params (title text)
       (update-news-item news-item language :title title :text text)
-      (with-bos-cms-page (req :title "News item updated")
+      (with-bos-cms-page (:title "News item updated")
 	(:h2 "Your changes have been saved")
 	"You may " (cmslink (edit-object-url news-item) "continue editing the news item")))))
 
-(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item req)
+(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item)
   (delete-object news-item)
-  (with-bos-cms-page (req :title "News item has been deleted")
+  (with-bos-cms-page (:title "News item has been deleted")
     (:h2 "The news item has been deleted")))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/web/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/packages.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/packages.lisp	Mon Feb 11 12:24:41 2008
@@ -8,8 +8,6 @@
 	:cl-user
 	:cl-interpol
 	:cl-ppcre
-	:net.aserve
-	:net.aserve.client
 	:xhtml-generator
 	:cxml
 	:puri
@@ -27,6 +25,5 @@
 	:bos.m2.config)
   (:nicknames :web :worldpay-test)
   (:shadowing-import-from :cl-interpol #:quote-meta-chars)
-  (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)
-  (:import-from :net.html.generator #:*html-stream*)
+  (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)  
   (:export))

Modified: branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/poi-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/poi-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -6,26 +6,26 @@
 (defclass make-poi-handler (page-handler)
   ())
   
-(defmethod handle ((handler make-poi-handler) req)
-  (with-query-params (req name)
+(defmethod handle ((handler make-poi-handler))
+  (with-query-params (name)
     (cond
       ((find-store-object name :class 'poi)
-       (with-bos-cms-page (req :title "Duplicate POI name")
+       (with-bos-cms-page (:title "Duplicate POI name")
 	 (html (:h2 "Duplicate POI name")
 	       "A POI with that name exists already, please choose a unique name")))
       ((not (scan #?r"(?i)^[a-z][-a-z0-9_]+$" name))
-       (with-bos-cms-page (req :title "Bad technical name")
+       (with-bos-cms-page (:title "Bad technical name")
 	 (html (:h2 "Bad technical name")
 	       "Please use only alphanumerical characters, - and _ for technical POI names")))
       (t
-       (redirect (edit-object-url (make-poi (session-variable :language) name)) req)))))
+       (redirect (edit-object-url (make-poi (session-variable :language) name)))))))
 
 (defclass edit-poi-handler (editor-only-handler edit-object-handler)
   ()
   (:default-initargs :object-class 'poi :query-function #'find-poi))
 
-(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)) req)
-  (with-bos-cms-page (req :title "Choose POI")
+(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)))
+  (with-bos-cms-page (:title "Choose POI")
     (if (store-objects-with-class 'poi)
 	(html
 	 (:h2 "Choose a POI to edit")
@@ -50,8 +50,8 @@
     (html ((:img :src #?"/images/$(icon).gif")))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
-			       action (poi poi) req)
-  (with-query-params (req language shift shift-by)
+			       action (poi poi))
+  (with-query-params (language shift shift-by)
     (unless language (setq language (session-variable :language)))
     (when shift
       ;; change image order
@@ -66,8 +66,8 @@
 	(setf (nth (+ shift-by old-position) new-images) tmp)
 	(change-slot-values poi 'bos.m2::images new-images)))
     (setf (session-variable :language) language)
-    (with-bos-cms-page (req :title "Edit POI")
-      (content-language-chooser req)
+    (with-bos-cms-page (:title "Edit POI")
+      (content-language-chooser)
       (unless (poi-complete poi language)
 	(html (:h2 "This POI is not complete in the current language - Please check that "
 		   "the location and all text fields are set and that at least one image "
@@ -95,11 +95,11 @@
 		     (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi)))))
 		     (cmslink (format nil "map-browser/~A/~A?chosen-url=~A"
 				      (first (poi-area poi)) (second (poi-area poi))
-				      (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req)))))
+				      (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri)))))
 		       "[relocate]"))
 		    (t
 		     (cmslink (format nil "map-browser/?chosen-url=~A"
-				      (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req)))))
+				      (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri)))))
 		       "[choose]")))))
 	(:tr (:td "icon")
 	     (:td (icon-chooser "icon" (poi-icon poi))))
@@ -167,8 +167,8 @@
 		  (submit-button "delete" "delete" :confirm "Really delete the POI?"))))))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
-			       (action (eql :save)) (poi poi) req)
-  (with-query-params (req published title subtitle description language x y icon movie)
+			       (action (eql :save)) (poi poi))
+  (with-query-params (published title subtitle description language x y icon movie)
     (unless language (setq language (session-variable :language)))
     (let ((args (list :title title
 		      :published published
@@ -180,21 +180,20 @@
       (when movie
 	(setq args (append args (list :movies (list movie)))))
       (apply #'update-poi poi language args))
-    (with-bos-cms-page (req :title "POI has been updated")
+    (with-bos-cms-page (:title "POI has been updated")
       (html (:h2 "Your changes have been saved")
 	    "You may " (cmslink (edit-object-url poi) "continue editing the POI") "."))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :upload-airal))
-			       (poi poi)
-			       req)
-  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car))))
+			       (poi poi))
+  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))))
     (unless uploaded-file
       (error "no file uploaded in upload handler"))
     (cl-gd:with-image-from-file* (uploaded-file)
       (unless (and (eql (cl-gd:image-width) *poi-image-width*)
 		   (eql (cl-gd:image-height) *poi-image-height*))
-	(with-bos-cms-page (req :title "Invalid image size")
+	(with-bos-cms-page (:title "Invalid image size")
 	  (:h2 "Invalid image size")
 	  (:p "The image needs to be "
 	      (:princ-safe *poi-image-width*) " pixels wide and "
@@ -207,30 +206,27 @@
     (change-slot-values poi 'airals (list (import-image uploaded-file
 							:class-name 'store-image))))
   (redirect (format nil "/edit-poi/~D"
-		    (store-object-id poi)) req))
+		    (store-object-id poi))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :delete-airal))
-			       (poi poi)
-			       req)
+			       (poi poi))
   (let ((airals (poi-airals poi)))
     (change-slot-values poi 'airals nil)
     (mapc #'delete-object airals))
   (redirect (format nil "/edit-poi/~D"
-		    (store-object-id poi)) req))
+		    (store-object-id poi))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :delete-movie))
-			       (poi poi)
-			       req)
+			       (poi poi))
   (change-slot-values poi 'movies nil)
-  (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req))
+  (redirect (format nil "/edit-poi/~D" (store-object-id poi))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :upload-panorama))
-			       (poi poi)
-			       req)
-  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car))))
+			       (poi poi))
+  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))))
     (unless uploaded-file
       (error "no file uploaded in upload handler"))
     (cl-gd:with-image-from-file* (uploaded-file)
@@ -240,23 +236,22 @@
 							   :class-name 'store-image)
 					     (poi-panoramas poi))))
   (redirect (format nil "/edit-poi/~D"
-		    (store-object-id poi)) req))
+		    (store-object-id poi))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :delete-panorama))
-			       (poi poi)
-			       req)
-  (with-query-params (req panorama-id)
+			       (poi poi))
+  (with-query-params (panorama-id)
     (let ((panorama (find-store-object (parse-integer panorama-id))))
       (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi)))
       (mapc #'delete-object panorama)))
   (redirect (format nil "/edit-poi/~D"
-		    (store-object-id poi)) req))
+		    (store-object-id poi))))
 
 (defmethod handle-object-form ((handler edit-poi-handler)
-			       (action (eql :delete)) (poi poi) req)
+			       (action (eql :delete)) (poi poi))
   (delete-object poi)
-  (with-bos-cms-page (req :title "POI has been deleted")
+  (with-bos-cms-page (:title "POI has been deleted")
     (html (:h2 "POI has been deleted")
 	  "The POI has been deleted")))
 
@@ -266,9 +261,9 @@
   ()
   (:default-initargs :object-class 'poi-image))
 
-(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)) req)
-  (with-query-params (req poi)
-    (with-bos-cms-page (req :title "Upload new POI image")
+(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)))
+  (with-query-params (poi)
+    (with-bos-cms-page (:title "Upload new POI image")
       (html
        (:h2 "Upload new image")
        ((:form :method "POST" :enctype "multipart/form-data"))
@@ -276,16 +271,16 @@
        (:p "Choose a file: " ((:input :type "file" :name "image-file")))
        (:p (submit-button "upload" "upload"))))))
 
-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image req)
-  (with-query-params (req poi)
+(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image)
+  (with-query-params (poi)
     (setq poi (find-store-object (parse-integer poi) :class 'poi))
-    (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car))))
+    (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car))))
       (unless uploaded-file
 	(error "no file uploaded in upload handler"))
       (cl-gd:with-image-from-file* (uploaded-file)
 	(unless (and (eql (cl-gd:image-width) *poi-image-width*)
 		     (eql (cl-gd:image-height) *poi-image-height*))
-	  (with-bos-cms-page (req :title "Invalid image size")
+	  (with-bos-cms-page (:title "Invalid image size")
 	    (:h2 "Invalid image size")
 	    (:p "The image needs to be "
 		(:princ-safe *poi-image-width*) " pixels wide and "
@@ -302,15 +297,15 @@
 					:initargs `(:poi ,poi))))
       (redirect (format nil "/edit-poi-image/~D?poi=~D"
 			(store-object-id poi-image)
-			(store-object-id poi)) req))))
+			(store-object-id poi))))))
 
-(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image req)
-  (with-query-params (req language poi)
+(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image)
+  (with-query-params (language poi)
     (unless language (setq language (session-variable :language)))
-    (with-bos-cms-page (req :title "Edit POI Image")
+    (with-bos-cms-page (:title "Edit POI Image")
       (html
        (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI")
-       (content-language-chooser req)
+       (content-language-chooser)
        ((:form :method "post" :enctype "multipart/form-data")
 	((:input :type "hidden" :name "poi" :value poi))
 	(:table (:tr (:td "thumbnail")
@@ -334,21 +329,21 @@
 				    :cols 40)))
 	  (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the image?")))))))))
 
-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image req)
-  (with-query-params (req title subtitle description language)
+(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image)
+  (with-query-params (title subtitle description language)
     (unless language (setq language (session-variable :language)))
     (update-poi-image poi-image language
 		      :title title
 		      :subtitle subtitle
 		      :description description)
-    (with-bos-cms-page (req :title "POI image has been updated")
+    (with-bos-cms-page (:title "POI image has been updated")
       (:h2 "The POI image information has been updated")
       "You may " (cmslink (edit-object-url poi-image) "continue editing the POI image"))))
 
-(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image req)
+(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image)
   (let ((poi (poi-image-poi poi-image)))
     (delete-object poi-image)
-    (with-bos-cms-page (req :title "POI image has been deleted")
+    (with-bos-cms-page (:title "POI image has been deleted")
       (:h2 "The POI image has been deleted")
       "You may " (cmslink (edit-object-url poi) "continue editing the POI"))))
 
@@ -363,12 +358,12 @@
 	  (sponsor-country (contract-sponsor contract))
 	  (length (contract-m2s contract))))
 
-(defmethod handle ((handler poi-javascript-handler) req)
-  (with-bknr-http-response (req :content-type "text/html; charset=UTF-8")
-    (setf (reply-header-slot-value req :cache-control) "no-cache")
-      (setf (reply-header-slot-value req :pragma) "no-cache")
-      (setf (reply-header-slot-value req :expires) "-1")
-      (with-http-body (req *ent*)
+(defmethod handle ((handler poi-javascript-handler))
+  (with-http-response (:content-type "text/html; charset=UTF-8")
+    (setf (hunchentoot:header-out :cache-control) "no-cache")
+      (setf (hunchentoot:header-out :pragma) "no-cache")
+      (setf (hunchentoot:header-out :expires) "-1")
+      (with-http-body ()
 	(let ((*standard-output* *html-stream*))
 	  (princ "<script language=\"JavaScript\">") (terpri)
 	  (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri)
@@ -380,18 +375,17 @@
   ()
   (:default-initargs :object-class 'poi :query-function #'find-poi))
 
-(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)) req)
+(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)))
   (error "poi not found"))
 
-(defmethod handle-object ((handler poi-image-handler) poi req)
-  (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler req))
+(defmethod handle-object ((handler poi-image-handler) poi)
+  (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler))
     (declare (ignore poi-name))
     (let ((image-index (1- (parse-integer image-index-string))))
       (if (and (not (minusp image-index))
 	       (< image-index (length (poi-images poi))))
 	  (redirect (format nil "/image/~D~@[~{/~a~}~]"
 			    (store-object-id (nth image-index (poi-images poi)))
-			    imageproc-arguments)
-		    req)
+			    imageproc-arguments))
 	  (error "image index ~a out of bounds for poi ~a" image-index poi)))))
 

Modified: branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp	Mon Feb 11 12:24:41 2008
@@ -21,7 +21,7 @@
 
 (defmethod handle ((handler reports-xml-handler) req)
   (with-xml-response ()
-    (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req)
+    (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler)
       (setf *year* (and *year* (parse-integer *year*)))
       (let ((*contracts-to-process* (sort (remove-if (lambda (contract)
 						       (or (not (contract-paidp contract))

Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	Mon Feb 11 12:24:41 2008
@@ -6,14 +6,14 @@
 (defclass search-sponsors-handler (editor-only-handler form-handler)
   ())
 
-(defmethod handle-form ((handler search-sponsors-handler) action req)
-  (with-bos-cms-page (req :title "Search for sponsor")))
+(defmethod handle-form ((handler search-sponsors-handler) action)
+  (with-bos-cms-page (:title "Search for sponsor")))
 
 (defclass edit-sponsor-handler (editor-only-handler edit-object-handler)
   ())
 
-(defmethod object-handler-get-object ((handler edit-sponsor-handler) req)
-  (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler req)))))))
+(defmethod object-handler-get-object ((handler edit-sponsor-handler))
+  (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler)))))))
     (typecase object
       (sponsor object)
       (contract (contract-sponsor object))
@@ -36,17 +36,17 @@
 (defmethod language-selector ((contract contract))
   (language-selector (contract-sponsor contract)))
 
-(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)) req)
-  (with-query-params (req id key count)
+(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)))
+  (with-query-params (id key count)
     (when id
-      (redirect #?"/edit-sponsor/$(id)" req)
+      (redirect #?"/edit-sponsor/$(id)")
       (return-from handle-object-form))
     (when (or key count)
       (let ((regex (format nil "(?i)~A" key))
 	    (found 0))
 	(when count
 	  (setf count (parse-integer count)))
-	(with-bos-cms-page (req :title "Sponsor search results")
+	(with-bos-cms-page (:title "Sponsor search results")
 	  ((:table :border "1")
 	   (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Country") (:th "Cert-Type") (:th "Paid by"))
 	   (dolist (sponsor (sort (remove-if-not #'sponsor-contracts (class-instances 'sponsor))
@@ -67,7 +67,7 @@
 		 (return))))
 	   (:tr ((:th :colspan "7") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found"))))))))
       (return-from handle-object-form)))
-  (with-bos-cms-page (req :title "Find or Create Sponsor")
+  (with-bos-cms-page (:title "Find or Create Sponsor")
     (html
      ((:form :name "form")
       ((:table)
@@ -106,23 +106,23 @@
 (defun date-to-universal (date-string)
   (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string))))
 
-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req)
-  (with-query-params (req numsqm country email name address date language)
+(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)))
+  (with-query-params (numsqm country email name address date language)
     (let* ((sponsor (make-sponsor :email email :country country :language language))
 	   (contract (make-contract sponsor (parse-integer numsqm)
 				    :paidp (format nil "~A: manually created by ~A"
 						   (format-date-time (get-universal-time))
-						   (user-login (bknr-request-user req)))
+						   (user-login bknr.web:*user*))
 				    :date (date-to-universal date))))
       (contract-issue-cert contract name :address address :language language)
-      (mail-backoffice-sponsor-data contract req)
-      (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req))))
+      (mail-backoffice-sponsor-data contract)
+      (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor))))))
 
 (defun contract-checkbox-name (contract)
   (format nil "contract-~D-paid" (store-object-id contract)))
 
-(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor req)
-  (with-bos-cms-page (req :title "Edit Sponsor")
+(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor)
+  (with-bos-cms-page (:title "Edit Sponsor")
     (html
      ((:form :method "post")
       (:h2 "Sponsor Data")
@@ -174,9 +174,9 @@
       (:p (submit-button "save" "save")
 	  (submit-button "delete" "delete" :confirm "Really delete this sponsor?"))))))
 
-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor req)
+(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor)
   (let (changed)
-    (with-bos-cms-page (req :title "Saving sponsor data")
+    (with-bos-cms-page (:title "Saving sponsor data")
       (dolist (field-name '(full-name email password country language info-text))
 	(let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
@@ -192,11 +192,11 @@
 	  (html (:p "Changed contract status to \"paid\""))))
       (unless changed
 	(html (:p "No changes have been made")))
-      (html (cmslink (uri-path (request-uri req))
+      (html (cmslink (uri-path (hunchentoot:request-uri))
 	      "Return to sponsor profile")))))
 
-(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor req)
-  (with-bos-cms-page (req :title "Sponsor deleted")
+(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor)
+  (with-bos-cms-page (:title "Sponsor deleted")
     (delete-object sponsor)
     (html (:p "The sponsor has been deleted"))))
 
@@ -204,17 +204,16 @@
   ()
   (:default-initargs :object-class 'contract))
 
-(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)) req)
-  (with-bos-cms-page (req :title "Invalid contract ID")
+(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)))
+  (with-bos-cms-page (:title "Invalid contract ID")
     (html "Invalid contract ID, maybe the sponsor or the contract has been deleted")))
 
-(defmethod handle-object-form ((handler complete-transfer-handler) action contract req)
+(defmethod handle-object-form ((handler complete-transfer-handler) action contract)
   (if (contract-paidp contract)
-      (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract)))
-		req)
+      (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))))
       (let ((numsqm (length (contract-m2s contract))))
-	(with-query-params (req email)
-	  (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment")
+	(with-query-params (email)
+	  (with-bos-cms-page (:title "Complete square meter sale with wire transfer payment")
 	    (html
 	     ((:form :name "form")
 	      ((:input :type "hidden" :name "numsqm" :value #?"$(numsqm)"))
@@ -231,16 +230,16 @@
 		    (:td (text-field "email" :size 20 :value email)))
 	       (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()")))))))))))
 
-(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req)
-  (with-query-params (req email country)
-    (with-bos-cms-page (req :title "Square meter sale completion")
+(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract)
+  (with-query-params (email country)
+    (with-bos-cms-page (:title "Square meter sale completion")
       (if (contract-paidp contract)
 	  (html (:h2 "This sale has already been completed"))
 	  (progn
 	    (html (:h2 "Completing square meter sale"))
 	    (sponsor-set-country (contract-sponsor contract) country)
 	    (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A"
-						 (format-date-time) (user-login (bknr-request-user req))))
+						 (format-date-time) (user-login bknr.web:*user*)))
 	    (when email
 	      (html (:p "Sending instruction email to " (:princ-safe email)))
 	      (mail-instructions-to-sponsor contract email))))
@@ -260,10 +259,10 @@
 		     (sponsor-id-or-x
 		      (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor))
 		     (t
-		      (when (eq (find-class 'sponsor) (class-of (bknr-request-user req)))
-			(bknr-request-user req))))))
-      (with-bknr-http-response (req :content-type "text/html; charset=UTF-8")
-	(with-http-body (req *ent*)
+		      (when (eq (find-class 'sponsor) (class-of bknr.web:*user*))
+			bknr.web:*user*)))))
+      (with-http-response (:content-type "text/html; charset=UTF-8")
+	(with-http-body ()
 	  (let ((*standard-output* *html-stream*))
 	    (princ "<script language=\"JavaScript\">") (terpri)
 	    (princ "var profil;") (terpri)
@@ -275,16 +274,16 @@
 (defclass sponsor-login-handler (page-handler)
   ())
 
-(defmethod handle ((handler sponsor-login-handler) req)
-  (with-query-params (req __sponsorid)
-    (with-bknr-http-response (req :content-type "text/html")
-      (setf (reply-header-slot-value req :cache-control) "no-cache")
-      (setf (reply-header-slot-value req :pragma) "no-cache")
-      (setf (reply-header-slot-value req :expires) "-1")
-      (with-http-body (req *ent*)
+(defmethod handle ((handler sponsor-login-handler))
+  (with-query-params (__sponsorid)
+    (with-http-response (:content-type "text/html")
+      (setf (hunchentoot:header-out :cache-control) "no-cache")
+      (setf (hunchentoot:header-out :pragma) "no-cache")
+      (setf (hunchentoot:header-out :expires) "-1")
+      (with-http-body ()
 	(format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%"
 		(cond
-		  ((eq (find-class 'sponsor) (class-of (bknr-request-user req)))
+		  ((eq (find-class 'sponsor) (class-of bknr.web:*user*))
 		   "logged-in")
 		  (__sponsorid
 		   "login-failed")
@@ -295,8 +294,8 @@
   ()
   (:default-initargs :class 'contract))
 
-(defmethod object-handler-get-object ((handler cert-regen-handler) req)
-  (let* ((object-id-string (first (decoded-handler-path handler req)))
+(defmethod object-handler-get-object ((handler cert-regen-handler))
+  (let* ((object-id-string (first (decoded-handler-path handler)))
 	 (object (store-object-with-id (parse-integer object-id-string))))
     (cond
       ((contract-p object)
@@ -305,8 +304,8 @@
        (first (sponsor-contracts object)))
       (t (error "invalid sponsor or contract id ~A" object-id-string)))))
 
-(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract) req)
-  (with-bos-cms-page (req :title (format nil "Re-generate Certificate~@[~*s~]"
+(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract))
+  (with-bos-cms-page (:title (format nil "Re-generate Certificate~@[~*s~]"
 					 (not (contract-download-only-p contract))))
     (html
      ((:form :name "form")
@@ -322,10 +321,10 @@
        (html
         (:tr (:td (submit-button "regenerate" "regenerate")))))))))
 
-(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req)
-  (with-query-params (req name address language)
+(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract))
+  (with-query-params (name address language)
     (contract-issue-cert contract name :address address :language language))
-  (with-bos-cms-page (req :title "Certificate has been recreated")
+  (with-bos-cms-page (:title "Certificate has been recreated")
     (html "The certificates for the sponsor have been re-generated." :br)
     (unless (contract-download-only-p contract)
       (mail-print-pdf contract)

Modified: branches/trunk-reorg/projects/bos/web/web-macros.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/web-macros.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/web-macros.lisp	Mon Feb 11 12:24:41 2008
@@ -2,26 +2,25 @@
 
 (enable-interpol-syntax)
 
-(defmacro with-bos-cms-page ((req &key title response) &rest body)
-  `(with-bknr-page (,req :title ,title :response ,response)
+(defmacro with-bos-cms-page ((&key title response) &rest body)
+  `(with-bknr-page (:title ,title :response ,response)
     , at body))
 
 (defvar *xml-sink*)
 
 (defmacro with-xml-response ((&key (content-type "text/xml") (root-element "response")) &body body)
-  `(with-http-response (*req* *ent* :content-type ,content-type)
-     (with-query-params (*req* download)
+  `(with-http-response (:content-type ,content-type)
+     (with-query-params (download)
        (when download
-	 (setf (reply-header-slot-value *req* :content-disposition)
-	       (format nil "attachment; filename=~A" download))))
-     (with-http-body (*req* *ent*)
-       (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil)))
+	 (setf (hunchentoot:header-out :content-disposition)
+               (format nil "attachment; filename=~A" download))))
+     (with-http-body ()
+       (let ((*xml-sink* (make-character-stream-sink xhtml-generator:*html-sink* :canonical nil)))
 	 (with-xml-output *xml-sink*
 	   (with-element ,root-element
 	     , at body))))))
 
-(defmacro with-xml-error-handler (req &body body)
-  (declare (ignore req))
+(defmacro with-xml-error-handler (() &body body)
   `(handler-case
     (progn , at body)
     (error (e)
@@ -29,3 +28,5 @@
        (with-element "status"
 	 (attribute "failure" 1)
 	 (text (princ-to-string e)))))))
+
+

Modified: branches/trunk-reorg/projects/bos/web/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/web-utils.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/web-utils.lisp	Mon Feb 11 12:24:41 2008
@@ -46,20 +46,20 @@
     (setf (session-variable :language) *default-language*))
   (session-variable :language))
 
-(defun content-language-chooser (req)
+(defun content-language-chooser ()
   (html
    ((:p :class "languages")
     "Content languages: "
     (loop for (language-symbol language-name) in (website-languages)
 	  do (labels ((show-language-link ()
-			(html (cmslink (format nil "~A?language=~A" (uri-path (request-uri req)) language-symbol)
+			(html (cmslink (format nil "~A?language=~A" (uri-path (hunchentoot:request-uri)) language-symbol)
 				(:princ-safe language-name)))))
 	       (if (equal (session-variable :language) language-symbol)
 		   (html "[" (show-language-link) "]")
 		   (html (show-language-link)))
 	       (html " "))))))
 
-(defun decode-ismap-query-string (req)
+(defun decode-ismap-query-string ()
   (let ((coord-string (caar (request-query req))))
     (when (and coord-string (scan #?r"^\d*,\d*$" coord-string))
       (mapcar #'parse-integer (split "," coord-string)))))

Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp	Mon Feb 11 12:24:41 2008
@@ -53,7 +53,7 @@
 				     "index" template-name)))))
   (call-next-method handler template-name))
 
-(defmethod initial-template-environment ((expander worldpay-template-handler) req)
+(defmethod initial-template-environment ((expander worldpay-template-handler))
   (append (list (cons :website-url *website-url*))
 	  (call-next-method)))
 
@@ -74,7 +74,7 @@
 			(when (website-supports-language language)
 			  language)))
 
-(defun find-browser-prefered-language (req)
+(defun find-browser-prefered-language ()
   "Determine the language prefered by the user, as determined by the Accept-Language header
 present in the HTTP request.  Header decoding is done according to RFC2616, considering individual
 language preference weights."
@@ -99,42 +99,41 @@
 (defclass index-handler (page-handler)
   ())
 
-(defmethod handle ((handler index-handler) req)
-  (redirect (format nil "/~A/index" (or (find-browser-prefered-language req)
+(defmethod handle ((handler index-handler))
+  (redirect (format nil "/~A/index" (or (find-browser-prefered-language)
 					*default-language*))
-	    req
-	    *response-moved-permanently*))
+	    :permanently *response-moved-permanently*))
 
 (defclass infosystem-handler (page-handler)
   ())
 
-(defmethod handle ((handler infosystem-handler) req)
+(defmethod handle ((handler infosystem-handler))
   ;; XXX hier logout-parameter implementieren
-  (with-query-params (req logout)
+  (with-query-params (logout)
     (when logout
-      (bknr.web::drop-session (bknr-request-session req))))
+      (bknr.web::drop-session *session*)))
   (let ((language (session-variable :language)))
-    (redirect #?"/infosystem/$(language)/satellitenkarte.htm" req)))
+    (redirect #?"/infosystem/$(language)/satellitenkarte.htm")))
 
 (defclass certificate-handler (object-handler)
   ()
   (:default-initargs :class 'contract))
 
-(defmethod handle-object ((handler certificate-handler) contract req)
+(defmethod handle-object ((handler certificate-handler) contract)
   (unless contract
-    (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req)))))
-  (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req))
+    (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts bknr.web:*user*))))
+  (redirect (format nil "/certificates/~D.pdf" (store-object-id contract))))
 
 (defclass statistics-handler (editor-only-handler prefix-handler)
   ())
 
-(defmethod handle ((handler statistics-handler) req)
+(defmethod handle ((handler statistics-handler))
   (let ((stats-name (parse-url req)))
     (cond
       (stats-name
-       (redirect (format nil "~A.svg" stats-name) req))
+       (redirect (format nil "~A.svg" stats-name)))
       (t
-       (with-bos-cms-page (req :title "Statistics browser")
+       (with-bos-cms-page (:title "Statistics browser")
 	 (:p
 	  ((:select :id "selector" :onchange "return statistic_selected()")
 	   (dolist (file (directory (merge-pathnames #p"images/statistics/*.svg" *website-directory*)))
@@ -146,15 +145,15 @@
 (defclass admin-handler (editor-only-handler page-handler)
   ())
 
-(defmethod handle ((handler admin-handler) req)
-  (with-bos-cms-page (req :title "CMS and Administration")
+(defmethod handle ((handler admin-handler))
+  (with-bos-cms-page (:title "CMS and Administration")
     "Please choose an administration activity from the menu above"))
 
 (defclass bos-authorizer (bknr-authorizer)
   ())
 
-(defmethod find-user-from-request-parameters ((authorizer bos-authorizer) req)
-  (with-query-params (req __sponsorid __password)
+(defmethod find-user-from-request-parameters ((authorizer bos-authorizer))
+  (with-query-params (__sponsorid __password)
     (if (and __sponsorid __password)
 	(handler-case
 	    (let ((sponsor (find-store-object (parse-integer __sponsorid) :class 'sponsor)))
@@ -172,13 +171,13 @@
 (defmethod authorize :after ((authorizer bos-authorizer)
 			     (req http-request)
 			     (ent net.aserve::entity))
-  (let ((new-language (or (language-from-url (uri-path (request-uri req)))
+  (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
 			  (query-param req "language")))
-	(current-language (gethash :language (bknr-session-variables (bknr-request-session req)))))
+	(current-language (gethash :language (bknr-session-variables *session*))))
     (when (or (not current-language)
 	      (and new-language
 		   (not (equal new-language current-language))))
-      (setf (gethash :language (bknr-session-variables (bknr-request-session req)))
+      (setf (gethash :language (bknr-session-variables *session*))
 	    (or new-language
 		(find-browser-prefered-language req)
 		*default-language*)))))


From ksprotte at common-lisp.net  Tue Feb 12 12:18:12 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 12 Feb 2008 07:18:12 -0500 (EST)
Subject: [bknr-cvs] r2480 - branches/trunk-reorg/xhtmlgen
Message-ID: <20080212121812.8546716042@common-lisp.net>

Author: ksprotte
Date: Tue Feb 12 07:18:11 2008
New Revision: 2480

Modified:
   branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
Log:
it seems that a rune is a character nowadays


Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
==============================================================================
--- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	(original)
+++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	Tue Feb 12 07:18:11 2008
@@ -131,7 +131,7 @@
   ;; das ist fuer WPDISPLAY
   (let ((s (cxml::chained-handler *html-sink*)))
     (cxml::maybe-close-tag s)
-    (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str)))
+    (map nil (lambda (c) (cxml::write-rune c s)) str)))
 
 (defun princ-http (val)
   #+(or)


From ksprotte at common-lisp.net  Tue Feb 12 12:19:26 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 12 Feb 2008 07:19:26 -0500 (EST)
Subject: [bknr-cvs] r2481 - branches/trunk-reorg/projects/bos/web
Message-ID: <20080212121926.60DA15E006@common-lisp.net>

Author: ksprotte
Date: Tue Feb 12 07:19:24 2008
New Revision: 2481

Modified:
   branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
   branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
   branches/trunk-reorg/projects/bos/web/map-handlers.lisp
   branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
   branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
   branches/trunk-reorg/projects/bos/web/startup.lisp
   branches/trunk-reorg/projects/bos/web/webserver.lisp
Log:
bos trunk-reorg compiles for the first time


Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	Tue Feb 12 07:19:24 2008
@@ -123,7 +123,7 @@
 		       do (incf dest-x copy-width))
 	      do (incf dest-y copy-height))
 	(cl-gd:draw-polygon vertices :color (elt colors 1))
-	(emit-image-to-browser req cl-gd:*default-image* :png)))))
+	(emit-image-to-browser cl-gd:*default-image* :png)))))
 
 (defclass create-allocation-area-handler (admin-only-handler form-handler)
   ())

Modified: branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp	Tue Feb 12 07:19:24 2008
@@ -7,7 +7,7 @@
   ()
   (:default-initargs :class 'contract))
 
-(defmethod handle-object ((handler contract-image-handler) contract req)
+(defmethod handle-object ((handler contract-image-handler) contract)
   "Create and return a GD image of the contract.  The returned
 rectangular image will have the size of the contracts' bounding box.
 All square meters will have yellow color, the background will be transparent."
@@ -27,4 +27,4 @@
 	  (cl-gd:do-rows (y)
 	    (cl-gd:do-pixels-in-row (x)
 	      (setf (cl-gd:raw-pixel) (aref work-array x y)))))
-	(emit-image-to-browser req cl-gd:*default-image* :png :cache-sticky t))))
\ No newline at end of file
+	(emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t))))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp	Tue Feb 12 07:19:24 2008
@@ -82,7 +82,7 @@
 ;;       (if (or (not ims)
 ;; 	      (> changed-time (date-to-universal-time ims)))
 ;; 	  (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
-;; 	    (emit-image-to-browser req image :png
+;; 	    (emit-image-to-browser image :png
 ;; 				   :date changed-time
 ;; 				   :max-age 60)
 ;; 	    (cl-gd:destroy-image image))
@@ -98,7 +98,7 @@
   (let (active-layers
 	(all-layer-names (mapcar #'symbol-name (image-tile-layers tile))))
     (dolist (layer-name all-layer-names)
-      (when (query-param req layer-name)
+      (when (query-param layer-name)
 	(push layer-name active-layers)))
     (or (reverse active-layers) all-layer-names)))
 

Modified: branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp	Tue Feb 12 07:19:24 2008
@@ -19,7 +19,7 @@
     (declare (ignore second minute hour date month day-of-week is-dst tz))
     year))
 
-(defmethod handle ((handler reports-xml-handler) req)
+(defmethod handle ((handler reports-xml-handler))
   (with-xml-response ()
     (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler)
       (setf *year* (and *year* (parse-integer *year*)))

Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	Tue Feb 12 07:19:24 2008
@@ -178,14 +178,14 @@
   (let (changed)
     (with-bos-cms-page (:title "Saving sponsor data")
       (dolist (field-name '(full-name email password country language info-text))
-	(let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
+	(let ((field-value (query-param (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
 		     (not (equal field-value (slot-value sponsor field-name))))
 	    (change-slot-values sponsor field-name field-value)
 	    (setf changed t)
 	    (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
       (dolist (contract (sponsor-contracts sponsor))
-	(when (and (query-param req (contract-checkbox-name contract))
+	(when (and (query-param (contract-checkbox-name contract))
 		   (not (contract-paidp contract)))
 	  (change-slot-values contract 'paidp t)
 	  (setf changed t)
@@ -249,8 +249,8 @@
 (defclass m2-javascript-handler (prefix-handler)
   ())
 
-(defmethod handle ((handler m2-javascript-handler) req)
-  (multiple-value-bind (sponsor-id-or-x y) (parse-url req)
+(defmethod handle ((handler m2-javascript-handler))
+  (multiple-value-bind (sponsor-id-or-x y) (parse-url)
     (let ((sponsor (cond
 		     (y
 		      (let ((m2 (get-m2 (parse-integer sponsor-id-or-x) (parse-integer y))))

Modified: branches/trunk-reorg/projects/bos/web/startup.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/startup.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/startup.lisp	Tue Feb 12 07:19:24 2008
@@ -42,10 +42,6 @@
 			    :website-url *website-url*
 			    :worldpay-test-mode *worldpay-test-mode*)
   (format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
-  (force-output)
-  (setq *webserver*
-	(if debug
-	    (progn (net.aserve::debug-on :notrap)
-		   (net.aserve:start :port *port* :listeners 0))
-	    (progn (net.aserve::debug-off :all)
-		   (net.aserve:start :port *port* :listeners *listeners*)))))
+  (force-output)  
+  (setq hunchentoot:*catch-errors-p* (not debug))
+  (hunchentoot:start-server :port *port*))

Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp	Tue Feb 12 07:19:24 2008
@@ -22,13 +22,13 @@
 ;; If the requested URL is /handle-sale, we do the sales processing
 ;; and change the template name according to the outcome.
 
-(defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request)
+(defmethod find-template-pathname ((Handler worldpay-template-handler) template-name)
   (cond
     ((scan #?r"(^|.*/)handle-sale" template-name)
-     (with-query-params (request cartId name address country transStatus lang MC_gift)      
+     (with-query-params (cartId name address country transStatus lang MC_gift)      
        (unless (website-supports-language lang)
 	 (setf lang *default-language*))
-       (bos.m2::remember-worldpay-params cartId (all-request-params request))
+       (bos.m2::remember-worldpay-params cartId (all-request-params))
        (let ((contract (get-contract (parse-integer cartId))))
 	 (sponsor-set-language (contract-sponsor contract) lang)
 	 (cond
@@ -128,7 +128,7 @@
   ())
 
 (defmethod handle ((handler statistics-handler))
-  (let ((stats-name (parse-url req)))
+  (let ((stats-name (parse-url)))
     (cond
       (stats-name
        (redirect (format nil "~A.svg" stats-name)))
@@ -168,19 +168,20 @@
 	    (call-next-method)))
 	(call-next-method))))
 
-(defmethod authorize :after ((authorizer bos-authorizer)
-			     (req http-request)
-			     (ent net.aserve::entity))
-  (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
-			  (query-param req "language")))
-	(current-language (gethash :language (bknr-session-variables *session*))))
-    (when (or (not current-language)
-	      (and new-language
-		   (not (equal new-language current-language))))
-      (setf (gethash :language (bknr-session-variables *session*))
-	    (or new-language
-		(find-browser-prefered-language req)
-		*default-language*)))))
+;; trunk-reorg adaption
+;; (defmethod authorize :after ((authorizer bos-authorizer)
+;; 			     (req http-request)
+;; 			     (ent net.aserve::entity))
+;;   (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
+;; 			  (query-param "language")))
+;; 	(current-language (gethash :language (bknr-session-variables *session*))))
+;;     (when (or (not current-language)
+;; 	      (and new-language
+;; 		   (not (equal new-language current-language))))
+;;       (setf (gethash :language (bknr-session-variables *session*))
+;; 	    (or new-language
+;; 		(find-browser-prefered-language req)
+;; 		*default-language*)))))
 
 (defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
   (setf *website-directory* website-directory)


From dverna at common-lisp.net  Tue Feb 12 14:13:33 2008
From: dverna at common-lisp.net (dverna at common-lisp.net)
Date: Tue, 12 Feb 2008 09:13:33 -0500 (EST)
Subject: [bknr-cvs] r2482 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080212141333.79ED65D162@common-lisp.net>

Author: dverna
Date: Tue Feb 12 09:13:32 2008
New Revision: 2482

Modified:
   trunk/projects/lisp-ecoop/website/templates/home.xml
   trunk/projects/lisp-ecoop/website/templates/programme.xml
   trunk/projects/lisp-ecoop/website/templates/submissions.xml
Log:
Updated the deadlines

Modified: trunk/projects/lisp-ecoop/website/templates/home.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/home.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/home.xml	Tue Feb 12 09:13:32 2008
@@ -27,9 +27,9 @@
 
 <h2>Important Dates</h2>
 <ul>
-<li>Submission deadline: <b>May 18, 2008</b></li>
-<li>Notification of acceptance: <b>June 08, 2008</b></li>
-<li>ECOOP early registration deadline: <b>June 15, 2008</b></li>
+<li>Submission deadline: <b>May 04, 2008</b></li>
+<li>Notification of acceptance: <b>May 19, 2008</b></li>
+<li>ECOOP early registration deadline: <b>June 01, 2008</b></li>
 </ul>
 
 <h2>Overview</h2>

Modified: trunk/projects/lisp-ecoop/website/templates/programme.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/programme.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/programme.xml	Tue Feb 12 09:13:32 2008
@@ -5,7 +5,7 @@
 
 <h1>Workshop Programme</h1>
 
-The programme will be available by the end of June.
+The programme will be available in June.
 
 <!--
 <h3>9:00 - 10:30</h3>

Modified: trunk/projects/lisp-ecoop/website/templates/submissions.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/submissions.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/submissions.xml	Tue Feb 12 09:13:32 2008
@@ -7,7 +7,7 @@
 
 <!-- <p>We have accepted the following submissions.</p> -->
 
-The list of accepted submissions will be available by the end of June.
+The list of accepted submissions will be available in June.
 
 <h2>Papers</h2>
 <lisp-ecoop:submission-list type="paper"/>


From ksprotte at common-lisp.net  Tue Feb 12 16:56:57 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 12 Feb 2008 11:56:57 -0500 (EST)
Subject: [bknr-cvs] r2483 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080212165657.870CD5D162@common-lisp.net>

Author: ksprotte
Date: Tue Feb 12 11:56:56 2008
New Revision: 2483

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
Log:
(script-name) from hunchentoot returns a string and must
be parsed here into an uri


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Tue Feb 12 11:56:56 2008
@@ -233,7 +233,7 @@
 	 (if (not (authorized-p handler))
 	     (progn
 	       (setf (session-value :login-redirect-uri)
-		     (redirect-uri (script-name)))
+		     (redirect-uri (parse-uri (script-name))))
 	       (redirect (website-make-path *website* "login")))
 	     (if *catch-errors-p*
 		 (handle handler)


From ksprotte at common-lisp.net  Tue Feb 12 16:58:36 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 12 Feb 2008 11:58:36 -0500 (EST)
Subject: [bknr-cvs] r2484 - in branches/trunk-reorg/projects/bos: m2 web
Message-ID: <20080212165836.0D17A2F060@common-lisp.net>

Author: ksprotte
Date: Tue Feb 12 11:58:31 2008
New Revision: 2484

Modified:
   branches/trunk-reorg/projects/bos/m2/m2.lisp
   branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
   branches/trunk-reorg/projects/bos/m2/utils.lisp
   branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
   branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp
   branches/trunk-reorg/projects/bos/web/map-handlers.lisp
   branches/trunk-reorg/projects/bos/web/news-handlers.lisp
   branches/trunk-reorg/projects/bos/web/news-tags.lisp
   branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
   branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
   branches/trunk-reorg/projects/bos/web/startup.lisp
   branches/trunk-reorg/projects/bos/web/tags.lisp
   branches/trunk-reorg/projects/bos/web/web-utils.lisp
   branches/trunk-reorg/projects/bos/web/webserver.lisp
Log:
more changes for bos trunk-reorg


Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/m2.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/m2.lisp	Tue Feb 12 11:58:31 2008
@@ -446,12 +446,10 @@
       (incf retval (length (contract-m2s contract))))
     retval))
 
-;; trunk-reorg adaption
-;; (defun string-safe (string)
-;;   (if string
-;;       (escape-nl (with-output-to-string (s)
-;; 		   (net.html.generator::emit-safe s string)))
-;;       ""))
+(defun string-safe (string)
+  (if string
+      (escape-nl (arnesi:escape-as-html string))
+      ""))
 
 (defun make-m2-javascript (sponsor)
   "Erzeugt das Quadratmeter-Javascript f?r die angegebenen Contracts"

Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp	Tue Feb 12 11:58:31 2008
@@ -275,7 +275,7 @@
 					       email
 					       country
 					       language))
-		       (make-contract-xml-part (store-object-id contract) (all-request-params req))
+		       (make-contract-xml-part (store-object-id contract) (all-request-params))
 		       (make-vcard-part (store-object-id contract)
 					(make-vcard :sponsor-id (store-object-id (contract-sponsor contract))
 						    :note (format nil "Paid-by: Back office
@@ -293,7 +293,7 @@
 						    :email email)))))
       (mail-contract-data contract "Manually entered sponsor" parts))))
 
-(defun mail-manual-sponsor-data (req)
+(defun mail-manual-sponsor-data ()
   (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
 	   (sponsor-id (store-object-id (contract-sponsor contract)))
@@ -327,7 +327,7 @@
 						(if want-print "yes" "no")
 						(if donationcert-yearly "yes" "no")
 						*website-url* contract-id email))
-			(make-contract-xml-part contract-id (all-request-params req))
+			(make-contract-xml-part contract-id (all-request-params))
 			(make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id
 								 :note (format nil "Paid-by: Manual money transfer
 Contract ID: ~A
@@ -362,7 +362,7 @@
 	(remhash contract-id *worldpay-params-hash*))
       (error "cannot find WorldPay callback params for contract ~A~%" contract-id)))
 
-(defun mail-worldpay-sponsor-data (req)
+(defun mail-worldpay-sponsor-data ()
   (with-query-params (contract-id)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
 	   (params (get-worldpay-params contract-id))

Modified: branches/trunk-reorg/projects/bos/m2/utils.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/utils.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/utils.lisp	Tue Feb 12 11:58:31 2008
@@ -5,4 +5,8 @@
 (defun escape-nl (string)
   (if string
       (regex-replace-all #?r"[\n\r]+" string #?"<br />")
-      ""))
\ No newline at end of file
+      ""))
+
+(defun random-elt (choices)
+  (when choices
+    (elt choices (random (length choices)))))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp	Tue Feb 12 11:58:31 2008
@@ -145,7 +145,7 @@
 			 x y
 			 (uriencode-string "Choose lower right point of allocation area")
 			 (uriencode-string (format nil "~A?left=~A&top=~A&"
-						   (uri-path (hunchentoot:request-uri))
+						   (hunchentoot:request-uri)
 						   x y)))))
       (t
        (with-bos-cms-page (:title "Create allocation area")
@@ -166,7 +166,7 @@
     (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&"
 		      start-x start-y
 		      (uriencode-string "Choose upper left point of allocation area")
-		      (uriencode-string (format nil "~A?" (uri-path (hunchentoot:request-uri))))))))
+		      (uriencode-string (format nil "~A?" (hunchentoot:request-uri)))))))
 
 (defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)))
   (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car))))

Modified: branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp	Tue Feb 12 11:58:31 2008
@@ -41,15 +41,15 @@
 (defmethod handle ((handler map-browser-handler))
   (with-query-params (chosen-url)
     (when chosen-url
-      (setf (session-variable :chosen-url) chosen-url)))
+      (setf (hunchentoot:session-value :chosen-url) chosen-url)))
   (with-query-params (view-x view-y)
     (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string)
       (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler)
 	(with-query-params (action)
 	  (when (equal action "save")
-	    (if (session-variable :chosen-url)
+	    (if (hunchentoot:session-value :chosen-url)
 		(redirect (format nil "~Ax=~D&y=~D"
-				  (session-variable :chosen-url)
+				  (hunchentoot:session-value :chosen-url)
 				  point-x
 				  point-y))
 		(with-bos-cms-page (:title "Map Point Chooser")
@@ -130,7 +130,7 @@
 			 ((:div :id "cursor"
 				:style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible")
 			  ((:img :src "/images/map-cursor.png")))))))
-	       (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
+	       (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
 	    (t
 	     (with-bos-cms-page (:title "Map Point Chooser")
 	       (html

Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp	Tue Feb 12 11:58:31 2008
@@ -2,7 +2,7 @@
 
 (enable-interpol-syntax)
 
-(defun map-navigator (req x y base-url &key formcheck)
+(defun map-navigator (x y base-url &key formcheck)
   (labels ((pfeil-image (name)
 	     (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name)))))
 	   (td-link-to (x y name &optional (link-format (concatenate 'string base-url "~D/~D")))
@@ -69,27 +69,27 @@
 	  operation-strings))
 
 ;; trunk-reorg adaption
-;; (defmethod handle-object ((handler image-tile-handler) tile)
-;;   ;; xxx parse url another time - the parse result of
-;;   ;; object-handler-get-object should really be kept in the request
-;;   (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler)
-;;     (declare (ignore x y))
-;;     (let ((changed-time (image-tile-changed-time tile))
-;; 	  (ims (header-slot-value req :if-modified-since)))
-;;       (format t "Warning: not setting last-modified of *ent* to changed-time")
-;;       #+(or)
-;;       (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims)
-;;       (if (or (not ims)
-;; 	      (> changed-time (date-to-universal-time ims)))
-;; 	  (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
-;; 	    (emit-image-to-browser image :png
-;; 				   :date changed-time
-;; 				   :max-age 60)
-;; 	    (cl-gd:destroy-image image))
-;; 	  (with-http-response (*ent*)
-;; 	    (with-http-body ()
-;; 	      ; do nothing
-;; 	      ))))))
+(defmethod handle-object ((handler image-tile-handler) tile)
+  ;; xxx parse url another time - the parse result of
+  ;; object-handler-get-object should really be kept in the request
+  (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler)
+    (declare (ignore x y))
+    (let ((changed-time (image-tile-changed-time tile))
+	  (ims (hunchentoot:header-in :if-modified-since)))
+      (format t "Warning: not setting last-modified of *ent* to changed-time")
+      #+(or)
+      (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims)
+      (if (or (not ims)
+	      (> changed-time (date-to-universal-time ims)))
+	  (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
+	    (emit-image-to-browser image :png
+				   :date changed-time
+				   :max-age 60)
+	    (cl-gd:destroy-image image))
+	  (with-http-response ()
+	    (with-http-body ()
+              ;; do nothing
+	      ))))))
 
 (defclass enlarge-tile-handler (image-tile-handler)
   ())
@@ -107,22 +107,21 @@
 	  x y
 	  (tile-active-layers-from-request-params tile)))
 
-;; trunk-reorg adaption
-;; (defmethod handle-object ((handler enlarge-tile-handler) tile)
-;;   (let ((ismap-coords (decode-ismap-query-string req))
-;; 	(tile-x (tile-nw-x tile))
-;; 	(tile-y (tile-nw-y tile)))
-;;     (if ismap-coords
-;; 	(let* ((x (+ (floor (first ismap-coords) 4) tile-x))
-;; 	       (y (+ (floor (second ismap-coords) 4) tile-y))
-;; 	       (m2 (get-m2 x y))
-;; 	       (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2)))))
-;; 	  (if contract-id
-;; 	      (redirect #?"/contract/$(contract-id)")
-;; 	      (with-bos-cms-page (:title "Not sold")
-;; 		(html (:h2 "this square meter has not been sold yet")))))
-;; 	(with-bos-cms-page (:title "Browsing tile")
-;; 	  (:a ((:a :href (uri-path (hunchentoot:request-uri)))
-;; 	       ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req)))))
-;; 	  (map-navigator req tile-x tile-y "/enlarge-overview/")))))
+(defmethod handle-object ((handler enlarge-tile-handler) tile)
+  (let ((ismap-coords (decode-ismap-query-string))
+	(tile-x (tile-nw-x tile))
+	(tile-y (tile-nw-y tile)))
+    (if ismap-coords
+	(let* ((x (+ (floor (first ismap-coords) 4) tile-x))
+	       (y (+ (floor (second ismap-coords) 4) tile-y))
+	       (m2 (get-m2 x y))
+	       (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2)))))
+	  (if contract-id
+	      (redirect #?"/contract/$(contract-id)")
+	      (with-bos-cms-page (:title "Not sold")
+		(html (:h2 "this square meter has not been sold yet")))))
+	(with-bos-cms-page (:title "Browsing tile")
+	  (:a ((:a :href (hunchentoot:request-uri))
+	       ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y)))))
+	  (map-navigator tile-x tile-y "/enlarge-overview/")))))
 

Modified: branches/trunk-reorg/projects/bos/web/news-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/news-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/news-handlers.lisp	Tue Feb 12 11:58:31 2008
@@ -10,7 +10,7 @@
   ())
 
 (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)))
-  (let ((language (session-variable :language)))
+  (let ((language (hunchentoot:session-value :language)))
     (with-bos-cms-page (:title "Edit news items")
       (content-language-chooser)
       (:h2 "Create new item")
@@ -33,7 +33,7 @@
   (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item)))))
 
 (defmethod handle-object-form ((handler edit-news-handler) action news-item)
-  (let ((language (session-variable :language)))
+  (let ((language (hunchentoot:session-value :language)))
     (with-bos-cms-page (:title "Edit news item")
       (content-language-chooser)
       ((:script :type "text/javascript")
@@ -49,7 +49,7 @@
 	 (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?"))))))))
 
 (defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item)
-  (let ((language (session-variable :language)))
+  (let ((language (hunchentoot:session-value :language)))
     (with-query-params (title text)
       (update-news-item news-item language :title title :text text)
       (with-bos-cms-page (:title "News item updated")

Modified: branches/trunk-reorg/projects/bos/web/news-tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/news-tags.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/news-tags.lisp	Tue Feb 12 11:58:31 2008
@@ -7,17 +7,17 @@
 	do (html (:princ-safe line) :br)))
 
 (define-bknr-tag news-headlines (&key archive)
-  (let ((language (session-variable :language)))
+  (let ((language (hunchentoot:session-value :language)))    
     (let* ((now (get-universal-time))
-	   (news-items (subseq
-			(sort (if archive
-				  (all-news-items language)
-				  (remove-if #'(lambda (news-item)
-						 (> (- now (news-item-time news-item)) *maximum-news-item-age*))
-					     (all-news-items language)))
-			      #'>
-			      :key #'news-item-time)
-			0 (unless archive 3))))
+	   (news-items (if archive
+                           (all-news-items language)
+                           (let ((items (sort (remove-if
+                                               #'(lambda (news-item)
+                                                   (> (- now (news-item-time news-item)) *maximum-news-item-age*))
+                                               (all-news-items language))
+                                              #'>
+                                              :key #'news-item-time)))
+                             (subseq items 0 (min (length items) 3))))))
       (labels ((show-news-entry (news-item)
 		 (html ((:a :href (format nil "javascript:window_news('news/~a')" (store-object-id news-item))
 			    :class "more")
@@ -25,16 +25,16 @@
 				 :br
 				 (:princ-safe (news-item-title news-item language)))))))
 	(loop for news-item in news-items
-	      for index from 1
-	      do (if archive
-		     (html (show-news-entry news-item)
-			   :br :br)
-		     (html ((:div :id (format nil "newsbox~a" index))
-			    (show-news-entry news-item)))))))))
+           for index from 1
+           do (if archive
+                  (html (show-news-entry news-item)
+                        :br :br)
+                  (html ((:div :id (format nil "newsbox~a" index))
+                         (show-news-entry news-item)))))))))
 
 (define-bknr-tag news-item ()
   (let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url (get-template-var :request))))))
-	(language (session-variable :language)))
+	(language (hunchentoot:session-value :language)))
     (html ((:h1 :class "extra")
 	   (:princ-safe (format-date-time (news-item-time news-item) :show-time nil))
 	   ", "

Modified: branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/poi-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/poi-handlers.lisp	Tue Feb 12 11:58:31 2008
@@ -18,7 +18,7 @@
 	 (html (:h2 "Bad technical name")
 	       "Please use only alphanumerical characters, - and _ for technical POI names")))
       (t
-       (redirect (edit-object-url (make-poi (session-variable :language) name)))))))
+       (redirect (edit-object-url (make-poi (hunchentoot:session-value :language) name)))))))
 
 (defclass edit-poi-handler (editor-only-handler edit-object-handler)
   ()
@@ -34,7 +34,7 @@
 		do (html (:li (cmslink (edit-object-url poi)
 				(:princ-safe (poi-name poi))
 				" - "
-				(:princ-safe (slot-string poi 'title (session-variable :language)))))))))
+				(:princ-safe (slot-string poi 'title (hunchentoot:session-value :language)))))))))
 	(html (:h2 "No POIs created yet")))
     ((:form :method "post" :action "/make-poi")
      "Make new POI named "
@@ -52,7 +52,7 @@
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       action (poi poi))
   (with-query-params (language shift shift-by)
-    (unless language (setq language (session-variable :language)))
+    (unless language (setq language (hunchentoot:session-value :language)))
     (when shift
       ;; change image order
       (setq shift (find-store-object (parse-integer shift)))
@@ -65,7 +65,7 @@
 	(setf (nth old-position new-images) (nth (+ shift-by old-position) new-images))
 	(setf (nth (+ shift-by old-position) new-images) tmp)
 	(change-slot-values poi 'bos.m2::images new-images)))
-    (setf (session-variable :language) language)
+    (setf (hunchentoot:session-value :language) language)
     (with-bos-cms-page (:title "Edit POI")
       (content-language-chooser)
       (unless (poi-complete poi language)
@@ -95,11 +95,11 @@
 		     (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi)))))
 		     (cmslink (format nil "map-browser/~A/~A?chosen-url=~A"
 				      (first (poi-area poi)) (second (poi-area poi))
-				      (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri)))))
+				      (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri))))
 		       "[relocate]"))
 		    (t
 		     (cmslink (format nil "map-browser/?chosen-url=~A"
-				      (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri)))))
+				      (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri))))
 		       "[choose]")))))
 	(:tr (:td "icon")
 	     (:td (icon-chooser "icon" (poi-icon poi))))
@@ -169,7 +169,7 @@
 (defmethod handle-object-form ((handler edit-poi-handler)
 			       (action (eql :save)) (poi poi))
   (with-query-params (published title subtitle description language x y icon movie)
-    (unless language (setq language (session-variable :language)))
+    (unless language (setq language (hunchentoot:session-value :language)))
     (let ((args (list :title title
 		      :published published
 		      :subtitle subtitle
@@ -301,7 +301,7 @@
 
 (defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image)
   (with-query-params (language poi)
-    (unless language (setq language (session-variable :language)))
+    (unless language (setq language (hunchentoot:session-value :language)))
     (with-bos-cms-page (:title "Edit POI Image")
       (html
        (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI")
@@ -331,7 +331,7 @@
 
 (defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image)
   (with-query-params (title subtitle description language)
-    (unless language (setq language (session-variable :language)))
+    (unless language (setq language (hunchentoot:session-value :language)))
     (update-poi-image poi-image language
 		      :title title
 		      :subtitle subtitle
@@ -366,7 +366,7 @@
       (with-http-body ()
 	(let ((*standard-output* *html-stream*))
 	  (princ "<script language=\"JavaScript\">") (terpri)
-	  (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri)
+	  (princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) (terpri)
 	  (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri)
 	  (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts)))
 	  (princ "</script>") (terpri)))))

Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	Tue Feb 12 11:58:31 2008
@@ -192,7 +192,7 @@
 	  (html (:p "Changed contract status to \"paid\""))))
       (unless changed
 	(html (:p "No changes have been made")))
-      (html (cmslink (uri-path (hunchentoot:request-uri))
+      (html (cmslink (hunchentoot:request-uri)
 	      "Return to sponsor profile")))))
 
 (defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor)

Modified: branches/trunk-reorg/projects/bos/web/startup.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/startup.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/startup.lisp	Tue Feb 12 11:58:31 2008
@@ -36,12 +36,15 @@
 
 (defun reinit (&key debug)
   (format t "~&; Publishing BOS handlers.~%")
-  (unpublish :all t)
+  (unpublish)
   (bos.web::publish-website :website-directory *website-directory*
 			    :vhosts *vhosts*
 			    :website-url *website-url*
 			    :worldpay-test-mode *worldpay-test-mode*)
-  (format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
+  (format t "~&; Starting hunchentoot~@[ in debug mode~].~%" debug)
   (force-output)  
   (setq hunchentoot:*catch-errors-p* (not debug))
-  (hunchentoot:start-server :port *port*))
+  (when *webserver*
+    (hunchentoot:stop-server *webserver*))
+  (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
+  (setq *webserver* (hunchentoot:start-server :port *port*)))

Modified: branches/trunk-reorg/projects/bos/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/tags.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/tags.lisp	Tue Feb 12 11:58:31 2008
@@ -41,7 +41,7 @@
     (let ((contract (find-store-object (parse-integer (get-template-var :contract-id)))))
       (when (equal want-print "no")
 	(contract-set-download-only-p contract t))
-      (contract-issue-cert contract name :address address :language (session-variable :language))
+      (contract-issue-cert contract name :address address :language (hunchentoot:session-value :language))
       (mail-worldpay-sponsor-data (get-template-var :request))
       (bknr.web::redirect-request :target (if gift "index"
 					      (format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
@@ -78,7 +78,7 @@
 	       (manual-transfer (or (scan #?r"rweisen" action)
 				    (scan #?r"rweisung" action)
 				    (scan #?r"verf" action)))
-	       (language (session-variable :language))
+	       (language (hunchentoot:session-value :language))
 	       (sponsor (make-sponsor :language language))
 	       (contract (make-contract sponsor numsqm
 					:download-only download-only
@@ -120,8 +120,7 @@
       (bknr.web::redirect-request :target "allocation-areas-exhausted"))))
 
 (define-bknr-tag mail-transfer ()
-  (with-query-params ((get-template-var :request)
-		      country
+  (with-query-params (country
 		      contract-id 
 		      name vorname strasse plz ort)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
@@ -134,7 +133,7 @@
 					    vorname name
 					    strasse
 					    plz ort)
-			   :language (session-variable :language))
+			   :language (hunchentoot:session-value :language))
       (mail-manual-sponsor-data (get-template-var :request)))))
 
 (define-bknr-tag when-certificate (&key children)

Modified: branches/trunk-reorg/projects/bos/web/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/web-utils.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/web-utils.lisp	Tue Feb 12 11:58:31 2008
@@ -42,9 +42,9 @@
   (cadr (assoc language-short-name (website-languages) :test #'equal)))
 
 (defun current-website-language ()
-  (unless (session-variable :language)
-    (setf (session-variable :language) *default-language*))
-  (session-variable :language))
+  (unless (hunchentoot:session-value :language)
+    (setf (hunchentoot:session-value :language) *default-language*))
+  (hunchentoot:session-value :language))
 
 (defun content-language-chooser ()
   (html
@@ -52,9 +52,9 @@
     "Content languages: "
     (loop for (language-symbol language-name) in (website-languages)
 	  do (labels ((show-language-link ()
-			(html (cmslink (format nil "~A?language=~A" (uri-path (hunchentoot:request-uri)) language-symbol)
+			(html (cmslink (format nil "~A?language=~A" (hunchentoot:request-uri) language-symbol)
 				(:princ-safe language-name)))))
-	       (if (equal (session-variable :language) language-symbol)
+	       (if (equal (hunchentoot:session-value :language) language-symbol)
 		   (html "[" (show-language-link) "]")
 		   (html (show-language-link)))
 	       (html " "))))))

Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp	Tue Feb 12 11:58:31 2008
@@ -46,8 +46,8 @@
 	    (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info")))))))
     ((and (not (scan "/" template-name))
 	  (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml")
-					    (template-handler-destination handler)))))
-     (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request)
+					    (bknr.web::template-expander-destination handler)))))
+     (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language)
 						 *default-language*)
 				 (if (equal "" template-name)
 				     "index" template-name)))))
@@ -78,7 +78,7 @@
   "Determine the language prefered by the user, as determined by the Accept-Language header
 present in the HTTP request.  Header decoding is done according to RFC2616, considering individual
 language preference weights."
-  (let ((accept-language (header-slot-value req :accept-language)))
+  (let ((accept-language (hunchentoot:header-in :accept-language)))
     (dolist (language (mapcar #'car
 			      (sort (mapcar #'(lambda (language-spec-string)
 						(if (find #\; language-spec-string)
@@ -102,7 +102,7 @@
 (defmethod handle ((handler index-handler))
   (redirect (format nil "/~A/index" (or (find-browser-prefered-language)
 					*default-language*))
-	    :permanently *response-moved-permanently*))
+	    :permanently t))
 
 (defclass infosystem-handler (page-handler)
   ())
@@ -112,7 +112,7 @@
   (with-query-params (logout)
     (when logout
       (bknr.web::drop-session *session*)))
-  (let ((language (session-variable :language)))
+  (let ((language (hunchentoot:session-value :language)))
     (redirect #?"/infosystem/$(language)/satellitenkarte.htm")))
 
 (defclass certificate-handler (object-handler)
@@ -172,7 +172,7 @@
 ;; (defmethod authorize :after ((authorizer bos-authorizer)
 ;; 			     (req http-request)
 ;; 			     (ent net.aserve::entity))
-;;   (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
+;;   (let ((new-language (or (language-from-url (hunchentoot:request-uri))
 ;; 			  (query-param "language")))
 ;; 	(current-language (gethash :language (bknr-session-variables *session*))))
 ;;     (when (or (not current-language)
@@ -180,9 +180,13 @@
 ;; 		   (not (equal new-language current-language))))
 ;;       (setf (gethash :language (bknr-session-variables *session*))
 ;; 	    (or new-language
-;; 		(find-browser-prefered-language req)
+;; 		(find-browser-prefered-language)
 ;; 		*default-language*)))))
 
+;;; TODOreorg
+(defun publish-directory (&key prefix destination)
+  (push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:*dispatch-table*))
+
 (defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
   (setf *website-directory* website-directory)
 
@@ -231,8 +235,8 @@
 					("/index" index-handler)
 					("/" worldpay-template-handler
 					 :destination ,(namestring (merge-pathnames #p"templates/" website-directory))
-					 :command-packages ((:bos . :bos.web)
-							    (:bknr . :bknr.web))))
+					 :command-packages (("http://headcraft.de/bos" . :bos.web)
+							    ("http://bknr.net" . :bknr.web))))
 		 :modules '(user images stats)
 		 :navigation '(("sponsor" . "edit-sponsor/")
 			       ("statistics" . "statistics/")
@@ -256,4 +260,4 @@
   (publish-directory :prefix "/infosystem/"
 		     :destination (namestring (merge-pathnames "infosystem/" website-directory)))
   (publish-directory :prefix "/certificates/"
-		     :destination (namestring *cert-download-directory*)))
+		     :destination (namestring *cert-download-directory*)))
\ No newline at end of file


From hhubner at common-lisp.net  Wed Feb 13 10:15:14 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed, 13 Feb 2008 05:15:14 -0500 (EST)
Subject: [bknr-cvs] r2485 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080213101514.0379817046@common-lisp.net>

Author: hhubner
Date: Wed Feb 13 05:15:12 2008
New Revision: 2485

Modified:
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
Log:
Fix templater so that top-level element can be user-defined again.


Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Wed Feb 13 05:15:12 2008
@@ -147,8 +147,9 @@
 	   (let ((*tag-children* children))
 	     (apply (find-tag-function expander name ns)
 		    (append (loop for (key name) in attrs
+                                  unless (consp key) ; ignore attributes with namespace
 				  collect (make-keyword-from-string key)
-				  collect (expand-variables name #'get-template-var))))))
+                                  and collect (expand-variables name #'get-template-var))))))
           (t
            (sax:start-element *html-sink* nil nil name
                               (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs))
@@ -164,7 +165,7 @@
   (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)
 		     (cxml-xmls::compute-attributes/lnames toplevel t))
   (let ((*template-expander* expander))
-    (mapc (curry #'emit-template-node expander) (node-children toplevel)))
+    (emit-template-node expander toplevel))
   (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)))
 
 (defun find-template (dir components)


From hhubner at common-lisp.net  Wed Feb 13 19:40:27 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed, 13 Feb 2008 14:40:27 -0500 (EST)
Subject: [bknr-cvs] r2486 - in branches/trunk-reorg/thirdparty/slime: .
	contrib contrib/CVS
Message-ID: <20080213194027.4DB114F01A@common-lisp.net>

Author: hhubner
Date: Wed Feb 13 14:40:19 2008
New Revision: 2486

Modified:
   branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
   branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
   branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el
   branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el
   branches/trunk-reorg/thirdparty/slime/slime.el
   branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
   branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
   branches/trunk-reorg/thirdparty/slime/swank.asd
   branches/trunk-reorg/thirdparty/slime/swank.lisp
Log:
update and add marcos patch to allow for repeated loading of the swank system

Modified: branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/CVS/Entries	Wed Feb 13 14:40:19 2008
@@ -4,34 +4,34 @@
 /slime-asdf.el/1.3/Thu Oct 11 14:10:25 2007//
 /slime-autodoc.el/1.7/Thu Feb  7 07:59:35 2008//
 /slime-banner.el/1.4/Thu Oct 11 14:10:25 2007//
-/slime-c-p-c.el/1.8/Thu Oct 11 14:10:25 2007//
 /slime-editing-commands.el/1.6/Thu Feb  7 07:59:35 2008//
 /slime-fuzzy.el/1.6/Thu Feb  7 07:59:35 2008//
 /slime-highlight-edits.el/1.3/Thu Oct 11 14:10:25 2007//
-/slime-indentation.el/1.1/Sun Feb  3 18:45:14 2008//
-/slime-motd.el/1.1/Sun Feb  3 18:39:23 2008//
 /slime-parse.el/1.10/Thu Feb  7 07:59:35 2008//
 /slime-presentation-streams.el/1.2/Thu Oct 11 14:10:25 2007//
 /slime-presentations.el/1.12/Thu Feb  7 07:59:35 2008//
 /slime-references.el/1.4/Thu Oct 11 14:10:25 2007//
-/slime-scheme.el/1.1/Thu Feb  7 08:07:31 2008//
 /slime-scratch.el/1.4/Thu Oct 11 14:10:25 2007//
 /slime-tramp.el/1.2/Thu Oct 11 14:10:25 2007//
 /slime-typeout-frame.el/1.6/Thu Feb  7 07:59:35 2008//
-/slime-xref-browser.el/1.1/Thu Oct 11 14:10:25 2007//
 /swank-arglists.lisp/1.20/Thu Feb  7 08:07:31 2008//
 /swank-asdf.lisp/1.1/Thu Oct 11 14:10:25 2007//
 /swank-c-p-c.lisp/1.2/Thu Oct 11 14:10:25 2007//
 /swank-fuzzy.lisp/1.7/Thu Feb  7 07:59:35 2008//
-/swank-goo.goo/1.1/Thu Feb  7 08:07:32 2008//
-/swank-indentation.lisp/1.1/Sun Feb  3 18:45:14 2008//
-/swank-kawa.scm/1.1/Thu Feb  7 08:07:32 2008//
 /swank-listener-hooks.lisp/1.1/Thu Oct 11 14:10:25 2007//
-/swank-motd.lisp/1.1/Sun Feb  3 18:39:23 2008//
 /swank-presentation-streams.lisp/1.5/Thu Feb  7 08:07:32 2008//
 /swank-presentations.lisp/1.4/Thu Oct 11 14:10:25 2007//
-/ChangeLog/1.89/Mon Feb 11 14:20:11 2008//
 /slime-fancy-inspector.el/1.3/Mon Feb 11 14:20:11 2008//
 /slime-fancy.el/1.5/Mon Feb 11 14:20:11 2008//
 /swank-fancy-inspector.lisp/1.11/Mon Feb 11 14:20:11 2008//
+/ChangeLog/1.91/Wed Feb 13 19:38:01 2008//
+/slime-c-p-c.el/1.9/Wed Feb 13 19:38:01 2008//
+/slime-indentation.el/1.1/Wed Feb 13 19:38:02 2008//
+/slime-motd.el/1.1/Wed Feb 13 19:38:02 2008//
+/slime-scheme.el/1.1/Wed Feb 13 19:38:02 2008//
+/slime-xref-browser.el/1.2/Wed Feb 13 19:38:02 2008//
+/swank-goo.goo/1.1/Wed Feb 13 19:38:03 2008//
+/swank-indentation.lisp/1.1/Wed Feb 13 19:38:03 2008//
+/swank-kawa.scm/1.1/Wed Feb 13 19:38:03 2008//
+/swank-motd.lisp/1.1/Wed Feb 13 19:38:03 2008//
 D

Modified: branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/ChangeLog	Wed Feb 13 14:40:19 2008
@@ -1,3 +1,16 @@
+2008-02-13  Helmut Eller  <heller at common-lisp.net>
+
+	* slime-c-p-c.el (slime-c-p-c-init): Use slime-require instead of
+	a connected-hook.
+
+2008-02-13  Helmut Eller  <heller at common-lisp.net>
+
+	Track tree-widget change: :dynarg is now called :expander.
+
+	* slime-xref-browser.el (slime-expand-class-node)
+	(slime-browse-classes, slime-expand-xrefs, slime-browse-xrefs):
+	:dynargs is obsolete, it is now called :expander.
+
 2008-02-10  Helmut Eller  <heller at common-lisp.net>
 
 	Fix some bugs introduced by the recent reorganization.
@@ -10,7 +23,7 @@
 	* slime-fancy.el: slime-fancy-inspector-init no longer exists, so
 	don't call it.  Once loaded, it's also no longer possible to turn
 	the fancy inspector off.
-	
+
 2008-02-04  Marco Baringer  <mb at bese.it>
 
 	* swank-presentation-streams.lisp (presenting-object-1): Add

Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-c-p-c.el	Wed Feb 13 14:40:19 2008
@@ -13,7 +13,7 @@
 ;; Add this to your .emacs: 
 ;;
 ;;   (add-to-list 'load-path "<directory-of-this-file>")
-;;   (add-hook 'slime-load-hook (lambda () (require 'slime-c-p-c)))
+;;   (slime-setup '(slime-c-p-c ... possibly other packages ...))
 ;;
 
 
@@ -177,6 +177,7 @@
 (defvar slime-c-p-c-init-undo-stack nil)
 
 (defun slime-c-p-c-init ()
+  (slime-require :swank-arglists)
   ;; save current state for unload
   (push 
    `(progn
@@ -188,13 +189,9 @@
 	',(lookup-key slime-repl-mode-map "\C-c\C-s")))
    slime-c-p-c-init-undo-stack)
   (setq slime-complete-symbol-function 'slime-complete-symbol*)
-  (add-hook 'slime-connected-hook 'slime-c-p-c-on-connect)
   (define-key slime-mode-map "\C-c\C-s" 'slime-complete-form)
   (define-key slime-repl-mode-map "\C-c\C-s" 'slime-complete-form))
 
-(defun slime-c-p-c-on-connect ()
-  (slime-eval-async '(swank:swank-require :swank-arglists)))
-
 (defun slime-c-p-c-unload ()
   (while slime-c-p-c-init-undo-stack
     (eval (pop slime-c-p-c-init-undo-stack))))

Modified: branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/contrib/slime-xref-browser.el	Wed Feb 13 14:40:19 2008
@@ -8,7 +8,7 @@
 ;; Add this to your .emacs: 
 ;;
 ;;   (add-to-list 'load-path "<directory-of-this-file>")
-;;   (add-hook 'slime-load-hook (lambda () (require 'slime-xref-browser)))
+;;   (slime-setup '(slime-xref-browser ... possibly other packages ...))
 ;;
 
 

@@ -19,7 +19,7 @@
       (let ((name (widget-get widget :tag)))
 	(loop for kid in (slime-eval `(swank:mop :subclasses ,name))
 	      collect `(tree-widget :tag ,kid
-				    :dynargs slime-expand-class-node
+				    :expander slime-expand-class-node
 				    :has-children t)))))
 
 (defun slime-browse-classes (name)
@@ -29,7 +29,7 @@
    "*slime class browser*" (slime-current-package) "Class Browser"
    (lambda ()
      (widget-create 'tree-widget :tag name 
-                    :dynargs 'slime-expand-class-node 
+                    :expander 'slime-expand-class-node 
                     :has-echildren t))))
 
 (defvar slime-browser-map nil
@@ -84,7 +84,7 @@
               collect `(tree-widget :tag ,label
                                     :xref-type ,type
                                     :xref-dspec ,dspec
-                                    :dynargs slime-expand-xrefs
+                                    :expander slime-expand-xrefs
                                     :has-children t)))))
 
 (defun slime-browse-xrefs (name type)
@@ -99,6 +99,6 @@
    "*slime xref browser*" (slime-current-package) "Xref Browser"
    (lambda ()
      (widget-create 'tree-widget :tag name :xref-type type :xref-dspec name 
-                    :dynargs 'slime-expand-xrefs :has-echildren t))))
+                    :expander 'slime-expand-xrefs :has-echildren t))))
 
-(provide 'slime-xref-browser)
\ No newline at end of file
+(provide 'slime-xref-browser)

Modified: branches/trunk-reorg/thirdparty/slime/slime.el
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/slime.el	(original)
+++ branches/trunk-reorg/thirdparty/slime/slime.el	Wed Feb 13 14:40:19 2008
@@ -1432,6 +1432,7 @@
     (format "%S\n\n"
             `(progn
                (load ,(expand-file-name loader) :verbose t)
+               (funcall (read-from-string "swank-loader:load-swank"))
                (funcall (read-from-string "swank:start-server")
                         ,port-filename
                         :coding-system ,encoding)))))

Modified: branches/trunk-reorg/thirdparty/slime/swank-backend.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-backend.lisp	Wed Feb 13 14:40:19 2008
@@ -10,7 +10,11 @@
 ;;; separately for each Lisp. Each is declared as a generic function
 ;;; for which swank-<implementation>.lisp provides methods.
 
-(defpackage :swank-backend
+;(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+;  (cl:when (cl:find-package :swank-backend)
+;    (cl:delete-package :swank-backend)))
+
+(cl:defpackage :swank-backend
   (:use :common-lisp)
   (:export #:sldb-condition
            #:original-condition
@@ -39,7 +43,11 @@
            #:with-struct
            ))
 
-(defpackage :swank-mop
+(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+  (cl:when (cl:find-package :swank-mop)
+    (cl:delete-package :swank-mop)))
+
+(cl:defpackage :swank-mop
   (:use)
   (:export
    ;; classes

Modified: branches/trunk-reorg/thirdparty/slime/swank-loader.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank-loader.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank-loader.lisp	Wed Feb 13 14:40:19 2008
@@ -18,11 +18,11 @@
 ;;   (defparameter swank-loader::*fasl-directory* "/tmp/fasl/")
 ;;   (load ".../swank-loader.lisp")
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (find-package :swank)
-    (delete-package :swank)
-    (delete-package :swank-io-package)
-    (delete-package :swank-backend)))
+;(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+;  (cl:when (cl:find-package :swank)
+;    (cl:delete-package :swank-loader)
+;    (cl:delete-package :swank)
+;    (cl:delete-package :swank-backend)))
 
 (cl:defpackage :swank-loader
   (:use :cl)
@@ -139,7 +139,7 @@
     (ignore-errors (delete-file binary-pathname)))
   (abort))
 
-(defun compile-files-if-needed-serially (files fasl-directory load)
+(defun compile-files-if-needed-serially (files fasl-directory &key load force)
   "Compile each file in FILES if the source is newer than
 its corresponding binary, or the file preceding it was
 recompiled."
@@ -149,7 +149,8 @@
                                               fasl-directory)))
         (handler-case
             (progn
-              (when (or needs-recompile
+              (when (or force
+                        needs-recompile
                         (not (probe-file binary-pathname))
                         (file-newer-p source-pathname binary-pathname))
                 ;; need a to recompile source-pathname, so we'll
@@ -220,18 +221,17 @@
                    (source-directory *source-directory*)
                    (fasl-directory *fasl-directory*)
                    (contrib-fasl-directory 
-                    (append-dir fasl-directory "contrib")))
+                    (append-dir fasl-directory "contrib"))
+                   (force nil))
   (compile-files-if-needed-serially (swank-source-files source-directory)
-                                    fasl-directory t)
+                                    fasl-directory :load t :force force)
   (compile-files-if-needed-serially (contrib-source-files source-directory)
-                                    contrib-fasl-directory nil))
-
-(load-swank)
+                                    contrib-fasl-directory :load nil :force force)
 
-(setq swank::*swank-wire-protocol-version* (slime-version-string))
-(setq swank::*load-path* 
-      (append swank::*load-path* (list (contrib-src-dir *source-directory*))))
-(swank-backend::warn-unimplemented-interfaces)
-(load-site-init-file *source-directory*)
-(load-user-init-file)
-(swank:run-after-init-hook)
+  (setf (symbol-value (read-from-string "swank::*swank-wire-protocol-version*")) (slime-version-string))
+  (push (contrib-src-dir *source-directory*)
+        (symbol-value (read-from-string "swank::*load-path*")))
+  (funcall (read-from-string "swank-backend::warn-unimplemented-interfaces"))
+  (load-site-init-file *source-directory*)
+  (load-user-init-file)
+  (funcall (read-from-string "swank:run-after-init-hook")))

Modified: branches/trunk-reorg/thirdparty/slime/swank.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.asd	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank.asd	Wed Feb 13 14:40:19 2008
@@ -24,25 +24,32 @@
 
 (in-package :swank-loader)
 
-(defclass cl-script-file (asdf:source-file) ())
+(defclass swank-loader-file (asdf:source-file) ())
 
-(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file))
-  t)
-(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file))
-  (mapcar #'load (asdf:input-files o f)))
-(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file))
-  nil)
-(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file))
-  (list (asdf:component-pathname c)))
-(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file))
-  t)
-(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module))
+;; asdf:compile-op does nothing for swank.
+
+(defmethod asdf:perform ((o asdf:compile-op) (f swank-loader-file)) t)
+
+(defmethod asdf:operation-done-p ((o asdf:compile-op) (f swank-loader-file)) t)
+
+(defmethod asdf:output-files ((o asdf:compile-op) (f swank-loader-file)) '())
+
+;; asdf:load-op acutally loads it
+
+(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
+  (if (find-package :swank)
+      (warn "Attempting to load re-load swank into this image. Ignoring request.")
+      (progn
+        (load (merge-pathnames (asdf:component-pathname f)))
+        (funcall (read-from-string "swank-loader:load-swank")
+                 :source-directory (asdf:component-pathname (asdf:find-system :swank))))))
+
+(defmethod asdf:operation-done-p ((o asdf:load-op) (f swank-loader-file))
+  (find-package :swank))
+
+(defmethod asdf:source-file-type ((c swank-loader-file) (s asdf:module))
   "lisp")
 
 (asdf:defsystem :swank
-    :default-component-class cl-script-file
+    :default-component-class swank-loader-file
     :components ((:file "swank-loader")))
-
-(defparameter *source-directory*
-  (asdf:component-pathname (asdf:find-system :swank)))
-

Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp	Wed Feb 13 14:40:19 2008
@@ -12,7 +12,11 @@
 ;;; them separately for each Lisp implementation. These extensions are
 ;;; available to us here via the `SWANK-BACKEND' package.
 
-(defpackage :swank
+;(cl:eval-when (:compile-toplevel :load-toplevel :execute)
+;  (cl:when (cl:find-package :swank)
+;    (cl:delete-package :swank)))
+
+(cl:defpackage :swank
   (:use :cl :swank-backend)
   (:export #:startup-multiprocessing
            #:start-server 


From hhubner at common-lisp.net  Wed Feb 13 19:41:11 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed, 13 Feb 2008 14:41:11 -0500 (EST)
Subject: [bknr-cvs] r2487 - in
	branches/trunk-reorg/thirdparty/drakma-0.11.3: . doc
Message-ID: <20080213194111.D4CDB702E7@common-lisp.net>

Author: hhubner
Date: Wed Feb 13 14:41:09 2008
New Revision: 2487

Added:
   branches/trunk-reorg/thirdparty/drakma-0.11.3/
   branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/
   branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp   (contents, props changed)
   branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp   (contents, props changed)
Log:
Add drakma


Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/CHANGELOG.txt	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,147 @@
+Version 0.11.3
+2008-01-14
+The previous change is only needed for Windows
+
+Version 0.11.2
+2008-01-14
+Disable WRITE-TIMEOUT for LW5.0 if SSL is used (reported by Nico de Jager)
+
+Version 0.11.1
+2007-10-11
+Make Drakma work with AllegroCL's "modern" mode (patch by Ross Jekel)
+Needs at least Chunga 0.4.1 and FLEXI-STREAMS 0.13.1
+
+Version 0.11.0
+2007-10-01
+Added *TEXT-CONTENT-TYPES* and *BODY-FORMAT-FUNCTION* (suggested by Peter Eddy)
+
+Version 0.10.2
+2007-09-29
+Fixed bug introduced in latest change... (reported by Ross Jekel)
+
+Version 0.10.1
+2007-09-25
+Use parameters in URI if they weren't used up for the content body (suggested by Jan Rychter)
+
+Version 0.10.0
+2007-09-18
+Added support for "HttpOnly" cookie attribute (due to a bug report by Alexey Goldin)
+
+Version 0.9.1
+2007-07-12
+Improved CL+SSL support (patch by David Lichteblau)
+
+Version 0.9.0
+2007-06-30
+Added reason phrase to return values (patch by Holger D?rer)
+
+Version 0.8.0
+2007-06-25
+In cookie dates, accept time zones different from "GMT" (reported by Didier Verna)
+Added *ignore-unparseable-cookie-dates-p*
+
+Version 0.7.1
+2007-06-17
+Allow streams or functions as file designators (suggested by Andrei Stebakov)
+
+Version 0.7.0
+2007-04-07
+Switched from trivial-sockets to usocket (patch by Erik Huelsmann)
+
+Version 0.6.2
+2007-03-09
+Fixed release dates (thanks to Jeffrey Cunningham)
+
+Version 0.6.1
+2007-03-08
+Changed SPLIT-STRING so that it doesn't rely on unspecified behaviour (reported by Jianshi Huang)
+
+Version 0.6.0
+2007-02-08
+Make sure stream is closed in case of early errors (thanks to Chris Dean for test data)
+Robustified cookie parsing
+Send all outgoing cookies in one fell swoop (for Sun's buggy web server)
+Deal with empty Location headers
+Deal with corrupted Content-Type headers
+
+Version 0.5.5
+2007-02-05
+Fixed socket leak in case of redirects (bug report by Chris Dean)
+
+Version 0.5.4
+2006-12-01
+Workaround for servers which send headers after 100 status line (provided by Donavon Keithley)
+
+Version 0.5.3
+2006-10-11
+Set stream element type for binary streams as needed for CLISP (reported by Magnus Henoch)
+
+Version 0.5.2
+2006-10-08
+Adhere to user-provided content length if FORM-DATA is true
+
+Version 0.5.1
+2006-10-07
+Take Content-Encoding header into account (due to a bug report by Gregory Tod)
+
+Version 0.5.0
+2006-09-25
+Fixed bug where body sometimes wasn't read (reported by Ivan Toshkov)
+Added AUTO-REFERER feature (thanks to Colin Simmonds)
+
+Version 0.4.4
+2006-09-24
+Treat "localhost" special for cookies (reported by Ivan Toshkov)
+
+Version 0.4.3
+2006-09-24
+Circumvent CL+SSL for AllegroCL (suggested by David Lichteblau)
+
+Version 0.4.2
+2006-09-07
+Fixed :OPTIONS* method
+
+Version 0.4.1
+2006-09-07
+Added more methods including :OPTIONS* pseudo method (suggested by Ralf Mattes)
+Always (except for POST) add parameters to URI query
+Always read body (unless there's no chunking and no content length)
+
+Version 0.4.0
+2006-09-05
+Added file uploads
+Added multipart/form-data
+Added enforced computation of request bodies in RAM
+Use LF line endings in default external format
+
+Version 0.3.1
+2006-09-04
+Don't use underlying streams of flexi streams anymore
+Returned streams now have element type OCTET when FORCE-BINARY is true
+Better default "User-Agent" header for some Lisps
+Added info about mailing lists
+Added note about Gentoo
+
+Version 0.3.0
+2006-09-02
+Added client-side chunked encoding and various ways to send the content
+
+Version 0.2.0
+2006-09-01
+Completely re-factored for portability, chunking code is in Chunga now
+
+Version 0.1.3
+2006-08-30
+REQUIRE "comm" before WITH-STREAM-INPUT-BUFFER is used
+
+Version 0.1.2
+2006-08-27
+Notes about SSL and listener font
+
+Version 0.1.1
+2006-08-27
+Note about CL-BASE64 and KMRCL
+
+Version 0.1.0
+2006-08-27
+First public release

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/cookies.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,309 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/cookies.lisp,v 1.15 2008/01/14 01:57:01 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :drakma)
+
+(defclass cookie ()
+  ((name :initarg :name
+         :initform (error "A cookie must have a name.")
+         :accessor cookie-name
+         :documentation "The name of the cookie.")
+   (value :initarg :value
+          :initform ""
+          :accessor cookie-value
+          :documentation "The cookie's value.")
+   (domain :initarg :domain
+           :initform (error "A cookie must have a domain.")
+           :accessor cookie-domain
+           :documentation "The domain the cookie is valid for.")
+   (path :initarg :path
+         :initform "/"
+         :accessor cookie-path
+         :documentation "The path prefix the cookie is valid for.")
+   (expires :initarg :expires
+            :initform nil
+            :accessor cookie-expires
+            :documentation "When the cookie expires.  A Lisp
+universal time or NIL.")
+   (securep :initarg :securep
+            :initform nil
+            :accessor cookie-securep
+            :documentation "Whether the cookie must only be
+transmitted over secure connections.")
+   (http-only-p :initarg :http-only-p
+                :initform nil
+                :accessor cookie-http-only-p
+                :documentation "Whether the cookie should not be
+accessible from Javascript.
+
+This is a Microsoft extension that has been implemented in Firefox as
+well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>."))
+  (:documentation "Elements of this class represent HTTP cookies."))
+
+(defun render-cookie-date (time)
+  "Returns a string representation of the universal time TIME
+which can be used for cookie headers."
+  (multiple-value-bind (second minute hour date month year weekday)
+      (decode-universal-time time 0)
+    (format nil "~A, ~2,'0d-~2,'0d-~4,'0d ~2,'0d:~2,'0d:~2,'0d GMT"
+            (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") weekday)
+            date month year hour minute second)))
+
+(defmethod print-object ((cookie cookie) stream)
+  "Prints a representation of COOKIE similar to a `Set-Cookie' header."
+  (print-unreadable-object (cookie stream :type t)
+    (with-slots (name value expires path domain securep http-only-p)
+        cookie
+      (format stream "~A~@[=~A~]~@[; expires=~A~]~@[; path=~A~]~@[; domain=~A~]~@[; secure~]~@[; HttpOnly~]"
+              name (and (plusp (length value)) value)
+              (and expires (render-cookie-date expires))
+              path domain securep http-only-p))))
+              
+(defun normalize-cookie-domain (domain)
+  "Adds a dot at the beginning of the string DOMAIN unless there
+is already one."
+  (cond ((starts-with-p domain ".") domain)
+        (t (format nil ".~A" domain))))
+
+(defun valid-cookie-domain-p (domain)
+  "Checks if the string DOMAIN contains enough dots to be
+acceptable."
+  (or (string-equal domain "localhost")
+      (> (count #\. (normalize-cookie-domain domain) :test #'char=) 1)))
+
+(defun cookie-domain-matches (domain uri)
+  "Checks if the domain DOMAIN \(a string) matches the \(PURI) URI URI."
+  (ends-with-p (normalize-cookie-domain (uri-host uri))
+               (normalize-cookie-domain domain)))
+
+(defun send-cookie-p (cookie uri force-ssl)
+  "Checks if the cookie COOKIE should be sent to the server
+depending on the \(PURI) URI URI and the value of FORCE-SSL \(as
+in HTTP-REQUEST)."
+  (and ;; check domain
+       (cookie-domain-matches (cookie-domain cookie) uri)
+       ;; check path
+       (starts-with-p (uri-path uri) (cookie-path cookie))
+       ;; check expiry date
+       (let ((expires (cookie-expires cookie)))
+         (or (null expires)
+             (> expires (get-universal-time))))
+       ;; check if connection must be secure       
+       (or (null (cookie-securep cookie))
+           force-ssl
+           (eq (uri-scheme uri) :https))))
+
+(defun check-cookie (cookie)
+  "Checks if the slots of the COOKIE object COOKIE have valid
+values and raises a corresponding error otherwise."
+  (with-slots (name value domain path expires)
+      cookie
+    (unless (and (stringp name) (plusp (length name)))
+      (error "Cookie name ~S must be a non-empty string." name))
+    (unless (stringp value)
+      (error "Cookie value ~S must be a non-empty string." value))
+    (unless (valid-cookie-domain-p domain)
+      (error "Invalid cookie domain ~S." domain))
+    (unless (and (stringp path) (plusp (length path)))
+      (error "Cookie path ~S must be a non-empty string." path))
+    (unless (or (null expires)
+                (and (integerp expires)
+                     (plusp expires)))
+      (error "Cookie expiry ~S should have been NIL or a universal time." expires))))
+
+(defmethod initialize-instance :after ((cookie cookie) &rest initargs)
+  "Check cookie validity after creation."
+  (declare (ignore initargs))
+  (check-cookie cookie))
+
+(defmethod (setf cookie-name) :after (new-value (cookie cookie))
+  "Check cookie validity after name change."
+  (declare (ignore new-value))
+  (check-cookie cookie))
+
+(defmethod (setf cookie-value) :after (new-value (cookie cookie))
+  "Check cookie validity after value change."
+  (declare (ignore new-value))
+  (check-cookie cookie))
+
+(defmethod (setf cookie-domain) :after (new-value (cookie cookie))
+  "Check cookie validity after domain change."
+  (declare (ignore new-value))
+  (check-cookie cookie))
+
+(defmethod (setf cookie-path) :after (new-value (cookie cookie))
+  "Check cookie validity after path change."
+  (declare (ignore new-value))
+  (check-cookie cookie))
+
+(defmethod (setf cookie-expires) :after (new-value (cookie cookie))
+  "Check cookie validity after expiry change."
+  (declare (ignore new-value))
+  (check-cookie cookie))
+
+(defun cookie= (cookie1 cookie2)
+  "Returns true if the cookies COOKIE1 and COOKIE2 are equal.
+Two cookies are considered to be equal if name and path are
+equal."
+  (and (string= (cookie-name cookie1) (cookie-name cookie2))
+       (string= (cookie-path cookie1) (cookie-path cookie2))))
+
+(defclass cookie-jar ()
+  ((cookies :initarg :cookies
+            :initform nil
+            :accessor cookie-jar-cookies
+            :documentation "A list of the cookies in this cookie jar."))
+  (:documentation "A COOKIE-JAR object is a collection of cookies."))
+
+(defmethod print-object ((cookie-jar cookie-jar) stream)
+  "Print a cookie jar, showing the number of cookies it contains."
+  (print-unreadable-object (cookie-jar stream :type t :identity t)
+    (format stream "(with ~A cookie~:P)" (length (cookie-jar-cookies cookie-jar)))))
+
+(defun parse-cookie-date (string)
+  "Parses a cookie expiry date and returns it as a Lisp universal
+time.  Currently understands the following formats:
+
+  \"Wed, 06-Feb-2008 21:01:38 GMT\"
+  \"Wed, 06-Feb-08 21:01:38 GMT\"
+  \"Tue Feb 13 08:00:00 2007 GMT\"
+  \"Wednesday, 07-February-2027 08:55:23 GMT\"
+  \"Wed, 07-02-2017 10:34:45 GMT\"
+
+Instead of \"GMT\" time zone abbreviations like \"CEST\" and UTC
+offsets like \"GMT-01:30\" are also allowed."
+  ;; it seems like everybody and their sister invents their own format
+  ;; for this, so (as there's no real standard for it) we'll have to
+  ;; make this function more flexible once we come across something
+  ;; new; as an alternative we could use net-telent-date, but it also
+  ;; fails to parse some of the stuff you encounter in the wild; or we
+  ;; could try to employ CL-PPCRE, but that'd add a new dependency
+  ;; without making this code much cleaner
+  (handler-case 
+      (let* ((last-space-pos (or (position #\Space string :test #'char= :from-end t)
+                                 (error "Can't parse cookie date ~S, no space found." string)))
+             (time-zone-string (subseq string (1+ last-space-pos)))
+             (time-zone (interpret-as-time-zone time-zone-string))
+             second minute hour day month year)
+        (dolist (part (rest (split-string (subseq string 0 last-space-pos))))
+          (when (and day month)
+            (cond ((every #'digit-char-p part)
+                   (when year
+                     (error "Can't parse cookie date ~S, confused by ~S part." string part))
+                   (setq year (parse-integer part)))
+                  ((= (count #\: part :test #'char=) 2)
+                   (let ((h-m-s (mapcar #'safe-parse-integer (split-string part ":"))))
+                     (setq hour (first h-m-s)
+                           minute (second h-m-s)
+                           second (third h-m-s))))
+                  (t (error "Can't parse cookie date ~S, confused by ~S part." string part))))
+          (cond ((null day)
+                 (unless (setq day (safe-parse-integer part))               
+                   (setq month (interpret-as-month part))))
+                ((null month)
+                 (setq month (interpret-as-month part)))))
+        (unless (and second minute hour day month year)
+          (error "Can't parse cookie date ~S, component missing." string))
+        (when (< year 100)
+          (setq year (+ year 2000)))
+        (encode-universal-time second minute hour day month year time-zone))
+    (error (condition)
+      (cond (*ignore-unparseable-cookie-dates-p*
+             (warn "~A" condition)
+             nil)
+            (t (error condition))))))
+
+(defun parse-set-cookie (string)
+  "Parses the `Set-Cookie' header line STRING and returns a list
+of three-element lists where each one contains the name of the
+cookie, the value of the cookie, and an attribute/value list for
+the optional cookie parameters."
+  (with-input-from-string (stream string)
+    (loop with *current-error-message* = (format nil "While parsing cookie header ~S:" string)
+          for first = t then nil
+          for next = (and (skip-whitespace stream)
+                          (or first (assert-char stream #\,))
+                          (skip-whitespace stream)
+                          (skip-more-commas stream))
+          for name/value = (and next (read-name-value-pair stream
+                                                           :cookie-syntax t))
+          for parameters = (and name/value (read-name-value-pairs stream
+                                                                  :value-required-p nil
+                                                                  :cookie-syntax t))
+          while name/value
+          collect (list (car name/value) (cdr name/value) parameters))))
+
+(defun get-cookies (headers uri)
+  "Returns a list of COOKIE objects corresponding to the
+`Set-Cookie' header as found in HEADERS \(an alist as returned by
+HTTP-REQUEST).  Collects only cookies which match the domain of
+the \(PURI) URI URI."
+  (loop with set-cookie-header = (header-value :set-cookie headers)
+        with parsed-cookies = (and set-cookie-header (parse-set-cookie set-cookie-header))
+        for (name value parameters) in parsed-cookies
+        for expires = (parameter-value "expires" parameters)
+        for domain = (or (parameter-value "domain" parameters) (uri-host uri))
+        when (and (valid-cookie-domain-p domain)
+                  (cookie-domain-matches domain uri))
+        collect (make-instance 'cookie
+                               :name name
+                               :value value
+                               :path (or (parameter-value "path" parameters)
+                                         (uri-path uri)
+                                         "/")
+                               :expires (and expires
+                                             (plusp (length expires))
+                                             (parse-cookie-date expires))
+                               :domain domain
+                               :securep (not (not (parameter-present-p "secure" parameters)))
+                               :http-only-p (not (not (parameter-present-p "HttpOnly" parameters))))))
+
+(defun update-cookies (new-cookies cookie-jar)
+  "Updates the cookies in COOKIE-JAR by replacing those which are
+equal to a cookie in \(the list) NEW-COOKIES with the corresponding
+`new' cookie and adding those which are really new."
+  (setf (cookie-jar-cookies cookie-jar)
+        (let ((updated-cookies
+               (loop for old-cookie in (cookie-jar-cookies cookie-jar)
+                     collect (or (find old-cookie new-cookies :test #'cookie=)
+                                 old-cookie))))
+          (union updated-cookies
+                 (set-difference new-cookies updated-cookies))))                               
+  cookie-jar)
+
+(defun delete-old-cookies (cookie-jar)
+  "Removes all cookies from COOKIE-JAR which have either expired
+or which don't have an expiry date."
+  (setf (cookie-jar-cookies cookie-jar)
+        (loop with now = (get-universal-time)
+              for cookie in (cookie-jar-cookies cookie-jar)
+              for expires = (cookie-expires cookie)
+              unless (or (null expires) (< expires now))
+              collect cookie))
+  cookie-jar)

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/doc/index.html	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,1472 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html> 
+
+<head>
+  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+  <title>DRAKMA - A Common Lisp web client</title>
+  <style type="text/css">
+  pre { padding:5px; background-color:#e0e0e0 }
+  h3, h4 { text-decoration: underline; }
+  a { text-decoration: none; padding: 1px 2px 1px 2px; }
+  a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+  a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } 
+  a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+  a.none { text-decoration: none; padding: 0; }
+  a.none:visited { text-decoration: none; padding: 0; } 
+  a.none:hover { text-decoration: none; border: none; padding: 0; } 
+  a.none:focus { text-decoration: none; border: none; padding: 0; } 
+  a.noborder { text-decoration: none; padding: 0; } 
+  a.noborder:visited { text-decoration: none; padding: 0; } 
+  a.noborder:hover { text-decoration: none; border: none; padding: 0; } 
+  a.noborder:focus { text-decoration: none; border: none; padding: 0; }  
+  pre.none { padding:5px; background-color:#ffffff }
+  </style>
+</head>
+
+<body bgcolor=white>
+
+<h2>DRAKMA - A Common Lisp web client</h2>
+
+<blockquote>
+<br>&nbsp;<br><h3><a name=abstract class=none>Abstract</a></h3>
+
+Drakma is a fully-featured web client (implemented in Common Lisp)
+that knows how to handle <a href="#chunked">HTTP/1.1
+chunking</a>, <a href="#keep-alive">persistent
+connections</a>, <a href="#re-use">re-usable
+sockets</a>, <a href="#force-ssl">SSL</a>, <a href="#cont">continuable
+uploads</a>, <a href="#form-data">file uploads</a>, <a href="#cookie-jar-param">cookies</a>, and other
+things.  And it's probably a result of
+my <a href="http://en.wikipedia.org/wiki/Not_Invented_Here">NIH
+syndrome</a>...
+<p>
+Drakma was developed and tested
+with <a href="http://www.lispworks.com/">LispWorks</a>, but it should
+also work with a couple of other Common Lisp implementations depending
+on the <a href="#download">supporting libraries</a>.  Some tests
+with <a href="http://www.sbcl.org/">SBCL</a> seem to confirm this.
+<p>
+The code comes with
+a <a
+href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
+license</a> so you can basically do with it whatever you want.
+
+<p>
+<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/drakma.tar.gz">http://weitz.de/files/drakma.tar.gz</a>.
+</blockquote>
+
+<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+  <li><a href="#example">Examples</a>
+  <li><a href="#download">Download and installation</a>
+  <li><a href="#mail">Support and mailing lists</a>
+  <li><a href="#dictionary">The Drakma dictionary</a>
+    <ol>
+      <li><a href="#request">The request</a>
+        <ol>
+          <li><a href="#http-request"><code>http-request</code></a>
+          <li><a href="#*drakma-default-external-format*"><code>*drakma-default-external-format*</code></a>
+          <li><a href="#*text-content-types*"><code>*text-content-types*</code></a>
+          <li><a href="#*body-format-function*"><code>*body-format-function*</code></a>
+          <li><a href="#*header-stream*"><code>*header-stream*</code></a>
+        </ol>
+      <li><a href="#cookies">Cookies</a>
+        <ol>
+          <li><a href="#cookie"><code>cookie</code></a>
+          <li><a href="#cookie-name"><code>cookie-name</code></a>
+          <li><a href="#cookie-value"><code>cookie-value</code></a>
+          <li><a href="#cookie-domain"><code>cookie-domain</code></a>
+          <li><a href="#cookie-path"><code>cookie-path</code></a>
+          <li><a href="#cookie-expires"><code>cookie-expires</code></a>
+          <li><a href="#cookie-securep"><code>cookie-securep</code></a>
+          <li><a href="#cookie-http-only-p"><code>cookie-http-only-p</code></a>
+          <li><a href="#cookie-jar"><code>cookie-jar</code></a>
+          <li><a href="#cookie-jar-cookies"><code>cookie-jar-cookies</code></a>
+          <li><a href="#cookie="><code>cookie=</code></a>
+          <li><a href="#delete-old-cookies"><code>delete-old-cookies</code></a>
+          <li><a href="#*ignore-unparseable-cookie-dates-p*"><code>*ignore-unparseable-cookie-dates-p*</code></a>
+        </ol>
+      <li><a href="#headers">Headers</a>
+        <ol>
+          <li><a href="#header-value"><code>header-value</code></a>
+          <li><a href="#split-tokens"><code>split-tokens</code></a>
+          <li><a href="#read-tokens-and-parameters"><code>read-tokens-and-parameters</code></a>
+          <li><a href="#parameter-present-p"><code>parameter-present-p</code></a>
+          <li><a href="#parameter-value"><code>parameter-value</code></a>
+          <li><a href="#get-content-type"><code>get-content-type</code></a>
+        </ol>
+    </ol>
+  <li><a href="#prob">Potential problems</a>
+  <li><a href="#ack">Acknowledgements</a>
+</ol>
+
+<br>&nbsp;<br><h3><a class=none name="example">Examples</a></h3>
+
+Here's an example session with Drakma&nbsp;0.3.0 which demonstrates
+some of its features.  (Some linebreaks were added or removed to
+enhance legibility.)  Note that this doesn't necessarily reflect the
+current versions of Drakma and Hunchentoot.  The examples should work
+nevertheless - kind of...
+
+<pre>
+<font color=orange>;; create a log file of this sessions</font>
+<font color=red>CL-USER 1 &gt;</font> (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/f_dribbl.htm">dribble</a> &quot;/tmp/drakma_dribble&quot;)
+; Loading C:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\ccl\dribble.ofasl on demand...
+
+<font color=orange>;; load Drakma</font>
+<font color=red>CL-USER 2 &gt;</font> (<a class=noborder href="http://www.cliki.net/asdf">asdf</a>:oos &#039;asdf:load-op :drakma)
+; loading system definition from c:\home\lisp\drakma\drakma.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\drakma\drakma.asd
+; registering #&lt;SYSTEM :DRAKMA 21D6D24F&gt; as DRAKMA
+;; Creating system COMMON-LISP-USER::DRAKMA
+; loading system definition from c:\home\lisp\<a class=noborder href="http://globalia.net/donlope/fz/songs/Chunga's_Revenge.html">chunga</a>\chunga.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\chunga\chunga.asd
+; registering #&lt;SYSTEM :CHUNGA 200B12A3&gt; as CHUNGA
+;; Creating system COMMON-LISP-USER::CHUNGA
+; loading system definition from c:\home\lisp\flexi-streams\flexi-streams.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\flexi-streams\flexi-streams.asd
+; registering #&lt;SYSTEM :FLEXI-STREAMS 200E8017&gt; as FLEXI-STREAMS
+;; Creating system COMMON-LISP-USER::FLEXI-STREAMS
+; loading system definition from c:\home\lisp\trivial-gray-streams\trivial-gray-streams.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\trivial-gray-streams\trivial-gray-streams.asd
+; registering #&lt;SYSTEM :TRIVIAL-GRAY-STREAMS 21D6741F&gt; as TRIVIAL-GRAY-STREAMS
+;; Creating system COMMON-LISP-USER::TRIVIAL-GRAY-STREAMS
+; loading system definition from c:\home\lisp\cl-base64-3.3.2\cl-base64.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\cl-base64-3.3.2\cl-base64.asd
+; registering #&lt;SYSTEM CL-BASE64 21D6D277&gt; as CL-BASE64
+;; Creating system COMMON-LISP-USER::CL-BASE64
+; registering #&lt;SYSTEM CL-BASE64-TESTS 2009701B&gt; as CL-BASE64-TESTS
+;; Creating system COMMON-LISP-USER::CL-BASE64-TESTS
+; loading system definition from c:\home\lisp\puri-1.5\puri.asd into
+; #&lt;The ASDF0 package, 0/16 internal, 0/16 external&gt;
+; Loading text file c:\home\lisp\puri-1.5\puri.asd
+; registering #&lt;SYSTEM PURI 21D6B093&gt; as PURI
+;; Creating system COMMON-LISP-USER::PURI
+; registering #&lt;SYSTEM PURI-TESTS 200CFEEF&gt; as PURI-TESTS
+;; Creating system COMMON-LISP-USER::PURI-TESTS
+; Loading fasl file c:\home\lisp\trivial-gray-streams\package.ofasl
+; Loading fasl file c:\home\lisp\trivial-gray-streams\mixin.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\packages.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\ascii.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\iso-8859.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\code-pages.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\specials.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\util.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\external-format.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\in-memory.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\stream.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\output.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\input.ofasl
+; Loading fasl file c:\home\lisp\flexi-streams\strings.ofasl
+; Loading fasl file c:\home\lisp\chunga\packages.ofasl
+; Loading fasl file c:\home\lisp\chunga\specials.ofasl
+; Loading fasl file c:\home\lisp\chunga\util.ofasl
+; Loading fasl file c:\home\lisp\chunga\read.ofasl
+; Loading fasl file c:\home\lisp\chunga\streams.ofasl
+; Loading fasl file c:\home\lisp\chunga\input.ofasl
+; Loading fasl file c:\home\lisp\chunga\output.ofasl
+; Loading fasl file c:\home\lisp\cl-base64-3.3.2\package.ofasl
+; Loading fasl file c:\home\lisp\cl-base64-3.3.2\encode.ofasl
+; Loading fasl file c:\home\lisp\cl-base64-3.3.2\decode.ofasl
+; Loading fasl file c:\home\lisp\puri-1.5\src.ofasl
+; Loading fasl file c:\home\lisp\drakma\packages.ofasl
+; Loading fasl file c:\home\lisp\drakma\specials.ofasl
+; Loading fasl file c:\home\lisp\drakma\util.ofasl
+; Loading c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\comm-defsys.lisp on demand...
+;; Creating system COMM
+
+;  Loading text file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\comm-pkg.lisp
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\sockets.ofasl
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-constants.ofasl
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-foreign-types.ofasl
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl.ofasl
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\load-on-demand\processes\ssl-certs.ofasl
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0001.ofasl
+; Loaded public patch COMM 1.1
+
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0002.ofasl
+; Loaded public patch COMM 1.2
+
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0003.ofasl
+; Loaded public patch COMM 1.3
+
+;  Loading fasl file c:\Program Files\LispWorks\lib\5-0-0-0\patches\comm\0001\0004.ofasl
+; Loaded public patch COMM 1.4
+
+; Loading fasl file c:\home\lisp\drakma\read.ofasl
+; Loading fasl file c:\home\lisp\drakma\cookies.ofasl
+; Loading fasl file c:\home\lisp\drakma\request.ofasl
+NIL
+
+<font color=orange>;; create a package to work in</font>
+<font color=red>CL-USER 3 &gt;</font> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_defpkg.htm" class=noborder>defpackage</a> :drakma-user (:use :cl :drakma))
+#&lt;The DRAKMA-USER package, 0/16 internal, 0/16 external&gt;
+
+<font color=orange>;; switch to this package</font>
+<font color=red>CL-USER 4 &gt;</font> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_in_pkg.htm" class=noborder>in-package</a> :drakma-user)
+#&lt;The DRAKMA-USER package, 0/16 internal, 0/16 external&gt;
+
+<font color=orange>;; log headers, so we can see what happens -
+;; output to <a class=noborder href="#*header-stream*"><code><font color=orange>*HEADER-STREAM*</font></code></a> will be shown in <font color=green>green</font> below</font>
+<font color=red>DRAKMA-USER 5 &gt;</font> (setq <a class=noborder href="#*header-stream*">*header-stream*</a> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_debug_.htm" class=noborder>*standard-output*</a>)
+#&lt;Broadcast stream to (#&lt;Echo Stream Input = #&lt;EDITOR::RUBBER-STREAM #&lt;EDITOR:BUFFER CAPI interactive-pane 2&gt; 2198ECD7&gt;,
+                                     Output = #&lt;STREAM::LATIN-1-FILE-STREAM c:\tmp\drakma_dribble&gt;&gt;
+                       #&lt;EDITOR::RUBBER-STREAM #&lt;EDITOR:BUFFER CAPI interactive-pane 2&gt; 2198ECD7&gt;)&gt;
+
+<font color=orange>;; note how Drakma automatically follows the 301 redirect and how the fourth return value shows the <em>new</em> URI</font>
+<font color=red>DRAKMA-USER 6 &gt;</font> (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://lisp.org/" class=noborder>http://lisp.org/</a>&quot;)
+<font color=green>GET / HTTP/1.1
+Host: lisp.org
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 301  Moved Permanently
+Date: Sat, 26 Aug 2006 15:46:31 GMT
+Connection: Close
+Server: <a href="http://opensource.franz.com/aserve/" class=noborder>AllegroServe</a>/1.2.37
+Transfer-Encoding: chunked
+LOCATION: /index.html
+
+GET /index.html HTTP/1.1
+Host: lisp.org
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200  OK
+Date: Sat, 26 Aug 2006 15:46:32 GMT
+Connection: Close
+Server: AllegroServe/1.2.37
+Content-Type: text/html
+Content-Length: 82
+LAST-MODIFIED: Mon, 16 Feb 2004 09:30:02 GMT</font>
+
+&quot;&lt;title&gt;redirect...&lt;/title&gt;
+&lt;meta http-equiv=\&quot;Refresh\&quot; content=\&quot;0; url=/alu/home\&quot;&gt;
+&quot;
+200
+((:DATE . &quot;Sat, 26 Aug 2006 15:46:32 GMT&quot;)
+ (:CONNECTION . &quot;Close&quot;)
+ (:SERVER . &quot;AllegroServe/1.2.37&quot;)
+ (:CONTENT-TYPE . &quot;text/html&quot;)
+ (:CONTENT-LENGTH . &quot;82&quot;)
+ (:LAST-MODIFIED . &quot;Mon, 16 Feb 2004 09:30:02 GMT&quot;))
+#&lt;URI http://lisp.org/index.html&gt;
+#&lt;FLEXI-STREAMS:FLEXI-IO-STREAM 201017D3&gt;
+T
+
+<font color=orange>;; here, Drakma automatically interprets the 'charset=utf-8' part correctly -
+;; might look a bit different in your listener depending on the font you've chosen</font>
+<font color=red>DRAKMA-USER 7 &gt;</font> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_subseq.htm" class=noborder>subseq</a> (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://www.cl.cam.ac.uk/~mgk25/ucs/examples/digraphs.txt" class=noborder>http://www.cl.cam.ac.uk/~mgk25/ucs/examples/digraphs.txt</a>&quot;) 0 298)
+<font color=green>GET /~mgk25/ucs/examples/digraphs.txt HTTP/1.1
+Host: www.cl.cam.ac.uk
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 16:02:56 GMT
+Server: Apache/1.3.37 (Unix) mod_ucam_webauth/1.2.2
+Last-Modified: Thu, 05 Jan 2006 20:49:55 GMT
+ETag: &quot;17cd62-298-43bd8673&quot;
+Accept-Ranges: bytes
+Content-Length: 664
+Connection: close
+Content-Type: text/plain; charset=utf-8</font>
+
+&quot;Latin Digraphs and Ligatures in ISO10646-1
+
+A short table of ligatures and digraphs follows. Some of these may not be
+ligatures/digraphs in the technical sense, (for example, ? is a seperate
+letter in English), but visually they behave that way.
+
+A?E : U+00C6
+a?e : U+00E6
+&#x17F;?s : U+00DF
+I&#x132;J : U+0132&quot;
+
+<font color=orange>;; a vector of octets is returned for (non-text) binary data - a picture in this case</font>
+<font color=red>DRAKMA-USER 8 &gt;</font> (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://zappa.com/favicon.ico" class=noborder>http://zappa.com/favicon.ico</a>&quot;)
+<font color=green>GET /favicon.ico HTTP/1.1
+Host: zappa.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 16:02:59 GMT
+Server: Apache/2.0.46 (Red Hat)
+Last-Modified: Fri, 17 Mar 2006 08:11:07 GMT
+ETag: &quot;3a4080-b6-59d5bcc0&quot;
+Accept-Ranges: bytes
+Content-Length: 182
+Connection: close
+Content-Type: image/gif</font>
+
+#(71 73 70 56 57 97 17 0 17 0 179 1 0 150 151 153 255 255 255 37 37 36 112 114 115
+  201 202 204 0 0 0 80 83 84 26 28 26 230 231 231 249 249 249 12 13 14 219 221 222
+  18 21 22 239 240 241 52 52 54 64 66 66 33 249 4 1 0 0 1 0 44 0 0 0 0 17 0 17 0 0
+  4 99 48 200 73 107 109 54 172 101 129 120 196 180 12 12 51 80 64 161 42 3 48 28
+  170 106 72 141 16 223 120 113 166 121 95 0 14 95 239 33 236 41 98 10 129 114 185
+  188 29 127 25 201 224 73 60 4 8 0 130 22 59 64 52 96 135 148 35 96 80 152 159 186
+  192 64 183 112 0 200 61 65 0 1 192 76 214 185 113 102 241 88 26 90 8 81 18 8 94 
+  130 134 22 17 0 59)
+200
+((:DATE . &quot;Sat, 26 Aug 2006 16:02:59 GMT&quot;)
+ (:SERVER . &quot;Apache/2.0.46 (Red Hat)&quot;)
+ (:LAST-MODIFIED . &quot;Fri, 17 Mar 2006 08:11:07 GMT&quot;)
+ (:ETAG . &quot;\&quot;3a4080-b6-59d5bcc0\&quot;&quot;)
+ (:ACCEPT-RANGES . &quot;bytes&quot;)
+ (:CONTENT-LENGTH . &quot;182&quot;)
+ (:CONNECTION . &quot;close&quot;)
+ (:CONTENT-TYPE . &quot;image/gif&quot;))
+#&lt;URI http://zappa.com/favicon.ico&gt;
+#&lt;FLEXI-STREAMS:FLEXI-IO-STREAM 200D59BF&gt;
+T
+
+<font color=orange>;; a secure connection (see <a class=noborder href="#download"><font color=orange>below</font></a>) -
+;; also note that the server uses <a class=noborder name="chunked" href="http://www.rfc.net/rfc2616.html#s3.6.1"><font color=orange>chunked transfer encoding</font></a> for its reply</font>
+<font color=red>DRAKMA-USER 9 &gt;</font> (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#scan-to-strings">scan-to-strings</a> &quot;(?s)You have.*your data.&quot;
+                                       (<a class=noborder href="#http-request">http-request</a> &quot;<a href="https://www.fortify.net/cgi/ssl_2.pl" class=noborder>https://www.fortify.net/cgi/ssl_2.pl</a>&quot;))
+<font color=green>GET /cgi/ssl_2.pl HTTP/1.1
+Host: www.fortify.net
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 16:10:06 GMT
+Server: Apache
+Connection: close
+Transfer-Encoding: chunked
+Content-Type: text/html</font>
+
+
+&quot;You have connected to this web server using the DHE-RSA-AES256-SHA encryption cipher
+ with a key length of 256 bits.
+ &lt;p&gt;
+ This is a high-grade encryption connection, regarded by most experts as being suitable
+ for sending or receiving even the most sensitive or valuable information
+ across a network.
+ &lt;p&gt;
+ In a crude analogy, using this cipher is similar to sending or storing your data inside
+ a high quality safe - compared to an export-grade cipher which is similar to using
+ a paper envelope to protect your data.&quot;
+#()
+
+<font color=orange>;; using a different 'User-Agent' header</font>
+<font color=red>DRAKMA-USER 10 &gt;</font> (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#regex-replace-all">regex-replace-all</a>
+                  &quot;&lt;.*?&gt;&quot;
+                  (<a class=noborder href="http://weitz.de/cl-ppcre/">ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#scan-to-strings">scan-to-strings</a> &quot;(?s)Your browser reports.*?&lt;/table&gt;&quot; 
+                                         (<a class=noborder href="#http-request">http-request</a> &quot;<a class=noborder href="http://bcheck.scanit.be/bcheck/">http://bcheck.scanit.be/bcheck/</a>&quot;
+                                                       :user-agent :explorer))
+                  &quot;&quot;)
+<font color=green>GET /bcheck/ HTTP/1.1
+Host: bcheck.scanit.be
+User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 16:21:50 GMT
+Server: Apache
+Connection: close
+Transfer-Encoding: chunked
+Content-Type: text/html</font>
+
+
+&quot;Your browser reports to be:
+
+Browser name: MSIE
+Version: 6.0
+Platform: Windows NT 5.1
+&quot;
+
+<font color=orange>;; sending parameters in a POST request and working with <a href="#cookie" class=noborder><font color=orange>cookies</font></a> -
+;; note how Drakma sends the cookie back in the second request</font>
+<font color=red>DRAKMA-USER 11 &gt;</font> (let ((cookie-jar (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_ins.htm" class=noborder>make-instance</a> &#039;<a class=noborder href="#cookie-jar">cookie-jar</a>)))
+                   (<a class=noborder href="#http-request">http-request</a> &quot;<a class=noborder href="http://www.phpsecurepages.com/test/test.php">http://www.phpsecurepages.com/test/test.php</a>&quot;
+                                 :method :post
+                                 :parameters &#039;((&quot;entered_login&quot; . &quot;test&quot;)
+                                               (&quot;entered_password&quot; . &quot;test&quot;))
+                                 :cookie-jar cookie-jar)
+                   (<a class=noborder href="#http-request">http-request</a> &quot;<a class=noborder href="http://www.phpsecurepages.com/test/test2.php">http://www.phpsecurepages.com/test/test2.php</a>&quot;
+                                 :cookie-jar cookie-jar)
+                   (<a class=noborder href="#cookie-jar-cookies">cookie-jar-cookies</a> cookie-jar))
+<font color=green>POST /test/test.php HTTP/1.1
+Host: www.phpsecurepages.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Content-Length: 40
+Content-Type: application/x-www-form-urlencoded
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 18:26:17 GMT
+Server: Apache/2.0.51 (Fedora)
+X-Powered-By: PHP/4.3.10
+Expires: Thu, 19 Nov 1981 08:52:00 GMT
+Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0
+Pragma: no-cache
+Set-Cookie: PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4; path=/
+Connection: close
+Transfer-Encoding: chunked
+Content-Type: text/html
+
+
+GET /test/test2.php HTTP/1.1
+Host: www.phpsecurepages.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Cookie: PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 18:26:18 GMT
+Server: Apache/2.0.51 (Fedora)
+X-Powered-By: PHP/4.3.10
+Expires: Thu, 19 Nov 1981 08:52:00 GMT
+Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0
+Pragma: no-cache
+Connection: close
+Transfer-Encoding: chunked
+Content-Type: text/html</font>
+
+
+(#&lt;<a href="#cookie" class=noborder>COOKIE</a> PHPSESSID=3ce33aa3e326ab4bf5da7feecc3248b4; path=/; domain=www.phpsecurepages.com&gt;)
+
+<font color=orange>;; now we are going to <a name="re-use" class=noborder>re-use</a> a socket for the second connection to the same server
+;; this will also work with chunked encoding</font>
+<font color=red>DRAKMA-USER 12 &gt;</font> (let ((stream (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 4 (<a class=noborder href="#http-request">http-request</a> &quot;<a class=noborder href="http://www.lispworks.com/">http://www.lispworks.com/</a>&quot; :close nil))))
+                   (nth-value 2 (<a class=noborder href="#http-request">http-request</a> &quot;<a class=noborder href="http://www.lispworks.com/success-stories/index.html">http://www.lispworks.com/success-stories/index.html</a>&quot;
+                                              :stream stream)))
+<font color=green>GET / HTTP/1.1
+Host: www.lispworks.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 18:34:20 GMT
+Server: Apache/1.3.37 Ben-SSL/1.57 (Unix)
+Last-Modified: Tue, 08 Aug 2006 18:20:49 GMT
+ETag: &quot;28ee4f0-22db-44d8d601&quot;
+Accept-Ranges: bytes
+Content-Length: 8923
+Content-Type: text/html
+
+GET /success-stories/index.html HTTP/1.1
+Host: www.lispworks.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Date: Sat, 26 Aug 2006 18:34:20 GMT
+Server: Apache/1.3.37 Ben-SSL/1.57 (Unix)
+Last-Modified: Tue, 08 Aug 2006 18:22:19 GMT
+ETag: &quot;28f3f42-2325-44d8d65b&quot;
+Accept-Ranges: bytes
+Content-Length: 8997
+Connection: close
+Content-Type: text/html</font>
+
+((:DATE . &quot;Sat, 26 Aug 2006 18:34:20 GMT&quot;)
+ (:SERVER . &quot;Apache/1.3.37 Ben-SSL/1.57 (Unix)&quot;)
+ (:LAST-MODIFIED . &quot;Tue, 08 Aug 2006 18:22:19 GMT&quot;)
+ (:ETAG . &quot;\&quot;28f3f42-2325-44d8d65b\&quot;&quot;)
+ (:ACCEPT-RANGES . &quot;bytes&quot;)
+ (:CONTENT-LENGTH . &quot;8997&quot;)
+ (:CONNECTION . &quot;close&quot;)
+ (:CONTENT-TYPE . &quot;text/html&quot;))
+
+<font color=orange>;; testing basic authorization against a local <a href="http://weitz.de/hunchentoot/" class=noborder><font color=orange>Hunchentoot</font></a> server</font>
+<font color=red>DRAKMA-USER 13 &gt;</font> (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 1 (<a class=noborder href="#http-request">http-request</a> &quot;http://localhost:4242/<a class=noborder href="http://weitz.de/tbnl/#test">tbnl/test</a>/authorization.html&quot;))
+<font color=green>GET /tbnl/test/authorization.html HTTP/1.1
+Host: localhost:4242
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 401 Authorization Required
+Content-Length: 563
+Content-Type: text/html; charset=iso-8859-1
+Date: Sat, 26 Aug 2006 18:38:58 GMT
+Server: <a class=noborder href="http://weitz.de/hunchentoot/">Hunchentoot</a> 0.1.5 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.10.0)
+Connection: Close
+WWW-Authenticate: Basic realm=&quot;TBNL&quot;</font>
+
+401
+
+<font color=red>DRAKMA-USER 14 &gt;</font> (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 1 (<a class=noborder href="#http-request">http-request</a> &quot;http://localhost:4242/<a class=noborder href="http://weitz.de/tbnl/#test">tbnl/test</a>/authorization.html&quot;
+                                            :basic-authorization &#039;(&quot;nanook&quot; &quot;igloo&quot;)))
+<font color=green>GET /tbnl/test/authorization.html HTTP/1.1
+Host: localhost:4242
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Authorization: Basic bmFub29rOmlnbG9v
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Content-Length: 884
+Content-Type: text/html; charset=iso-8859-1
+Date: Sat, 26 Aug 2006 18:39:19 GMT
+Server: <a class=noborder href="http://weitz.de/hunchentoot/">Hunchentoot</a> 0.1.5 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.10.0)
+Connection: Close</font>
+
+200
+
+<font color=orange>;; now we ask Drakma to return a stream and read from it directly</font>
+<font color=red>DRAKMA-USER 15 &gt;</font> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/s_let_l.htm" class=noborder>let</a> ((stream (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://www.jalat.com/blogs/lisp?id=3" class=noborder>http://www.jalat.com/blogs/lisp?id=3</a>&quot; 
+                                             :want-stream t)))
+                   (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/06_a.htm" class=noborder>loop</a> for i below 41
+                         for line = (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_rd_lin.htm" class=noborder>read-line</a> stream)
+                         when (&gt; i 35)
+                         do (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_stg.htm" class=noborder>write-line</a> line))
+                   (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_close.htm" class=noborder>close</a> stream)
+                   (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/a_values.htm" class=noborder>values</a>))
+<font color=green>GET /blogs/lisp?id=3 HTTP/1.1
+Host: www.jalat.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+
+HTTP/1.1 200 OK
+Content-Length: 21453
+Content-Type: text/html; charset=iso-8859-1
+Date: Sat, 26 Aug 2006 19:53:37 GMT
+Server: <a href="http://weitz.de/hunchentoot/" class=noborder>Hunchentoot</a> 0.1.3 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.9.7)
+Connection: Close</font>
+
+Bill Clementson has &lt;a
+href=&quot;<a href="http://bc.tech.coop/blog/041111.html" class=noborder>http://bc.tech.coop/blog/041111.html</a>&quot;&gt;written&lt;/a&gt; about getting
+<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> up and running with <a href="http://httpd.apache.org/" class=noborder>apache</a> and <a href="http://www.fractalconcept.com/asp/html/mod_lisp.html" class=noborder>mod_lisp</a>. In this example I&#039;m
+going to use &lt;a href=&quot;<a href="http://weitz.de/hunchentoot/" class=noborder>http://weitz.de/hunchentoot/</a>&quot;&gt;hunchentoot&lt;/a&gt;, a
+pure lisp web server by (again) Edi Weitz.
+
+<font color=orange><a class=noborder name="cont">;; let's test a POST request without content length and with chunked transfer encoding -</a>
+;; we build the content in several steps using different types of data
+;; (note: doesn't work anymore, probably due to server changes)</font>
+<font color=red>DRAKMA-USER 16 &gt;</font> (let ((temp-file (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_ensu_1.htm" class=noborder>ensure-directories-exist</a> #p&quot;/tmp/quux.txt&quot;))
+                       (continuation (<a href="#http-request" class=noborder>http-request</a> &quot;<a href="http://meme.b9.com/login.html" class=noborder>http://meme.b9.com/login.html</a>&quot;
+                                                   :method :post
+                                                   :content :continuation)))
+                   (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_funcal.htm" class=noborder>funcall</a> continuation &quot;username=&quot; t)
+                   (funcall continuation (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_list_.htm" class=noborder>list</a> (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_char_c.htm" class=noborder>char-code</a> #\n) (char-code #\a)) t)
+                   (funcall continuation (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_lambda.htm" class=noborder>lambda</a> (stream)
+                                           (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_cha.htm" class=noborder>write-char</a> #\n stream)) t)
+                   (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_w_open.htm" class=noborder>with-open-file</a> (out temp-file
+                                        :direction :output
+                                        :if-does-not-exist :create
+                                        :if-exists :supersede)
+                     (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_wr_stg.htm" class=noborder>write-string</a> &quot;ook&quot; out))
+                   (funcall continuation temp-file t)
+                   (<a href="http://weitz.de/cl-ppcre/" class=noborder>ppcre</a>:<a href="http://weitz.de/cl-ppcre/#scan-to-strings" class=noborder>scan-to-strings</a> &quot;(?i)[a-z ]+nanook[a-z .]+&quot;
+                                          (funcall continuation &quot;&amp;password=igloo&quot;)))
+<font color=green>POST /login.html HTTP/1.1
+Host: meme.b9.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+Content-Type: application/x-www-form-urlencoded
+Transfer-Encoding: chunked
+
+HTTP/1.0 200 OK
+Date: Sat, 02 Sep 2006 00:25:24 GMT
+Connection: close
+Server: AllegroServe/1.2.45
+Content-Type: text/html
+Content-Length: 2922
+PRAGMA: no-cache
+CACHE-CONTROL: no-cache
+SET-COOKIE: meme=1834b91d26f9be983a0ed9ca; path=/</font>
+
+&quot;The username nanook is not in our database.&quot;
+#()
+
+<font color=orange>;; finally, we send additional headers to ask for a <a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder><font color=orange>range</font></a></font>
+<font color=red>DRAKMA-USER 17 &gt;</font> (<a href="http://weitz.de/cl-ppcre/" class=noborder>ppcre</a>:<a class=noborder href="http://weitz.de/cl-ppcre/#regex-replace-all">regex-replace-all</a>
+                  &quot;&lt;.*?&gt;&quot;
+                  (<a href="http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" class=noborder>format</a> nil &quot;~A~A&quot;
+                          (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://users.cableaz.com/~lantz/pages/hunchentoot.html" class=noborder>http://users.cableaz.com/~lantz/pages/hunchentoot.html</a>&quot;
+                                        :additional-headers &#039;((&quot;<a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder>Range</a>&quot; . &quot;bytes=959-999&quot;)))
+                          (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://users.cableaz.com/~lantz/pages/hunchentoot.html" class=noborder>http://users.cableaz.com/~lantz/pages/hunchentoot.html</a>&quot;
+                                        :additional-headers &#039;((&quot;<a href="http://www.rfc.net/rfc2616.html#s14.35" class=noborder>Range</a>&quot; . &quot;bytes=1165-1201&quot;))))
+                  &quot;&quot;)
+<font color=green>GET /~lantz/pages/hunchentoot.html HTTP/1.1
+Host: users.cableaz.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+Range: bytes=959-999
+
+HTTP/1.1 206 Partial Content
+Date: Sat, 26 Aug 2006 19:07:44 GMT
+Server: Apache/2.0.16 (Unix)
+Last-Modified: Sun, 24 Apr 2005 04:08:45 GMT
+ETag: &quot;35298d-2fea-d8f4cd40&quot;
+Accept-Ranges: bytes
+Content-Length: 41
+Content-Range: bytes 959-999/12266
+Content-Type: text/html; charset=ISO-8859-1
+Connection: close
+
+GET /~lantz/pages/hunchentoot.html HTTP/1.1
+Host: users.cableaz.com
+User-Agent: Drakma/0.3.0 (LispWorks 5.0.0; Windows NT; Windows XP: 5.1 (build 2600) Service Pack 2; http://weitz.de/drakma/)
+Accept: */*
+Connection: close
+Range: bytes=1165-1201
+
+HTTP/1.1 206 Partial Content
+Date: Sat, 26 Aug 2006 19:07:45 GMT
+Server: Apache/2.0.16 (Unix)
+Last-Modified: Sun, 24 Apr 2005 04:08:45 GMT
+ETag: &quot;35298d-2fea-d8f4cd40&quot;
+Accept-Ranges: bytes
+Content-Length: 37
+Content-Range: bytes 1165-1201/12266
+Content-Type: text/html; charset=ISO-8859-1
+Connection: close</font>
+
+&quot;<a href="http://weitz.de/drakma/" class=noborder>DRAKMA</a> (Queen of Cosmic Greed)
+<a href="http://weitz.de/hunchentoot/" class=noborder>HUNCHENTOOT</a> (The Giant Spider)&quot;
+</pre>
+
+<br>&nbsp;<br><h3><a class=none name="download">Download and installation</a></h3>
+
+Drakma together with this documentation can be downloaded
+from <a
+href="http://weitz.de/files/drakma.tar.gz">http://weitz.de/files/drakma.tar.gz</a>.
+The current version is 0.11.3.  Drakma can be installed
+via <a href="http://www.cliki.net/asdf">ASDF</a> and depends on the
+open source
+libraries <a href="http://www.cliki.net/cl-base64">CL-BASE64</a> (use
+3.3.2 or higher to avoid an unneeded dependency
+on <a
+href="http://www.cliki.net/kmrcl">KMRCL</a>), <a
+href="http://www.cliki.net/Puri">Puri</a>, and <a href="http://weitz.de/chunga/">Chunga</a>.  If
+you're <em>not</em> using LispWorks, you'll also
+need <a
+href="http://www.cliki.net/usocket">usocket</a> (0.3.2 or newer)
+and (except for <a href="http://franz.com/products/allegrocl/">AllegroCL</a>) <a href="http://common-lisp.net/project/cl-plus-ssl/">CL+SSL</a>.
+Try to use the <b>newest</b> versions of all these libraries - use the CVS
+versions if in doubt.  Installation
+via <a href="http://www.cliki.net/asdf-install">asdf-install</a>
+should also be possible, and
+there's a port for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo
+Linux</a> thanks to Matthew Kennedy.
+<p>
+For <a
+href="http://en.wikipedia.org/wiki/Secure_Sockets_Layer">SSL</a>, you
+will need to
+have <a
+href="http://www.lispworks.com/documentation/lw50/LWUG/html/lwuser-344.htm">the
+corresponding C libraries</a> as well.  You'll usually have them
+already unless you're on Windows.
+<p>
+Lu&iacute;s Oliveira maintains a <a href="http://darcs.net/">darcs</a>
+repository of Drakma
+at <a
+href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>.
+<p>
+A <a href="http://www.selenic.com/mercurial/wiki/">Mercurial</a>
+repository of older versions is available
+at <a
+href="http://arcanes.fr.eu.org/~pierre/2007/02/weitz/">http://arcanes.fr.eu.org/~pierre/2007/02/weitz/</a>
+thanks to Pierre Thierry.
+
+<br>&nbsp;<br><h3><a name="mail" class=none>Support and mailing lists</a></h3>
+
+For questions, bug reports, feature requests, improvements, or patches
+please use the <a
+href="http://common-lisp.net/mailman/listinfo/drakma-devel">drakma-devel
+mailing list</a>. If you want to be notified about future releases
+subscribe to the <a
+href="http://common-lisp.net/mailman/listinfo/drakma-announce">drakma-announce
+mailing list</a>. These mailing lists were made available thanks to
+the services of <a href="http://common-lisp.net/">common-lisp.net</a>.
+<p>
+If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
+
+
+<br>&nbsp;<br><h3><a class=none name="dictionary">The Drakma dictionary</a></h3>
+
+<h4><a name="request" class=none>The request</a></h4>
+
+The <a href="#http-request"><code>HTTP-REQUEST</code></a> function is
+the heart of Drakma.  It is used to send requests to web servers and
+will either return the message body of the server's reply or (if the
+user so wishes) a stream one can read from.  The wealth of keyword
+parameters might look a bit intimidating first, but you will rarely
+need more than two or three of them - the default behaviour of Drakma
+is (hopefully) designed to do The Right Thing[TM] in most cases.
+<p>
+You can use
+the <a href="#*header-stream*"><code>*HEADER-STREAM*</code></a>
+variable to debug requests handled by Drakma in a way similar
+to <a href="http://livehttpheaders.mozdev.org/">LiveHTTPHeaders</a>.
+
+<!-- Entry for HTTP-REQUEST -->
+
+<p><br><table border=0><tr><td colspan=4 valign=top>[Function]</td></tr><tr><td valign=top style="white-space:nowrap"><a class=none name='http-request'><b>http-request</b></a>&nbsp;</td><td valign=top><i><a class=none href="#uri">uri</a>&nbsp;</i></td><td valign=top><tt>&amp;key</tt>&nbsp;</td><td><i><a class=none href="#protocol">protocol</a> <a class=none href="#method">method</a> <a class=none href="#force-ssl">force-ssl</a> <a class=none href="#parameters">parameters</a> <a class=none href="#form-data">form-data</a> <a class=none href="#content">content</a> <a class=none href="#content-length">content-length</a> <a class=none href="#content-type">content-type</a> <a class=none href="#cookie-jar-param">cookie-jar</a> <a class=none href="#basic-authorization">basic-authorization</a> <a class=none href="#user-agent">user-agent</a> <a class=none href="#accept">accept</a> <a class=none href="#proxy">proxy</a> <a class=none href="#proxy-basic-authorization">proxy-basic-authorization</a> <a class=none href="#additional-headers">additional-headers</a> <a class=none href="#redirect">redirect</a> <a class=none href="#redirect-methods">redirect-methods</a> <a class=none href="#auto-referer">auto-referer</a> <a class=none href="#keep-alive">keep-alive</a> <a class=none href="#close">close</a> <a class=none href="#external-format-out">external-format-out</a> <a class=none href="#external-format-in">external-format-in</a> <a class=none href="#force-binary">force-binary</a> <a class=none href="#want-stream">want-stream</a> <a class=none href="#stream">stream</a> <a class=none href="#connection-timeout">connection-timeout</a> <a class=none href="#read-timeout">read-timeout</a> <a class=none href="#write-timeout">write-timeout</a></i></td></tr><tr><td colspan=2></td><td colspan=2 valign=top> =&gt; <i>body-or-stream, status-code, headers, uri, stream, <a class=none href="#must-close">must-close</a>, reason-phrase</i></td></tr></table>
+<blockquote><br>
+
+Sends an <a href="http://www.rfc.net/rfc2616.html">HTTP</a> request to a web server and returns its reply.
+<a class=none name="uri"><code><i>uri</i></code></a> is where the
+request is sent to, and it is either a string denoting
+a <a
+href="http://en.wikipedia.org/wiki/Uniform_Resource_Identifier">uniform
+resource identifier</a> or
+a <a href="http://www.cliki.net/Puri"><code>PURI:URI</code></a>
+object.  The scheme of <code><i>uri</i></code> must be 'http' or
+'https'.  The function returns <em>seven</em> values - the body of the
+reply (but see below), the status code as an integer,
+an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a>
+of the headers sent by the server where for each element
+the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a>
+(the name of the header) is a keyword and
+the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a>
+(the value of the header) is a string, the URI the reply comes from
+(which might be different from the URI the request was sent to in case
+of <a href="#redirect">redirects</a>), the stream the reply was read
+from,
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean">generalized
+boolean</a> which denotes whether the stream should be closed (and
+which you can usually ignore), and finally the reason phrase from the
+status line as a string.
+<p>
+<a class=none name="protocol"><code><i>protocol</i></code></a> is the HTTP protocol which is going to be used in the
+<a href="http://www.rfc.net/rfc2616.html#s5.1">request line</a>, it must be one of the keywords <code>:HTTP/1.0</code> or
+<code>:HTTP/1.1</code> (the default).  <a class=none
+name="method"><code><i>method</i></code></a> is the method used in the
+request line,
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/t_kwd.htm">keyword</a>
+(like <code>:GET</code> or <code>:HEAD</code>) denoting a
+valid <a href="http://rfc.net/rfc2616.html">HTTP/1.1</a>
+or <a href="http://www.webdav.org/">WebDAV</a> request method.
+Additionally, you can also use the pseudo method <code>:OPTIONS*</code> which is like
+<code>:OPTIONS</code> but means that an "<code>OPTIONS&nbsp;*</code>"
+request line will be sent, i.e. the URI's path and query parts will be
+ignored.
+<p>
+If <a class=none
+name="force-ssl"><code><i>force-ssl</i></code></a> is true,
+<a href="http://en.wikipedia.org/wiki/Secure_Sockets_Layer">SSL</a>
+will be <a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-24.htm">attached</a> to the socket stream which connects Drakma with the
+web server.  Usually, you don't have to provide this argument, as SSL
+will be attached anyway if the scheme of <code><i>uri</i></code> is 'https'.
+<p>
+<a class=none name="parameters"><code><i>parameters</i></code></a> is
+an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a>
+of name/value pairs
+(the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#car">car</a>
+and
+the <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cdr">cdr</a>
+each being a string) which denotes the parameters which are added to
+the query part of the URI or (in the case of a POST request) comprise
+the request body.  (But
+see <a href="#content"><code><i>content</i></code></a> below.)  The
+name/value pairs
+are <a
+href="http://www.blooberry.com/indexdot/html/topics/urlencoding.htm">URL-encoded</a>
+using the external format <a class=none
+name="external-format-out"><code><i>external-format-out</i></code></a>
+before they are sent to the server, <em>unless</em> <a class=none
+name="form-data"><code><i>form-data</i></code></a> is true in which
+case the POST request body is sent
+as <a
+href="http://www.ietf.org/rfc/rfc2388.txt"><code>multipart/form-data</code></a>
+using
+<code><i>external-format-out</i></code>.  The values of
+the <code><i>parameters</i></code> alist can also be pathnames, unary
+functions, open binary input streams, or lists where the first element
+is of one of the former types.  These values denote files which should
+be sent as part of the request body, i.e. if such file designators are
+present in <code><i>parameters</i></code>, the content type of the
+request is <em>always</em> <code>multipart/form-data</code>.  If the
+value denoting a file is a list, the part of the list behind the first
+element is treated as
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#plist">plist</a>
+which can be used to optionally specify a content type (the default is
+"application/octet-stream") and/or a filename (the default is the
+result of
+applying <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_namest.htm"><code>FILE-NAMESTRING</code></a>
+to the pathname) for the file.  So, for example, a full file upload
+request could look like this:
+<pre>
+(http-request "http://www.whatever.com/file_upload/"
+              :method :post
+              <font color=orange>;; the following line is only needed if the receiving server doesn't accept
+              ;; chunked transfer encoding (like for example Apache 1.x)</font>
+              <a class=noborder href="#content-length2">:content-length</a> t
+              :parameters '(("file1" #p"/tmp/top_secret_stuff.doc" :content-type "application/msword" :filename "upload.doc")
+                            ("file2" . #p"/tmp/portrait.jpg")
+                            ("lname" . "Duck") ("fname" . "Donald")))
+</pre>
+<p>
+<code><i>external-format-out</i></code> (the default is the value of <a href="#*drakma-default-external-format*"><code>*DRAKMA-DEFAULT-EXTERNAL-FORMAT*</code></a>) must be the name of a <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a> <a href="http://weitz.de/flexi-streams/#external-formats">external
+format</a>.
+<p><a class=none name="content"><code><i>content</i></code></a>, if not <code>NIL</code>, is
+used as the request body - <code><i>parameters</i></code> is ignored
+in this case.  <code><i>content</i></code> can be a string, a
+sequence of octets, a pathname, an open binary input stream, or a
+<a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm">function
+designator</a>.  If <code><i>content</i></code> is a sequence, it will
+be directly sent to the server (using <code><i>external-format-out</i></code> in the case of strings).  If <code><i>content</i></code> is a
+pathname, the binary contents of the corresponding file will be sent
+to the server.  If <code><i>content</i></code> is a stream, everything
+that can be read from the stream
+until <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/e_end_of.htm">EOF</a>
+will be sent to the server.  If <code><i>content</i></code> is a
+function designator, the corresponding function will be called with
+one argument, the stream to the server, to which it should send data.
+<p>
+Finally, <code><i>content</i></code> can also be the
+keyword <code>:CONTINUATION</code> in which
+case <a href="#http-request"><code>HTTP-REQUEST</code></a> returns
+only one value - a "continuation" function.  This function has one
+required argument and one optional argument.  The first argument will
+be interpreted like <code><i>content</i></code> above (but it cannot
+be a keyword), i.e. it will be sent to the server according to its
+type.  If the second argument is true, the continuation function can
+be called again to send more content, if it is <code>NIL</code>, the
+continuation function returns
+what <a href="#http-request"><code>HTTP-REQUEST</code></a> would have
+returned.  See <a href="#cont">above</a> for an
+example on how to use a continuation function and different types of
+content.
+<p>
+If <code><i>content</i></code> is a sequence, Drakma will
+use <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_length.htm"><code>LENGTH</code></a>
+to determine its length and will use the result for the
+'Content-Length' header sent to the server.  You can overwrite this
+with the <a class=none
+name="content-length"><code><i>content-length</i></code></a> parameter
+(a non-negative integer) which you can also use for the cases where
+Drakma can't or won't determine the content length itself.  You can
+also explicitly provide a <code><i>content-length</i></code> argument
+of <code>NIL</code> which will imply that no 'Content-Length' header
+will be sent even if Drakma could compute the value.  If no
+'Content-Length' header is sent, Drakma will
+use <a href="http://weitz.de/chunga/">chunked encoding</a> to send the
+content body.  Note that this will not work with some older web
+servers.
+<p>
+<a class=none name="content-length2">A non-<code>NIL</code> <code><i>content-length</i></code> argument</a>
+means that Drakma <em>must</em> build the request body in RAM and
+compute the content length even if it would have otherwise used
+chunked encoding - for example in the case of file uploads.  A special
+case is the value <code>T</code>
+for <code><i>content-length</i></code> which means that Drakma should
+compute the content length after building the request body.
+<p>
+<a class=none name="content-type"><code><i>content-type</i></code></a> is the
+corresponding 'Content-Type' header to be sent and will be ignored
+unless <code><i>content</i></code> is provided as well.
+<p>
+Note that a
+query already contained in <code><i>uri</i></code> will always be sent
+with the request line anyway in addition to other parameters sent by
+Drakma.
+<p>
+<a class=none name="cookie-jar-param"><code><i>cookie-jar</i></code></a> is a <a href="#cookie-jar">cookie
+jar</a> containing cookies which will potentially be sent to the
+server (if the domain matches, if they haven't expired, etc.) - this
+cookie jar will be modified according to the 'Set-Cookie' header(s)
+sent back by the server.
+<p>
+<a class=none name="basic-authorization"><code><i>basic-authorization</i></code></a>, if not <code>NIL</code>,
+should be a list of two strings (username and password) which will be
+sent to the server for basic
+authorization.  <a class=none name="user-agent"><code><i>user-agent</i></code></a>, if
+not <code>NIL</code>, denotes which 'User-Agent' header will be sent
+with the request.  It can be one of the keywords <code>:DRAKMA</code>
+(the
+default), <code>:FIREFOX</code>, <code>:EXPLORER</code>, <code>:OPERA</code>,
+or
+<code>:SAFARI</code> which denote the current version of Drakma or, in
+the latter four cases, a fixed string corresponding to a more or less
+recent (as of August 2006) version of the corresponding browser.  Or
+it can be a string which is used
+directly.  <a class=none name="accept"><code><i>accept</i></code></a>, if not <code>NIL</code>, is the
+'Accept' header sent - the default is <code>"*/*"</code>.
+<p>
+If <a class=none name="proxy"><code><i>proxy</i></code></a> is not <code>NIL</code>, it should be a
+string denoting
+a <a href="http://en.wikipedia.org/wiki/Proxy_server">proxy server</a>
+through which the request should be sent.  Or it can be a list of two
+values - a string denoting the proxy server and an integer denoting
+the port to use (which will default to 80 otherwise).
+<a class=none name="proxy-basic-authorization"><code><i>proxy-basic-authorization</i></code></a> is used like <code><i>basic-authorization</i></code>, but for
+the proxy, and only if <code><i>proxy</i></code> is true.
+<p>
+<a class=none name="additional-headers"><code><i>additional-headers</i></code></a> is a
+name/value <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a>
+(like <code><i>parameters</i></code>) of additional HTTP headers which
+should be sent with the request.
+<p>
+If <a name="redirect" class=none><code><i>redirect</i></code></a> is
+not <code>NIL</code>, it must be a non-negative integer
+or <code>T</code>.  If <code><i>redirect</i></code> is true, Drakma
+will follow redirects (return codes 301, 302, 303, or 307)
+unless <code><i>redirect</i></code> is <code>0</code>.
+If <code><i>redirect</i></code> is an integer, it will be decreased
+by&nbsp;<code>1</code> with each redirect.  Drakma will only follow
+redirects if <code><i>method</i></code> is a member of the list <a name="redirect-methods" class=none><code><i>redirect-methods</i></code></a> the
+initial value of which is <code>(:GET :HEAD)</code>.
+Furthermore, if <a name="auto-referer"><code><i>auto-referer</i></code></a> is true when following redirects,
+Drakma will populate the 'Referer' (sic!) header with the URI that
+triggered the redirection, overwriting an existing 'Referer'
+header (in <a href="#additional-headers"><code><i>additional-headers</i></code></a>) if necessary.
+<p>
+If <a name="keep-alive" class=none><code><i>keep-alive</i></code></a> is <code>T</code>, the server will
+be asked to keep the connection alive, i.e. not to close it after the
+reply has been sent.  (Note that
+this <a href="http://www.rfc.net/rfc2616.html#s8.1">not necessary</a>
+if both the client and the server use HTTP 1.1.)
+If <a class=none name="close"><code><i>close</i></code></a> is <code>T</code>, the server is
+explicitly asked to close the connection after the reply has been
+sent.  <code><i>keep-alive</i></code> and <code><i>close</i></code>
+are obviously mutually
+exclusive.  The default for <code><i>close</i></code> is <code>T</code>, the default for <code><i>keep-alive</i></code> is <code>NIL</code>.
+<p>
+<a href="#http-request"><code>HTTP-REQUEST</code></a> will always
+<a class=none name="close-stream">close the stream</a> to the server before it returns unless
+<code><i>want-stream</i></code> is true or if the headers exchanged
+between Drakma and the server determine that the connection will be
+kept alive - for example if both client and server used the
+HTTP&nbsp;1.1 protocol and no
+explicit <code>"Connection:&nbsp;close"</code> header was sent.  In
+these cases <em>you</em> will have to close the stream manually.
+<p>
+If the message body sent by the server has a
+text <a href="http://www.rfc.net/rfc2616.html#s14.17">content
+type</a>, Drakma will try to return it as a Lisp string.
+It'll first check if the 'Content-Type' header denotes an encoding
+(charset) to be used, or otherwise it will use the <a class=none
+name="external-format-in"><code><i>external-format-in</i></code></a>
+(the default is the value
+of <a href="#*drakma-default-external-format*"><code>*DRAKMA-DEFAULT-EXTERNAL-FORMAT*</code></a>)
+argument.  The body is decoded
+using <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a>.  If
+FLEXI-STREAMS doesn't know the external format, the body is returned
+as an array of octets.  If the message body doesn't have a text
+content type or if
+<a class=none name="force-binary"><code><i>force-binary</i></code></a>
+is true, the body is always returned as an array of octets.  (But
+see <a href="#*text-content-types*"><code>*TEXT-CONTENT-TYPES*</code></a>
+and <a href="#*body-format-function*"><code>*BODY-FORMAT-FUNCTION*</code></a>.)
+<p>
+If <a class=none
+name="want-stream"><code><i>want-stream</i></code></a> is true, the
+message body is <em>not</em> read and instead the (open) socket stream
+is returned as the first return value.  If the sixth return value
+(<a class=none name="must-close"><code><i>must-close</i></code></a>)
+of <a href="#http-request"><code>HTTP-REQUEST</code></a> is true,
+Drakma deduced from the reply headers that the server will close the
+stream on its side, so you can't re-use it - you'll have to close it
+instead.  Of course, no matter what the sixth return value is, it's
+alway your responsibility to <a href="#close-stream">close the stream</a> once you're done with
+it.  The
+stream returned is a <a href="http://weitz.de/flexi-streams/">flexi
+stream</a> with a <a href="http://weitz.de/chunga/">chunked stream</a>
+as its underlying stream.
+<p>
+Drakma will usually
+create <a
+href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-35.htm">a
+new socket connection</a> for each HTTP request.  However, you can use
+the <a class=none name="stream"><code><i>stream</i></code></a> argument to provide an open socket stream which should be
+re-used instead.  <code><i>stream</i></code> <em>must</em> be a stream returned by a previous invocation of
+<a href="#http-request"><code>HTTP-REQUEST</code></a> where the sixth return value wasn't true.  Obviously, it
+must also be connected to the correct server and at the right position
+(i.e. the message body, if any, must have been read).  Drakma will
+<em>never</em> attach SSL to a stream provided as the <code><i>stream</i></code> argument.
+<p>
+<a class=none name="connection-timeout"><code><i>connection-timeout</i></code></a> is the time (in seconds) Drakma
+will wait until it considers an attempt to connect to a server as a
+failure.  <a class=none name="read-timeout"><code><i>read-timeout</i></code></a>
+and <a class=none name="write-timeout"><code><i>write-timeout</i></code></a> are the read and write timeouts
+(in seconds) for the socket stream to the server.  All three timeout
+arguments can also be <code>NIL</code> (meaning no timeout), and they
+don't apply if an existing stream is re-used.  All timeout keyword
+arguments are only available for
+LispWorks, <code><i>write-timeout</i></code> is only available for
+LispWorks&nbsp;5.0 or higher.
+
+</blockquote>
+
+<!-- End of entry for HTTP-REQUEST -->
+
+
+
+<!-- Entry for *DRAKMA-DEFAULT-EXTERNAL-FORMAT* -->
+
+<p><br>[Special variable]<br><a class=none name='*drakma-default-external-format*'><b>*drakma-default-external-format*</b></a>
+<blockquote><br>
+
+The default value for the two external format keyword arguments of
+<a href="#http-request"><code>HTTP-REQUEST</code></a>.  The value of
+this variable will be interpreted
+by <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a>.  The
+initial value is the keyword <code>:LATIN-1</code>.  (Note that Drakma
+binds <a
+href="http://weitz.de/flexi-streams/#*default-eol-style*"><code>*DEFAULT-EOL-STYLE*</code></a>
+to <code>:LF</code>.)
+
+</blockquote>
+
+<!-- End of entry for *DRAKMA-DEFAULT-EXTERNAL-FORMAT* -->
+
+
+<!-- Entry for *TEXT-CONTENT-TYPES* -->
+
+<p><br>[Special variable]<br><a class=none name='*text-content-types*'><b>*text-content-types*</b></a>
+<blockquote><br>
+
+A list of conses which are used by the default value of <a href="#*body-format-function*"><code>*BODY-FORMAT-FUNCTION*</code></a> to decide
+whether a 'Content-Type' header denotes text content.  The car and cdr
+of each cons should each be a string or <code>NIL</code>.  A content type matches
+one of these entries (and thus denotes text) if the type part is
+<a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stgeq_.htm"><code>STRING-EQUAL</code></a>
+to the car or if the car is <code>NIL</code> and if the subtype part
+is <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stgeq_.htm"><code>STRING-EQUAL</code></a>
+to the cdr or if the cdr is <code>NIL</code>.
+<p>
+The initial value of this variable is the list
+<pre>
+(("text" . nil))
+</pre>
+which means that every content type that starts with "text/" is
+regarded as text, no matter what the subtype is.
+
+</blockquote>
+
+<!-- End of entry for *TEXT-CONTENT-TYPES* -->
+
+<!-- Entry for *BODY-FORMAT-FUNCTION* -->
+
+<p><br>[Special variable]<br><a class=none name='*body-format-function*'><b>*body-format-function*</b></a>
+<blockquote><br>
+
+A function which determines whether the content body returned by the
+server is text and should be treated as such or not.  The function is
+called after the request <a href="#headers">headers</a> have been read
+and it must accept two arguments, <code><i>headers</i></code>
+and <code><i>external-format-in</i></code>, where <code><i>headers</i></code> is like the
+third return value of <a href="#http-request"><code>HTTP-REQUEST</code></a> while <code><i>external-format-in</i></code> is the
+<a href="#http-request"><code>HTTP-REQUEST</code></a> argument of the
+same name.  It should return <code>NIL</code> if the body should be
+regarded as binary content, or
+a <a href="http://weitz.de/flexi-streams/">FLEXI-STREAMS</a> external
+format (which will be used to read the body) otherwise.
+<p>
+This function will only be called if
+the <a href="#force-binary"><code><i>force-binary</i></code></a>
+argument to <a href="#http-request"><code>HTTP-REQUEST</code></a> is <code>NIL</code>.
+<p>
+The initial value of this variable is a function which uses
+<a href="#*text-content-types*"><code>*TEXT-CONTENT-TYPES*</code></a>
+to determine whether the body is text and then proceeds as described
+in the <a href="#http-request"><code>HTTP-REQUEST</code></a>
+documentation entry.
+
+</blockquote>
+
+<!-- End of entry for *BODY-FORMAT-FUNCTION* -->
+
+<!-- Entry for *HEADER-STREAM* -->
+
+<p><br>[Special variable]<br><a class=none name='*header-stream*'><b>*header-stream*</b></a>
+<blockquote><br>
+
+If this variable is not <code>NIL</code>, it should be bound to a
+stream to which incoming and outgoing headers will be written for
+debugging purposes.
+
+</blockquote>
+
+<!-- End of entry for *HEADER-STREAM* -->
+
+<h4><a name="cookies" class=none>Cookies</a></h4>
+
+<a href="#http-request"><code>HTTP-REQUEST</code></a> can deal
+with <a href="http://en.wikipedia.org/wiki/HTTP_cookie">cookies</a> if
+it gets a <a href="#cookie-jar"><em>cookie jar</em></a>, a collection
+of <a href="#cookie"><code>COOKIE</code></a> objects, as
+its <a href="#cookie-jar-param"><code><i>cookie-jar</i></code></a> argument.  Cookies sent by the web
+server will be added to the cookie jar (or updated) if appropriate and
+cookies already in the cookie jar will be sent to the server together
+with the request.
+<p>
+Drakma will <em>never</em> remove cookies from a cookie jar
+automatically - you have to do it manually
+using <a
+href="#delete-old-cookies"><code>DELETE-OLD-COOKIES</code></a>.
+
+<!-- Entry for COOKIE -->
+
+<p><br>[Standard class]<br><a class=none name='cookie'><b>cookie</b></a>
+<blockquote><br>
+
+Elements of this class
+represent <a href="http://en.wikipedia.org/wiki/HTTP_cookie">HTTP
+cookies</a>.  If you need to create your own cookies, you should
+use <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_ins.htm"><code>MAKE-INSTANCE</code></a>
+with the
+initargs <code>:NAME</code>, <code>:DOMAIN</code>, <code>:VALUE</code>, <code>:PATH</code>, <code>:EXPIRES</code>,
+<code>:SECUREP</code>, and <code>:HTTP-ONLY-P</code> all of which are
+optional except for the first two.  The meaning of these initargs
+and <a href="#cookie-name">the corresponding accessors</a> should be
+pretty clear if one looks at
+the <a href="http://wp.netscape.com/newsref/std/cookie_spec.html">original
+cookie specification</a> (and
+at <a href="http://msdn2.microsoft.com/en-us/library/ms533046.aspx">this
+page</a> for the <code>HttpOnly</code> extension).
+
+<pre>
+<font color=red>DRAKMA-USER 18 &gt;</font> (make-instance 'cookie :name "Foo" 
+                                        :value "Bar"
+                                        :expires (+ (get-universal-time) 3600)
+                                        :domain ".weitz.de")
+#&lt;COOKIE Foo=Bar; expires=Sat, 26-08-2006 23:14:27 GMT; path=/; domain=.weitz.de&gt;
+</pre>
+
+</blockquote>
+
+<!-- End of entry for COOKIE -->
+
+
+<p><br>[Specialized accessors]<br><a name="cookie-name" class=none><b>cookie-name</b> <i>(cookie cookie)</i> =&gt; <i>name</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-name</b> <i>(cookie cookie)</i><tt>)</tt> <i>name</i><tt>)</tt></a>
+<br><a name="cookie-value" class=none><b>cookie-value</b> <i>(cookie cookie)</i> =&gt; <i>value</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-value</b> <i>(cookie cookie)</i><tt>)</tt> <i>value</i><tt>)</tt></a>
+<br><a name="cookie-domain" class=none><b>cookie-domain</b> <i>(cookie cookie)</i> =&gt; <i>domain</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-domain</b> <i>(cookie cookie)</i><tt>)</tt> <i>domain</i><tt>)</tt></a>
+<br><a name="cookie-path" class=none><b>cookie-path</b> <i>(cookie cookie)</i> =&gt; <i>path</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-path</b> <i>(cookie cookie)</i><tt>)</tt> <i>path</i><tt>)</tt></a>
+<br><a name="cookie-expires" class=none><b>cookie-expires</b> <i>(cookie cookie)</i> =&gt; <i>expiry</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-expires</b> <i>(cookie cookie)</i><tt>)</tt> <i>expiry</i><tt>)</tt></a>
+<br><a name="cookie-securep" class=none><b>cookie-securep</b> <i>(cookie cookie)</i> =&gt; <i>securep</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-securep</b> <i>(cookie cookie)</i><tt>)</tt> <i>securep</i><tt>)</tt></a>
+<br><a name="cookie-http-only-p" class=none><b>cookie-http-only-p</b> <i>(cookie cookie)</i> =&gt; <i>http-only-p</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-http-only-p</b> <i>(cookie cookie)</i><tt>)</tt> <i>http-only-p</i><tt>)</tt></a>
+<blockquote><br>
+
+These
+are <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessors</a>
+to get and set the corresponding slots of
+a <a href="#cookie"><code>COOKIE</code></a> object.  Note that <code><i>expiry</i></code> is a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/25_adb.htm">universal time</a>
+and <code><i>securep</i></code> and <code><i>http-only-p</i></code> are <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_g.htm#generalized_boolean">generalized
+booleans</a>.  All other values are strings.
+
+</blockquote>
+
+<!-- Entry for COOKIE-JAR -->
+
+<p><br>[Standard class]<br><a class=none name='cookie-jar'><b>cookie-jar</b></a>
+<blockquote><br>
+
+An object of this class encapsulates a collection (a list, actually)
+of <a href="#cookie"><code>COOKIE</code></a> objects.  You create a
+new cookie jar with
+<code>(MAKE-INSTANCE&nbsp;'COOKIE-JAR)</code>
+where you can optionally provide a list
+of <a href="#cookie"><code>COOKIE</code></a> objects with
+the <code>:COOKIES</code> initarg.  The cookies in a cookie jar are
+accessed
+with <a
+href="#cookie-jar-cookies"><code>COOKIE-JAR-COOKIES</code></a>.
+
+</blockquote>
+
+<!-- End of entry for COOKIE-JAR -->
+
+
+<!-- Entry for COOKIE-JAR-COOKIES -->
+
+<p><br>[Specialized accessor]<br><a name="cookie-jar-cookies" class=none><b>cookie-jar-cookies</b> <i>(cookie-jar cookie-jar)</i> =&gt; <i>list</i></a>
+<br><a class=none><tt>(setf (</tt><b>cookie-jar-cookies</b> <i>(cookie-jar cookie-jar)</i><tt>)</tt> <i>list</i><tt>)</tt></a>
+<blockquote><br>
+
+This <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#accessor">accessor</a>
+is used to get and set the cookies comprised in a cookie
+jar.  <code><i>list</i></code> is a list
+of <a href="#cookie"><code>COOKIE</code></a> objects.
+<p>
+Note that <code><i>list</i></code> should not contain two cookies which are equal according to <a href="#cookie="><code>COOKIE=</code></a>.
+
+</blockquote>
+
+<!-- End of entry for COOKIE-JAR-COOKIES -->
+
+
+<!-- Entry for COOKIE= -->
+
+<p><br>[Function]<br><a class=none name='cookie='><b>cookie=</b> <i>cookie1 cookie2</i> =&gt; <i>result</i></a>
+<blockquote><br>
+
+Returns <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#true">true</a>
+if the cookies <code><i>cookie1</i></code>
+and <code><i>cookie2</i></code> are equal.  Two cookies are considered
+to be equal if their <a href="#cookie-name">names</a> and <a href="#cookie-path">paths</a> are equal.
+
+</blockquote>
+
+<!-- End of entry for COOKIE= -->
+
+
+<!-- Entry for DELETE-OLD-COOKIES -->
+
+<p><br>[Function]<br><a class=none name='delete-old-cookies'><b>delete-old-cookies</b> <i>cookie-jar</i> =&gt; <i>cookie-jar</i></a>
+<blockquote><br>
+
+Removes all cookies from the <a href="#cookie-jar">cookie
+jar</a> <code><i>cookie-jar</i></code> which have either expired or
+which don't have an expiry date.
+
+</blockquote>
+
+<!-- End of entry for DELETE-OLD-COOKIES -->
+
+
+<!-- Entry for *IGNORE-UNPARSEABLE-COOKIE-DATES-P* -->
+
+<p><br>[Special variable]<br><a class=none name='*ignore-unparseable-cookie-dates-p*'><b>*ignore-unparseable-cookie-dates-p*</b></a>
+<blockquote><br>
+
+Whether Drakma is allowed to treat <code>Expires</code> dates in
+cookie headers as non-existent if it can't parse them.  If the value
+of this variable is <code>NIL</code> (which is the default), an error
+will be signalled instead.
+<p>
+Note that Drakma tries hard to parse every date representation its
+author has so far seen in the wild.  As everybody and their sister
+seems to invent their own format, this feels like an uphill battle,
+though.  Nevertheless, if you're confronted with something Drakma
+can't parse, report it to the <a href="#mail">mailing list</a> and set
+this variable to a true value only as a temporary workaround.
+
+</blockquote>
+
+<!-- End of entry for *IGNORE-UNPARSEABLE-COOKIE-DATES-P* -->
+
+<h4><a name="headers" class=none>Headers</a></h4>
+
+This section assembles a couple of convenience functions which can be
+used to access information returned as the third
+value (<code><i>headers</i></code>)
+of <a href="#http-request"><code>HTTP-REQUEST</code></a>.
+<p>
+Note that if the header
+sends <a href="http://www.rfc.net/rfc2616.html#s4.2">multiple headers
+with the same name</a>, these are comprised into one entry by
+<a href="#http-request"><code>HTTP-REQUEST</code></a> where the values
+are separated by commas.
+
+<!-- Entry for HEADER-VALUE -->
+
+<p><br>[Function]<br><a class=none name='header-value'><b>header-value</b> <i>name headers</i> =&gt; <i>value</i></a>
+<blockquote><br>
+
+If <code><i>headers</i></code> is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of headers as returned by <a href="#http-request"><code>HTTP-REQUEST</code></a>
+and <code><i>name</i></code> is a keyword naming a header, this function returns the
+corresponding value of this header (or <code>NIL</code> if it's not in
+<code><i>headers</i></code>).
+<pre>
+<font color=red>DRAKMA-USER 19 &gt;</font> (setq <a href="#*header-stream*" class=noborder>*header-stream*</a> nil)
+NIL
+<font color=red>DRAKMA-USER 20 &gt;</font> (header-value :server
+                               (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 2 (<a class=noborder href="#http-request">http-request</a> &quot;<a href="http://www.jalat.com/blogs/lisp?id=5" class=noborder>http://www.jalat.com/blogs/lisp?id=5</a>&quot;)))
+&quot;<a href="http://weitz.de/" class=noborder>Hunchentoot</a> 0.1.3 (<a href="http://weitz.de/tbnl/" class=noborder>TBNL</a> 0.9.7)&quot;
+</pre>
+
+</blockquote>
+
+<!-- End of entry for HEADER-VALUE -->
+
+<!-- Entry for SPLIT-TOKENS -->
+
+<p><br>[Function]<br><a class=none name='split-tokens'><b>split-tokens</b> <i>string</i> =&gt; <i>string-list</i></a>
+<blockquote><br>
+
+Splits the string <code><i>string</i></code> into a list of substrings separated
+by commas and optional whitespace.  Empty substrings are
+ignored.
+<pre>
+<font color=red>DRAKMA-USER 21 &gt;</font> (split-tokens "chunked, identity")
+("chunked" "identity")
+</pre>
+
+</blockquote>
+
+<!-- End of entry for SPLIT-TOKENS -->
+
+
+<!-- Entry for READ-TOKENS-AND-PARAMETERS -->
+
+<p><br>[Function]<br><a class=none name='read-tokens-and-parameters'><b>read-tokens-and-parameters</b> <i>string <tt>&amp;key</tt> value-required-p</i> =&gt; <i>list</i></a>
+<blockquote><br>
+
+Reads a comma-separated list
+of <a href="http://www.rfc.net/rfc2616.html#s2.2">tokens</a> from the
+string <code><i>string</i></code>.  Each token can be followed by an
+optional, semicolon-separated list
+of <a href="http://www.rfc.net/rfc2616.html#s3.6">attribute/value
+pairs</a> where the attributes are tokens followed by
+a <code>#\=</code> character and a token or
+a <a href="http://www.rfc.net/rfc2616.html#s2.2">quoted string</a>.
+Returned is a list where each element is either a string (for a simple
+token) or
+a <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#cons">cons</a>
+of a string (the token) and
+an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a>
+(the attribute/value pairs).  If <code><i>value-required-p</i></code>
+is <code>NIL</code> (the default is <code>T</code>), the value part
+(including the <code>#\=</code> character) of each attribute/value
+pair is optional.
+<p>
+An example of an HTTP header which uses a syntax which can be parsed
+with this function is the 'Transfer-Encoding' header.
+<pre>
+<font color=red>DRAKMA-USER 21 &gt;</font> (read-tokens-and-parameters "iso-8859-5, unicode-1-1;q=0.8")
+("iso-8859-5" ("unicode-1-1" ("q" . "0.8")))
+</pre>
+
+</blockquote>
+
+<!-- End of entry for READ-TOKENS-AND-PARAMETERS -->
+
+<!-- Entry for PARAMETER-PRESENT-P -->
+
+<p><br>[Function]<br><a class=none name='parameter-present-p'><b>parameter-present-p</b> <i>name parameters</i> =&gt; <i>generalized-boolean</i></a>
+<blockquote><br>
+
+If <code><i>parameters</i></code> is
+an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a>
+of parameters (i.e. of attribute/value pairs) as returned by, for
+example, <a href="#read-tokens-and-parameters"><code>READ-TOKENS-AND-PARAMETERS</code></a> and <code><i>name</i></code> is a string naming a
+parameter, this function returns the full parameter (name and value) -
+or <code>NIL</code> if it's not in <code><i>parameters</i></code>.
+<pre>
+<font color=red>DRAKMA-USER 23 &gt;</font> (parameter-present-p "frob" '(("charset" . "latin-1") ("frob" . "quux")))
+("frob" . "quux")
+
+<font color=red>DRAKMA-USER 24 &gt;</font> (parameter-present-p "foo" '(("charset" . "latin-1") ("frob" . "quux")))
+NIL
+</pre>
+</blockquote>
+
+<!-- End of entry for PARAMETER-PRESENT-P -->
+
+
+<!-- Entry for PARAMETER-VALUE -->
+
+<p><br>[Function]<br><a class=none name='parameter-value'><b>parameter-value</b> <i>name parameters</i> =&gt; <i>value</i></a>
+<blockquote><br>
+
+If <code><i>parameters</i></code> is an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of parameters (i.e. of attribute/value pairs) as returned by, for
+example, <a href="#read-tokens-and-parameters"><code>READ-TOKENS-AND-PARAMETERS</code></a> and <code><i>name</i></code> is a string naming a
+parameter, this function returns the value of this parameter - or
+<code>NIL</code> if it's not in <code><i>parameters</i></code>.
+<pre>
+<font color=red>DRAKMA-USER 25 &gt;</font> (parameter-value "frob" '(("charset" . "latin-1") ("frob" . "quux")))
+"quux"
+
+<font color=red>DRAKMA-USER 26 &gt;</font> (parameter-value "foo" '(("charset" . "latin-1") ("frob" . "quux")))
+NIL
+</pre>
+</blockquote>
+
+<!-- End of entry for PARAMETER-VALUE -->
+
+<!-- Entry for GET-CONTENT-TYPE -->
+
+<p><br>[Function]<br><a class=none name='get-content-type'><b>get-content-type</b> <i>headers</i> =&gt; <i>type, subtype, parameters</i></a>
+<blockquote><br>
+
+Reads and parses a 'Content-Type' header and returns it as
+three values - the type, the subtype, and an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> (possibly
+empty) of name/value pairs for the optional parameters.  <code><i>headers</i></code>
+is supposed to be an <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of HTTP headers as returned by
+<a href="#http-request"><code>HTTP-REQUEST</code></a>.  Returns <code>NIL</code> if there is no 'Content-Type' header amongst
+<code><i>headers</i></code>.
+<pre>
+<font color=red>DRAKMA-USER 27 &gt;</font> (get-content-type 
+                  (<a class=noborder href="http://www.lispworks.com/documentation/HyperSpec/Body/m_nth_va.htm">nth-value</a> 2 (<a href="#http-request" class=noborder>http-request</a> &quot;<a href="http://weitz.de/" class=noborder>http://weitz.de/</a>&quot;)))
+"text"
+"html"
+(("charset" . "iso-8859-1"))
+</pre>
+</blockquote>
+
+<!-- End of entry for GET-CONTENT-TYPE -->
+
+<br>&nbsp;<br><h3><a class=none name="prob">Potential problems</a></h3>
+
+Some web servers (notably <a href="http://paulgraham.com/">Paul Graham</a>'s
+<a
+href="http://paulgraham.com/arc.html">Arc</a> <a
+href="http://common-lisp.net/pipermail/drakma-devel/2007-April/000116.html">web
+server</a>
+and <a
+href="http://common-lisp.net/pipermail/drakma-devel/2007-May/000135.html">some
+very old ones</a>) use wrong line endings when sending the HTTP
+headers.  By default, Drakma won't be able to understand them, but
+see <a
+href="http://weitz.de/chunga/">Chunga</a>'s <a
+href="http://weitz.de/chunga/#*accept-bogus-eols*"><code>*ACCEPT-BOGUS-EOLS*</code></a>.
+
+
+<br>&nbsp;<br><h3><a class=none name="ack">Acknowledgements</a></h3>
+
+Initial versions of Drakma used code
+from <a href="http://www.cliki.net/ACL-COMPAT">ACL-COMPAT</a>,
+specifically the chunking code from Jochen Schmidt.  (This has been replaced by <a href="http://weitz.de/chunga/">Chunga</a>.)
+The API of
+Drakma's <a href="#http-request"><code>HTTP-REQUEST</code></a> was
+inspired by John
+Foderaro's <a
+href="http://opensource.franz.com/aserve/aserve-dist/doc/aserve.html#f-do-http-request"><code>DO-HTTP-REQUEST</code></a>.
+And greetings to Bob Hutchinson who
+already <a
+href="http://recursive.ca/hutch/index.php?p=278">anticipated this
+library in 2005</a>... :)
+
+<p>
+This documentation was prepared with <a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>.
+</p>
+<p>
+$Header: /usr/local/cvsrep/drakma/doc/index.html,v 1.83 2008/01/14 18:51:40 edi Exp $
+<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
+
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/drakma.asd	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,60 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/drakma.asd,v 1.46 2008/01/14 18:51:38 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+#+:lispworks
+(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream)
+  (pushnew :lw-does-not-have-write-timeout *features*))
+
+(defpackage :drakma-asd
+  (:use :cl :asdf))
+
+(in-package :drakma-asd)
+
+(defvar *drakma-version-string* "0.11.3"
+  "Drakma's version number as a string.")
+
+;; we export its name so we can import it later
+(export '*drakma-version-string*)
+
+(defsystem :drakma
+  :serial t
+  :version #.*drakma-version-string*
+  :components ((:file "packages")
+               (:file "specials")
+               (:file "util")
+               (:file "read")
+               (:file "cookies")
+               (:file "request"))
+  :depends-on (:puri
+               :cl-base64
+               :chunga
+               #-:lispworks :usocket
+               #-(or :lispworks :allegro) :cl+ssl))

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/packages.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,59 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/packages.lisp,v 1.22 2008/01/14 01:57:01 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-user)
+
+(defpackage :drakma
+  (:use :cl :puri :flexi-streams :chunga)
+  ;; the variable defined in the ASDF system definition
+  (:import-from :drakma-asd :*drakma-version-string*)
+  (:export :*body-format-function*
+           :*drakma-default-external-format*
+           :*header-stream*
+           :*ignore-unparseable-cookie-dates-p*
+           :*text-content-types*
+           :cookie
+           :cookie-domain
+           :cookie-expires
+           :cookie-http-only-p
+           :cookie-jar
+           :cookie-jar-cookies
+           :cookie-name
+           :cookie-path
+           :cookie-securep
+           :cookie-value
+           :cookie=
+           :delete-old-cookies
+           :get-content-type
+           :header-value
+           :http-request
+           :parameter-present-p
+           :parameter-value
+           :read-tokens-and-parameters
+           :split-tokens))

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/read.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,127 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/read.lisp,v 1.15 2008/01/14 01:57:01 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :drakma)
+
+(defmacro ignore-eof (&body body)
+  "This macro is similar to IGNORE-ERRORS but it only ignores
+conditions of type END-OF-FILE."
+  `(handler-case
+       (progn , at body)
+     (end-of-file () nil)))
+
+(defun read-status-line (stream &optional log-stream)
+  "Reads one line from STREAM \(using Chunga's READ-LINE*) and
+interprets it as a HTTP status line.  Returns a list of two or
+three values - the protocol \(HTTP version) as a keyword, the
+status code as an integer, and optionally the reason phrase."
+  (let* ((*current-error-message* "While reading status line:")
+         (line (read-line* stream log-stream))
+         (first-space-pos (or (position #\Space line :test #'char=)
+                              (error "No space in status line ~S." line)))
+         (second-space-pos (position #\Space line
+                                     :test #'char=
+                                     :start (1+ first-space-pos))))
+    (list (cond ((string-equal line "HTTP/1.0" :end1 first-space-pos) :http/1.0)
+                ((string-equal line "HTTP/1.1" :end1 first-space-pos) :http/1.1)
+                (t (error "Unknown protocol in ~S." line)))
+          (or (ignore-errors (parse-integer line
+                                            :start (1+ first-space-pos)
+                                            :end second-space-pos))
+              (error "Status code in ~S is not an integer." line))
+          (and second-space-pos (subseq line (1+ second-space-pos))))))
+
+(defun get-content-type (headers)
+  "Reads and parses a `Content-Type' header and returns it as
+three values - the type, the subtype, and an alist \(possibly
+empty) of name/value pairs for the optional parameters.  HEADERS
+is supposed to be an alist of headers as returned by
+HTTP-REQUEST.  Returns NIL if there is no such header amongst
+HEADERS."
+  (when-let (content-type (header-value :content-type headers))
+    (with-input-from-string (stream content-type)
+      (let* ((*current-error-message* "Corrupted Content-Type header:")
+             (type (read-token stream))
+             (subtype (and (assert-char stream #\/)
+                           (read-token stream)))
+             (parameters (read-name-value-pairs stream)))
+        (values type subtype parameters)))))
+
+(defun read-token-and-parameters (stream)
+  "Reads and returns \(as a two-element list) from STREAM a token
+and an optional list of parameters \(attribute/value pairs)
+following the token."
+  (skip-whitespace stream)
+  (list (read-token stream)
+        (read-name-value-pairs stream)))
+
+(defun skip-more-commas (stream)
+  "Reads and consumes from STREAM any number of commas and
+whitespace.  Returns the following character or NIL in case of
+END-OF-FILE."
+  (loop while (eql (ignore-eof (peek-char nil stream)) #\,)
+        do (read-char stream) (skip-whitespace stream))
+  (skip-whitespace stream))
+
+(defun read-tokens-and-parameters (string &key (value-required-p t))
+  "Reads a comma-separated list of tokens from the string STRING.
+Each token can be followed by an optional, semicolon-separated
+list of attribute/value pairs where the attributes are tokens
+followed by a #\\= character and a token or a quoted string.
+Returned is a list where each element is either a string \(for a
+simple token) or a cons of a string \(the token) and an alist
+\(the attribute/value pairs).  If VALUE-REQUIRED-P is NIL, the
+value part \(including the #\\= character) of each attribute/value
+pair is optional."
+  (with-input-from-string (stream string)
+    (loop with *current-error-message* = (format nil "While parsing ~S:" string)
+          for first = t then nil
+          for next = (and (skip-whitespace stream)
+                          (or first (assert-char stream #\,))
+                          (skip-whitespace stream)
+                          (skip-more-commas stream))
+          for token = (and next (read-token stream))
+          for parameters = (and token
+                                (read-name-value-pairs stream
+                                                       :value-required-p value-required-p))
+          while token
+          collect (if parameters (cons token parameters) token))))
+
+(defun split-tokens (string)
+  "Splits the string STRING into a list of substrings separated
+by commas and optional whitespace.  Empty substrings are
+ignored."
+  (loop for old-position = -1 then position
+        for position = (and old-position
+                            (position #\, string :test #'char= :start (1+ old-position)))
+        for substring = (and old-position
+                             (trim-whitespace (subseq string (1+ old-position) position)))
+        while old-position
+        when (plusp (length substring))
+        collect substring))

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/request.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,666 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/request.lisp,v 1.54 2008/01/14 18:51:38 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :drakma)
+
+(defun determine-body-format (headers external-format-in)
+  "The default function used by Drakma to determine how the content
+body is to be read.  See the docstring of *BODY-FORMAT-FUNCTION* for
+more info."
+  (handler-case
+      (let ((transfer-encodings (header-value :transfer-encoding headers))
+            (content-encodings (header-value :content-encoding headers)))
+        (when transfer-encodings
+          (setq transfer-encodings (split-tokens transfer-encodings)))
+        (when content-encodings
+          (setq content-encodings (split-tokens content-encodings)))
+        (multiple-value-bind (type subtype params)
+            (get-content-type headers)
+          (when (and (text-content-type-p type subtype)
+                     (null (set-difference transfer-encodings
+                                           '("chunked" "identity")
+                                           :test #'equalp))
+                     (null (set-difference content-encodings
+                                           '("identity")
+                                           :test #'equalp)))
+            (let* ((charset (parameter-value "charset" params))
+                   (name (cond (charset (as-keyword charset))
+                               (t external-format-in))))
+              (make-external-format name :eol-style :lf)))))
+    (error (condition)
+      (warn "Problems determining charset \(falling back to binary):~%~A"
+            condition))))
+
+(defun send-content (content stream &optional external-format-out)
+  "Sends CONTENT to the stream STREAM as part of the request body
+depending on the type of CONTENT."
+  (when content
+    (cond ((stringp content)
+           (setf (flexi-stream-external-format stream) external-format-out)
+           (write-string content stream)
+           (setf (flexi-stream-external-format stream) +latin-1+))
+          ((or (arrayp content) (listp content))
+           (write-sequence content stream))
+          ((and (streamp content)
+                (input-stream-p content)
+                (open-stream-p content)
+                (subtypep (stream-element-type content) 'octet))
+           (let ((buf (make-array +buffer-size+ :element-type 'octet)))
+             (loop
+              (let ((pos (read-sequence buf content)))
+                (when (zerop pos) (return))
+                (write-sequence buf stream :end pos)))))
+          ((pathnamep content)
+           (with-open-file (from content :element-type 'octet)
+             ;; calls itself with a stream now
+             (send-content from stream)))
+          ((or (functionp content)
+               (and (symbolp content)
+                    (fboundp content)))
+           (funcall content stream))
+          (t (error "Don't know how to send content ~S to server." content)))))
+
+(defun make-form-data-function (parameters boundary)
+  "Creates and returns a closure which can be used as an argument for
+SEND-CONTENT to send PARAMETERS as a `multipart/form-data' request
+body using the boundary BOUNDARY."
+  (lambda (stream)
+    (flet ((crlf ()
+             "Sends carriage return and linefeed to STREAM."
+             (write-char #\Return stream)
+             (write-char #\Linefeed stream)))
+      (dolist (name/value parameters)
+        (destructuring-bind (name . value)
+            name/value
+          (when (or (pathnamep value)
+                    (streamp value)
+                    (functionp value))
+            (setq value (list value)))
+          (format stream "--~A" boundary)
+          (crlf)
+          (format stream "Content-Disposition: form-data; name=\"~A\"" name)
+          (cond ((stringp value)
+                 (crlf) (crlf)
+                 (format stream "~A" value))
+                ((listp value)
+                 (let* ((file-source (first value))
+                        (filename (or (if (functionp file-source) "user-closure")
+                                      (if (streamp file-source) "user-stream")
+                                      (getf (rest value) :filename)
+                                      (file-namestring file-source)))
+                        (content-type (or (getf (rest value) :content-type)
+                                          "application/octet-stream")))
+                   (format stream "; filename=\"~A\"" filename)
+                   (crlf)
+                   (format stream "Content-Type: ~A" content-type)
+                   (crlf) (crlf)
+                   ;; use SEND-CONTENT to send file as binary data
+                   (send-content file-source stream)))
+                (t (error "Don't know what to do with ~S in multipart/form-data body." value)))
+          (crlf)))
+      (format stream "--~A--" boundary)
+      (crlf))))
+
+(defun read-body (stream headers must-close textp)
+  "Reads the message body from the HTTP stream STREAM using the
+information contained in HEADERS \(as produced by HTTP-REQUEST).  If
+TEXTP is true, the body is assumed to be of content type `text' and
+will be returned as a string.  Otherwise an array of octets \(or NIL
+for an empty body) is returned.  Returns the optional `trailer' HTTP
+headers of the chunked stream \(if any) as a second value."
+  (let ((content-length (ignore-errors
+                           (parse-integer (header-value :content-length headers))))
+        (element-type (if textp
+                        #+:lispworks 'lw:simple-char #-:lispworks 'character
+                        'octet))
+        (chunkedp (chunked-stream-input-chunking-p (flexi-stream-stream stream))))
+    (multiple-value-prog1 
+        (values (cond ((eql content-length 0) nil)
+                      (content-length
+                       (when chunkedp
+                         ;; see RFC 2616, section 4.4
+                         (error "Got Content-Length header although input chunking is on."))
+                       (let ((result (make-array content-length
+                                                 :element-type element-type
+                                                 :fill-pointer t)))
+                         (setf (fill-pointer result)
+                               (read-sequence result stream))
+                         result))
+                      ((or chunkedp must-close)
+                       ;; no content length, read until EOF (or end of chunking)
+                       (let ((buffer (make-array +buffer-size+
+                                                 :element-type element-type))
+                             (result (make-array 0
+                                                 :element-type element-type
+                                                 :adjustable t)))
+                         (loop for index = 0 then (+ index pos)
+                               for pos = (read-sequence buffer stream)
+                               do (adjust-array result (+ index pos))
+                                  (replace result buffer :start1 index :end2 pos)
+                               while (= pos +buffer-size+))
+                         result)))
+                (chunked-input-stream-trailers stream)))))
+
+(defun http-request (uri &rest args
+                         &key (protocol :http/1.1)
+                              (method :get)
+                              force-ssl
+                              parameters
+                              content
+                              (content-type "application/x-www-form-urlencoded")
+                              (content-length nil content-length-provided-p)
+                              form-data
+                              cookie-jar
+                              basic-authorization
+                              (user-agent :drakma)
+                              (accept "*/*")
+                              proxy
+                              proxy-basic-authorization
+                              additional-headers
+                              (redirect 5)
+                              (redirect-methods '(:get :head))
+                              auto-referer
+                              keep-alive
+                              (close t)
+                              (external-format-out *drakma-default-external-format*)
+                              (external-format-in *drakma-default-external-format*)
+                              force-binary
+                              want-stream
+                              stream
+                              #+:lispworks (connection-timeout 20)
+                              #+:lispworks (read-timeout 20)
+                              #+(and :lispworks (not :lw-does-not-have-write-timeout))
+                              (write-timeout 20 write-timeout-provided-p))
+  "Sends an HTTP request to a web server and returns its reply.  URI
+is where the request is sent to, and it is either a string denoting a
+uniform resource identifier or a PURI:URI object.  The scheme of URI
+must be `http' or `https'.  The function returns SEVEN values - the
+body of the reply \(but see below), the status code as an integer, an
+alist of the headers sent by the server where for each element the car
+\(the name of the header) is a keyword and the cdr \(the value of the
+header) is a string, the URI the reply comes from \(which might be
+different from the URI the request was sent to in case of redirects),
+the stream the reply was read from, a generalized boolean which
+denotes whether the stream should be closed \(and which you can
+usually ignore), and finally the reason phrase from the status line as
+a string.
+
+PROTOCOL is the HTTP protocol which is going to be used in the
+request line, it must be one of the keywords :HTTP/1.0 or
+:HTTP/1.1.  METHOD is the method used in the request line, a
+keyword \(like :GET or :HEAD) denoting a valid HTTP/1.1 or WebDAV
+request method.  Additionally, you can also use the pseudo
+method :OPTIONS* which is like :OPTIONS but means that an
+\"OPTIONS *\" request line will be sent, i.e. the URI's path and
+query parts will be ignored.
+
+If FORCE-SSL is true, SSL will be attached to the socket stream
+which connects Drakma with the web server.  Usually, you don't
+have to provide this argument, as SSL will be attached anyway if
+the scheme of URI is `https'.
+
+PARAMETERS is an alist of name/value pairs \(the car and the cdr each
+being a string) which denotes the parameters which are added to the
+query part of the URL or \(in the case of a POST request) comprise the
+body of the request.  (But see CONTENT below.)  The name/value pairs
+are URL-encoded using the FLEXI-STREAMS external format
+EXTERNAL-FORMAT-OUT before they are sent to the server unless
+FORM-DATA is true in which case the POST request body is sent as
+`multipart/form-data' using EXTERNAL-FORMAT-OUT.  The values of the
+PARAMETERS alist can also be pathnames, open binary input streams,
+unary functions, or lists where the first element is of one of the
+former types.  These values denote files which should be sent as part
+of the request body, i.e. if files are present in PARAMETERS, the
+content type of the request is always `multipart/form-data'.  If the
+value is a list, the part of the list behind the first element is
+treated as a plist which can be used to specify a content type and/or
+a filename for the file, i.e. such a value could look like, e.g.,
+\(#p\"/tmp/my_file.doc\" :content-type \"application/msword\"
+:filename \"upload.doc\").
+
+CONTENT, if not NIL, is used as the request body - PARAMETERS is
+ignored in this case.  CONTENT can be a string, a sequence of
+octets, a pathname, an open binary input stream, or a function
+designator.  If CONTENT is a sequence, it will be directly sent
+to the server \(using EXTERNAL-FORMAT-OUT in the case of
+strings).  If CONTENT is a pathname, the binary contents of the
+corresponding file will be sent to the server.  If CONTENT is a
+stream, everything that can be read from the stream until EOF
+will be sent to the server.  If CONTENT is a function designator,
+the corresponding function will be called with one argument, the
+stream to the server, to which it should send data.
+
+Finally, CONTENT can also be the keyword :CONTINUATION in which case
+HTTP-REQUEST returns only one value - a `continuation' function.  This
+function has one required argument and one optional argument.  The
+first argument will be interpreted like CONTENT above \(but it cannot
+be a keyword), i.e. it will be sent to the server according to its
+type.  If the second argument is true, the continuation function can
+be called again to send more content, if it is NIL the continuation
+function returns what HTTP-REQUEST would have returned.
+
+If CONTENT is a sequence, Drakma will use LENGTH to determine its
+length and will use the result for the `Content-Length' header sent to
+the server.  You can overwrite this with the CONTENT-LENGTH parameter
+\(a non-negative integer) which you can also use for the cases where
+Drakma can't or won't determine the content length itself.  You can
+also explicitly provide a CONTENT-LENGTH argument of NIL which will
+imply that no `Content-Length' header will be sent in any case.  If no
+`Content-Length' header is sent, Drakma will use chunked encoding to
+send the content body.  Note that this will not work with older web
+servers.
+
+A non-NIL CONTENT-LENGTH argument means that Drakma /must/ build the
+request body in RAM and compute the content length even if it would
+have otherwise used chunked encoding, for example in the case of file
+uploads.  A special case is the value T for CONTENT-LENGTH which means
+that Drakma should compute the content length after building the
+request body.
+
+CONTENT-TYPE is the corresponding `Content-Type' header to be sent and
+will be ignored unless CONTENT is provided as well.
+
+Note that a query already contained in URI will always be sent with
+the request line anyway in addition to other parameters sent by
+Drakma.
+
+COOKIE-JAR is a cookie jar containing cookies which will
+potentially be sent to the server \(if the domain matches, if
+they haven't expired, etc.) - this cookie jar will be modified
+according to the `Set-Cookie' header\(s) sent back by the server.
+
+BASIC-AUTHORIZATION, if not NIL, should be a list of two strings
+\(username and password) which will be sent to the server for
+basic authorization.  USER-AGENT, if not NIL, denotes which
+`User-Agent' header will be sent with the request.  It can be one
+of the keywords :DRAKMA, :FIREFOX, :EXPLORER, :OPERA, or :SAFARI
+which denote the current version of Drakma or, in the latter four
+cases, a fixed string corresponding to a more or less recent \(as
+of August 2006) version of the corresponding browser.  Or it can
+be a string which is used directly.  ACCEPT, if not NIL, is the
+`Accept' header sent.
+
+If PROXY is not NIL, it should be a string denoting a proxy
+server through which the request should be sent.  Or it can be a
+list of two values - a string denoting the proxy server and an
+integer denoting the port to use \(which will default to 80
+otherwise).  PROXY-BASIC-AUTHORIZATION is used like
+BASIC-AUTHORIZATION, but for the proxy, and only if PROXY is
+true.
+
+ADDITIONAL-HEADERS is a name/value alist \(like PARAMETERS) of
+additional HTTP headers which should be sent with the request.
+
+If REDIRECT is not NIL, it must be a non-negative integer or T.
+If REDIRECT is true, Drakma will follow redirects \(return codes
+301, 302, 303, or 307) unless REDIRECT is 0.  If REDIRECT is an
+integer, it will be decreased by 1 with each redirect.
+Furthermore, if AUTO-REFERER is true when following redirects,
+Drakma will populate the `Referer' header with the URI that
+triggered the redirection, overwriting an existing `Referer'
+header (in ADDITIONAL-HEADERS) if necessary.
+
+If KEEP-ALIVE is T, the server will be asked to keep the
+connection alive, i.e. not to close it after the reply has been
+sent.  \(Note that this not necessary if both the client and the
+server use HTTP 1.1.)  If CLOSE is T, the server is explicitly
+asked to close the connection after the reply has been sent.
+KEEP-ALIVE and CLOSE are obviously mutually exclusive.
+
+If the message body sent by the server has a text content type,
+Drakma will try to return it as a Lisp string.  It'll first check
+if the `Content-Type' header denotes an encoding to be used, or
+otherwise it will use the EXTERNAL-FORMAT-IN argument.  The body
+is decoded using FLEXI-STREAMS.  If FLEXI-STREAMS doesn't know
+the external format, the body is returned as an array of octets.
+
+If the message body doesn't have a text content type or if
+FORCE-BINARY is true, the body is always returned as an array of
+octets.
+
+If WANT-STREAM is true, the message body is NOT read and instead the
+\(open) socket stream is returned as the first return value.  If the
+sixth value of HTTP-REQUEST is true, the stream should be closed \(and
+not be re-used) after the body has been read.  The stream returned is
+a flexi stream \(see http://weitz.de/flexi-streams/) with a chunked
+stream \(see http://weitz.de/chunga/) as its underlying stream.  If
+you want to read binary data from this stream, read from the
+underlying stream which you can get with FLEXI-STREAM-STREAM.
+
+Drakma will usually create a new socket connection for each HTTP
+request.  However, you can use the STREAM argument to provide an
+open socket stream which should be re-used.  STREAM MUST be a
+stream returned by a previous invocation of HTTP-REQUEST where
+the sixth return value wasn't true.  Obviously, it must also be
+connected to the correct server and at the right position
+\(i.e. the message body, if any, must have been read).  Drakma
+will NEVER attach SSL to a stream provided as the STREAM
+argument.
+
+CONNECTION-TIMEOUT is the time \(in seconds) Drakma will wait until it
+considers an attempt to connect to a server as a failure.
+READ-TIMEOUT and WRITE-TIMEOUT are the read and write timeouts \(in
+seconds) for the socket stream to the server.  All three timeout
+arguments can also be NIL \(meaning no timeout), and they don't apply
+if an existing stream is re-used.  All timeout keyword arguments are
+only available for LispWorks, WRITE-TIMEOUT is only available for
+LispWorks 5.0 or higher."
+  (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq)
+    (error "Don't know how to handle protocol ~S." protocol))
+  (setq uri (cond ((uri-p uri) (copy-uri uri))
+                  (t (parse-uri uri))))
+  (unless (member method +known-methods+ :test #'eq)
+    (error "Don't know how to handle method ~S." method))
+  (unless (member (uri-scheme uri) '(:http :https) :test #'eq)
+    (error "Don't know how to handle scheme ~S." (uri-scheme uri)))
+  (when (and close keep-alive)
+    (error "CLOSE and KEEP-ALIVE must not be both true."))
+  (when (and (eq content :continuation) content-length)
+    (error "CONTENT-LENGTH must be NIL if CONTENT is :CONTINUATION."))
+  (when (and form-data (not (eq method :post)))
+    (error "FORM-DATA makes only sense with POST requests."))
+  ;; convert PROXY argument to canonical form
+  (when proxy
+    (when (atom proxy)
+      (setq proxy (list proxy 80))))
+  ;; make sure we don't get :CRLF on Windows
+  (let ((*default-eol-style* :lf)
+        (file-parameters-p (find-if-not #'stringp parameters :key #'cdr))
+        parameters-used-p)
+    (when (and file-parameters-p (not (eq method :post)))
+      (error "Don't know how to handle parameters in ~S, as this is not a POST request."
+             parameters))
+    (when (eq method :post)
+      ;; create content body for POST unless it was provided
+      (unless content
+        ;; mark PARAMETERS argument as used up, so we don't use it
+        ;; again below
+        (setq parameters-used-p t)
+        (cond ((or form-data file-parameters-p)
+               (let ((boundary (format nil "----------~A" (make-random-string))))
+                 (setq content (make-form-data-function parameters boundary)
+                       content-type (format nil "multipart/form-data; boundary=~A" boundary)))
+               (unless (or file-parameters-p content-length-provided-p)
+                 (setq content-length (or content-length t))))
+              (t
+               (setq content (alist-to-url-encoded-string parameters external-format-out)
+                     content-type "application/x-www-form-urlencoded")))))
+    (let (http-stream must-close done)
+      (unwind-protect
+          (progn
+            (let ((host (or (and proxy (first proxy))
+                            (uri-host uri)))
+                  (port (cond (proxy (second proxy))
+                              ((uri-port uri))
+                              (t (default-port uri))))
+                  (use-ssl (or force-ssl
+                               (eq (uri-scheme uri) :https))))
+              #+(and :lispworks5.0 :mswindows
+                     (not :lw-does-not-have-write-timeout))
+              (when use-ssl
+                (when (and write-timeout write-timeout-provided-p)
+                  (warn "Disabling WRITE-TIMEOUT because it doesn't mix well with SSL."))
+                (setq write-timeout nil))
+              (setq http-stream (or stream
+                                    #+:lispworks
+                                    (comm:open-tcp-stream host port
+                                                          :element-type 'octet
+                                                          :timeout connection-timeout
+                                                          :read-timeout read-timeout
+                                                          #-:lw-does-not-have-write-timeout
+                                                          #-:lw-does-not-have-write-timeout
+                                                          :write-timeout write-timeout
+                                                          :errorp t)
+                                    #-:lispworks
+                                    (usocket:socket-stream
+                                     (usocket:socket-connect host port :element-type 'octet))))
+              (when (and use-ssl
+                         ;; don't attach SSL to existing streams
+                         (not stream))
+                #+:lispworks
+                (comm:attach-ssl http-stream :ssl-side :client)
+                #-:lispworks
+                (setq http-stream
+                      #+:allegro
+                      (socket:make-ssl-client-stream http-stream)
+                      #-:allegro
+                      (let ((s http-stream))
+                        (cl+ssl:make-ssl-client-stream 
+                         (cl+ssl:stream-fd s)
+                         :close-callback (lambda () (close s)))))))
+            (cond (stream
+                   (setf (flexi-stream-element-type http-stream)
+                         #+:lispworks 'lw:simple-char #-:lispworks 'character
+                         (flexi-stream-external-format http-stream) +latin-1+))
+                  (t
+                   (setq http-stream
+                         (make-flexi-stream (make-chunked-stream http-stream)
+                                            :external-format +latin-1+))))
+            (labels ((write-http-line (fmt &rest args)
+                       (when *header-stream*
+                         (format *header-stream* "~?~%" fmt args))
+                       (format http-stream "~?~C~C" fmt args #\Return #\Linefeed))
+                     (write-header (name value-fmt &rest value-args)
+                       (write-http-line "~A: ~?" name value-fmt value-args)))
+              (when (and (not parameters-used-p)
+                         parameters)
+                (setf (uri-query uri)
+                      ;; append parameters to existing query of URI
+                      (format nil "~@[~A~]~:*~:[~;&~]~A"
+                              (uri-query uri)
+                              (alist-to-url-encoded-string parameters external-format-out))))
+              (when (eq method :options*)
+                ;; special pseudo-method
+                (setf method :options
+                      (uri-path uri) "*"
+                      (uri-query uri) nil))
+              (write-http-line "~A ~A ~A"
+                               (string-upcase method)
+                               (cond (proxy (render-uri uri nil))
+                                     (t (format nil "~A~@[?~A~]"
+                                                (or (uri-path uri) "/")
+                                                (uri-query uri))))
+                               (string-upcase protocol))
+              (write-header "Host" "~A~@[:~A~]" (uri-host uri) (non-default-port uri))
+              (when user-agent
+                (write-header "User-Agent" (user-agent-string user-agent)))
+              (when basic-authorization
+                (write-header "Authorization" "Basic ~A"
+                              (base64:string-to-base64-string
+                               (format nil "~A:~A"
+                                       (first basic-authorization)
+                                       (second basic-authorization)))))
+              (when (and proxy proxy-basic-authorization)
+                (write-header "Proxy-Authorization" "Basic ~A"
+                              (base64:string-to-base64-string
+                               (format nil "~A:~A"
+                                       (first proxy-basic-authorization)
+                                       (second proxy-basic-authorization)))))
+              (when accept
+                (write-header "Accept" "~A" accept))
+              (when cookie-jar
+                ;; write all cookies in one fell swoop, so even Sun's
+                ;; web server has a change to get it
+                (when-let (cookies (loop for cookie in (cookie-jar-cookies cookie-jar)
+                                         when (send-cookie-p cookie uri force-ssl)
+                                         collect (cookie-name cookie) and
+                                         collect (cookie-value cookie)))
+                  (write-header "Cookie" "~{~A=~A~^; ~}" cookies)))
+              (when keep-alive
+                (write-header "Connection" "Keep-Alive"))
+              (when close
+                (setq must-close close)
+                (write-header "Connection" "close"))
+              (loop for (name . value) in additional-headers
+                    do (write-header name "~A" value))
+              (when content
+                (when content-type
+                  (write-header "Content-Type" "~A" content-type))
+                (when (and content-length
+                           (not (or (arrayp content)
+                                    (listp content)
+                                    (eq content :continuation))))
+                  ;; CONTENT-LENGTH forces us to compute request body
+                  ;; in RAM
+                  (setq content
+                        (with-output-to-sequence (bin-out)
+                          (let ((out (make-flexi-stream bin-out :external-format +latin-1+)))
+                            (send-content content out)))))
+                (when (and (or (not content-length-provided-p)
+                               (eq content-length t))
+                           (or (arrayp content) (listp content)))
+                  (setq content-length (length content)))
+                (cond (content-length
+                       (write-header "Content-Length" "~D" content-length))
+                      (t
+                       (write-header "Transfer-Encoding" "chunked"))))
+              ;; end of request headers
+              (when *header-stream*
+                (terpri *header-stream*))
+              (format http-stream "~C~C" #\Return #\Linefeed)
+              (force-output http-stream)
+              (when (and content (null content-length))
+                (setf (chunked-stream-output-chunking-p
+                       (flexi-stream-stream http-stream)) t))         
+              (labels ((finish-request (content &optional continuep)
+                         (send-content content http-stream external-format-out)
+                         (when continuep
+                           (force-output http-stream)
+                           (return-from finish-request))
+                         (setf (chunked-stream-output-chunking-p
+                                (flexi-stream-stream http-stream)) nil)
+                         (finish-output http-stream)
+                         (multiple-value-bind (server-protocol status-code status-text)
+                             ;; loop until status is NOT 100
+                             (loop for (server-protocol status-code status-text)
+                                   = (read-status-line http-stream *header-stream*)
+                                   when (= status-code 100)
+                                   ;; ignore headers sent until non-100 status is seen
+                                   do (read-http-headers http-stream *header-stream*)
+                                   until (/= status-code 100)
+                                   finally (return (values server-protocol status-code status-text)))
+                           (let ((headers (read-http-headers http-stream *header-stream*))
+                                 body external-format-body)
+                             (let ((connections (header-value :connection headers)))
+                               (when connections
+                                 (setq connections (split-tokens connections)))
+                               (when (or (member "close" connections :test #'string-equal)
+                                         (not (or (and (eq protocol :http/1.1)
+                                                       (eq server-protocol :http/1.1))
+                                                  (member "Keep-Alive" connections
+                                                          :test #'string-equal))))
+                                 (setq must-close t)))
+                             (when cookie-jar
+                               (update-cookies (get-cookies headers uri) cookie-jar))
+                             (when (and redirect
+                                        (member status-code +redirect-codes+)
+                                        (member method redirect-methods))
+                               (unless (or (eq redirect t)
+                                           (and (integerp redirect)
+                                                (plusp redirect)))
+                                 (cerror "Continue anyway."
+                                         "Status code was ~A, but ~
+~:[REDIRECT is ~S~;redirection limit has been exceeded~]."
+                                         status-code (integerp redirect) redirect))
+                               (when auto-referer
+                                 (setq additional-headers (set-referer uri additional-headers)))
+                               (let* ((location (header-value :location headers))
+                                      (new-uri (merge-uris (cond ((or (null location)
+                                                                      (zerop (length location)))
+                                                                  (warn "Empty `Location' header, assuming \"/\".")
+                                                                  "/")
+                                                                 (t location))
+                                                           uri))
+                                      ;; can we re-use the stream?
+                                      (old-server-p (and (string= (uri-host new-uri)
+                                                                  (uri-host uri))
+                                                         (eql (uri-port new-uri)
+                                                              (uri-port uri))
+                                                         (eq (uri-scheme new-uri)
+                                                             (uri-scheme uri)))))
+                                 (unless old-server-p
+                                   (setq must-close t
+                                         want-stream nil))
+                                 ;; try to re-use the stream, but only
+                                 ;; if the user hasn't opted for a
+                                 ;; connection which is always secure
+                                 (let ((re-use-stream (and old-server-p
+                                                           (not must-close)
+                                                           (not force-ssl))))
+                                   ;; close stream if we can't re-use it
+                                   (unless re-use-stream
+                                     (ignore-errors (close http-stream)))
+                                   (setq done t)
+                                   (return-from http-request
+                                     (apply #'http-request new-uri
+                                            :redirect (cond ((integerp redirect) (1- redirect))
+                                                            (t redirect))
+                                            :stream (and re-use-stream http-stream)
+                                            :additional-headers additional-headers
+                                            args)))))
+                             (let ((transfer-encodings (header-value :transfer-encoding headers)))
+                               (when transfer-encodings
+                                 (setq transfer-encodings (split-tokens transfer-encodings)))
+                               (when (member "chunked" transfer-encodings :test #'equalp)
+                                 (setf (chunked-stream-input-chunking-p
+                                        (flexi-stream-stream http-stream)) t)))
+                             (when (setq external-format-body
+                                         (and (not force-binary)
+                                              (funcall *body-format-function*
+                                                       headers external-format-in)))
+                               (setf (flexi-stream-external-format http-stream)
+                                     external-format-body))
+                             (when force-binary
+                               (setf (flexi-stream-element-type http-stream) 'octet))
+                             (unless (or want-stream (eq method :head))
+                               (let (trailers)
+                                 (multiple-value-setq (body trailers)
+                                     (read-body http-stream headers must-close external-format-body))
+                                 (when trailers
+                                   (warn "Adding trailers from chunked encoding to HTTP headers.")
+                                   (setq headers (nconc headers trailers)))))
+                             (setq done t)
+                             (values (cond (want-stream http-stream)
+                                           (t body))
+                                     status-code
+                                     headers
+                                     uri
+                                     http-stream
+                                     must-close
+                                     status-text)))))
+                (when (eq content :continuation)
+                  (return-from http-request #'finish-request))
+                (finish-request content))))
+        ;; the cleanup form of the UNWIND-PROTECT above
+        (when (and http-stream
+                   (or (not done)
+                       (and must-close
+                            (not want-stream)))
+                   (not (eq content :continuation)))
+          (ignore-errors (close http-stream)))))))

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/specials.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,208 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/specials.lisp,v 1.19 2008/01/14 01:57:02 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :drakma)
+
+(defmacro define-constant (name value &optional doc)
+  "A version of DEFCONSTANT for, cough, /strict/ CL implementations."
+  ;; See <http://www.sbcl.org/manual/Defining-Constants.html>
+  `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+     ,@(when doc (list doc))))
+
+(define-constant +latin-1+ (make-external-format :latin-1 :eol-style :lf)
+  "Default external format when reading headers.")
+
+(define-constant +redirect-codes+ '(301 302 303 307)
+  "A list of all HTTP return codes that redirect us to another URI.")
+
+(define-constant +known-methods+ '(:copy
+                                   :delete
+                                   :delete
+                                   :get
+                                   :head
+                                   :lock
+                                   :mkcol
+                                   :move
+                                   :options
+                                   :options*
+                                   :post
+                                   :propfind
+                                   :proppatch
+                                   :put
+                                   :trace
+                                   :unlock)
+  "The HTTP methods \(including WebDAV methods) Drakma knows.")
+
+(defconstant +buffer-size+ 8192)
+
+(defvar *drakma-default-external-format* ':latin-1
+  "The default value for the external format keyword arguments of
+HTTP-REQUEST.")
+
+(defvar *header-stream* nil
+  "If this variable is not NIL, it should be bound to a stream to
+which incoming and outgoing headers will be written for debugging
+purposes.")
+
+(defvar *ignore-unparseable-cookie-dates-p* nil
+  "Whether Drakma is allowed to treat `Expires' dates in cookie
+headers as non-existent if it can't parse them.  If the value of this
+variable is NIL \(which is the default), an error will be signalled
+instead.")
+
+(defvar *text-content-types* '(("text" . nil))
+  "A list of conses which are used by DETERMINE-BODY-FORMAT to decide
+whether a `Content-Type' header denotes text content.  The car and cdr
+of each cons should each be a string or NIL.  A content type matches
+one of these entries \(and thus denotes text) if the type part is
+STRING-EQUAL to the car or if the car is NIL and if the subtype part
+is STRING-EQUAL to the cdr or if the cdr is NIL.")
+
+(defvar *body-format-function* 'determine-body-format
+  "A function which determines whether the content body returned by
+the server is text and should be treated as such or not.  The function
+is called after the request headers have been read and it must accept
+two arguments, HEADERS and EXTERNAL-FORMAT-IN where HEADERS is like
+the third return value of HTTP-REQUEST while EXTERNAL-FORMAT-IN is the
+HTTP-REQUEST argument of the same name.  It should return NIL if the
+body should be regarded as binary content, or a FLEXI-STREAMS external
+format \(which will be used to read the body) otherwise.
+
+This function will only be called if the FORCE-BINARY argument to
+HTTP-REQUEST was NIL.")
+
+(defvar *time-zone-map*
+  ;; list taken from
+  ;; <http://www.timeanddate.com/library/abbreviations/timezones/>
+  '(("A" . -1)
+    ("ACDT" . -10.5)
+    ("ACST" . -9.5)
+    ("ADT" . 3)
+    ("AEDT" . -11)
+    ("AEST" . -10)
+    ("AKDT" . 8)
+    ("AKST" . 9)
+    ("AST" . 4)
+    ("AWDT" . -9)
+    ("AWST" . -8)
+    ("B" . -2)
+    ("BST" . -1)
+    ("C" . -3)
+    ("CDT" . 5)
+    ("CEDT" . -2)
+    ("CEST" . -2)
+    ("CET" . -1)
+    ("CST" . -10.5)
+    ("CST" . -9.5)
+    ("CST" . 6)
+    ("CXT" . -7)
+    ("D" . -4)
+    ("E" . -5)
+    ("EDT" . 4)
+    ("EEDT" . -3)
+    ("EEST" . -3)
+    ("EET" . -2)
+    ("EST" . -11)
+    ("EST" . -10)
+    ("EST" . 5)
+    ("F" . -6)
+    ("G" . -7)
+    ("GMT" . 0)
+    ("H" . -8)
+    ("HAA" . 3)
+    ("HAC" . 5)
+    ("HADT" . 9)
+    ("HAE" . 4)
+    ("HAP" . 7)
+    ("HAR" . 6)
+    ("HAST" . 10)
+    ("HAT" . 2.5)
+    ("HAY" . 8)
+    ("HNA" . 4)
+    ("HNC" . 6)
+    ("HNE" . 5)
+    ("HNP" . 8)
+    ("HNR" . 7)
+    ("HNT" . 3.5)
+    ("HNY" . 9)
+    ("I" . -9)
+    ("IST" . -1)
+    ("K" . -10)
+    ("L" . -11)
+    ("M" . -12)
+    ("MDT" . 6)
+    ("MESZ" . -2)
+    ("MEZ" . -1)
+    ("MST" . 7)
+    ("N" . 1)
+    ("NDT" . 2.5)
+    ("NFT" . -11.5)
+    ("NST" . 3.5)
+    ("O" . 2)
+    ("P" . 3)
+    ("PDT" . 7)
+    ("PST" . 8)
+    ("Q" . 4)
+    ("R" . 5)
+    ("S" . 6)
+    ("T" . 7)
+    ("U" . 8)
+    ("UTC" . 0)
+    ("V" . 9)
+    ("W" . 10)
+    ("WEDT" . -1)
+    ("WEST" . -1)
+    ("WET" . 0)
+    ("WST" . -9)
+    ("WST" . -8)
+    ("X" . 11)
+    ("Y" . 12)
+    ("Z" . 0))
+  "An alist which maps time zone abbreviations to Common Lisp
+timezones.")
+
+;; stuff for Nikodemus Siivola's HYPERDOC
+;; see <http://common-lisp.net/project/hyperdoc/>
+;; and <http://www.cliki.net/hyperdoc>
+;; also used by LW-ADD-ONS
+
+(defvar *hyperdoc-base-uri* "http://weitz.de/drakma/")
+
+(let ((exported-symbols-alist
+       (loop for symbol being the external-symbols of :drakma
+             collect (cons symbol
+                           (concatenate 'string
+                                        "#"
+                                        (string-downcase symbol))))))
+  (defun hyperdoc-lookup (symbol type)
+    (declare (ignore type))
+    (cdr (assoc symbol
+                exported-symbols-alist
+                :test #'eq))))
+               

Added: branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/drakma-0.11.3/util.lisp	Wed Feb 13 14:41:09 2008
@@ -0,0 +1,287 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/drakma/util.lisp,v 1.35 2008/01/14 01:57:02 edi Exp $
+
+;;; Copyright (c) 2006-2008, Dr. Edmund Weitz.  All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :drakma)
+
+#+:lispworks
+(require "comm")
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import 'lw:when-let))
+
+#-:lispworks
+(defmacro when-let ((var expr) &body body)
+  "Evaluates EXPR, binds it to VAR, and executes BODY if VAR has
+a true value."
+  `(let ((,var ,expr))
+     (when ,var
+       , at body)))
+
+#+:lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import 'lw:with-unique-names))
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+  "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+  ;; reference implementation posted to comp.lang.lisp as
+  ;; <cy3bshuf30f.fsf at ljosa.com> by Vebjorn Ljosa - see also
+  ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+  `(let ,(mapcar #'(lambda (binding)
+                     (check-type binding (or cons symbol))
+                     (if (consp binding)
+                       (destructuring-bind (var x) binding
+                         (check-type var symbol)
+                         `(,var (gensym ,(etypecase x
+                                          (symbol (symbol-name x))
+                                          (character (string x))
+                                          (string x)))))
+                       `(,binding (gensym ,(symbol-name binding)))))
+                 bindings)
+         , at body))
+
+(defun ends-with-p (seq suffix &key (test #'char-equal))
+  "Returns true if the sequence SEQ ends with the sequence
+SUFFIX.  Individual elements are compared with TEST."
+  (let ((mismatch (mismatch seq suffix :from-end t :test test)))
+    (or (null mismatch)
+        (= mismatch (- (length seq) (length suffix))))))
+
+(defun starts-with-p (seq prefix &key (test #'char-equal))
+  "Returns true if the sequence SEQ starts with the sequence
+PREFIX whereby the elements are compared using TEST."
+  (let ((mismatch (mismatch seq prefix :test test)))
+    (or (null mismatch)
+        (= mismatch (length prefix)))))
+
+(defun url-encode (string external-format)
+  "Returns a URL-encoded version of the string STRING using the
+LispWorks external format EXTERNAL-FORMAT."
+  (with-output-to-string (out)
+    (loop for octet across (string-to-octets (or string "")
+                                             :external-format external-format)
+          for char = (code-char octet)
+          do (cond ((or (char<= #\0 char #\9)
+                        (char<= #\a char #\z)
+                        (char<= #\A char #\Z)
+                        (find char "$-_.!*'()," :test #'char=))
+                     (write-char char out))
+                   ((char= char #\Space)
+                     (write-char #\+ out))
+                   (t (format out "%~2,'0x" (char-code char)))))))
+
+(defun alist-to-url-encoded-string (alist external-format)
+  "ALIST is supposed to be an alist of name/value pairs where both
+names and values are strings.  This function returns a string where
+this list is represented as for the content type
+`application/x-www-form-urlencoded', i.e. the values are URL-encoded
+using the external format EXTERNAL-FORMAT, the pairs are joined with a
+#\\& character, and each name is separated from its value with a #\\=
+character."
+  (with-output-to-string (out)
+    (loop for first = t then nil
+          for (name . value) in alist
+          unless first do (write-char #\& out)
+          do (format out "~A=~A"
+                      (url-encode name external-format)
+                      (url-encode value external-format)))))
+
+(defun default-port (uri)
+  "Returns the default port number for the \(PURI) URI URI.
+Works only with the http and https schemes."
+  (ecase (uri-scheme uri)
+    (:http 80)
+    (:https 443)))
+
+(defun non-default-port (uri)
+  "If the \(PURI) URI specifies an explicit port number which is
+different from the default port its scheme, this port number is
+returned, otherwise NIL."
+  (when-let (port (uri-port uri))
+    (when (/= port (default-port uri))
+      port)))
+
+(defun user-agent-string (token)
+  "Returns a corresponding user agent string if TOKEN is one of
+the keywords :DRAKMA, :FIREFOX, :EXPLORER, :OPERA, or :SAFARI.
+Returns TOKEN itself otherwise."
+  (case token
+    (:drakma
+     (format nil "Drakma/~A (~A~@[ ~A~]; ~A;~@[ ~A;~] http://weitz.de/drakma/)"
+             *drakma-version-string*
+             (or (lisp-implementation-type) "Common Lisp")
+             (or (lisp-implementation-version) "")
+             (or #-:clisp (software-type)
+                 #+(or :win32 :mswindows) "Windows"
+                 #-(or :win32 :mswindows) "Unix")
+             (or #-:clisp (software-version))))
+    (:firefox
+     "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.6) Gecko/20060728 Firefox/1.5.0.6")
+    (:explorer
+     "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)")
+    (:opera
+     "Opera/9.01 (Windows NT 5.1; U; en)")
+    (:safari
+     "Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en) AppleWebKit/418.8 (KHTML, like Gecko) Safari/419.3")
+    (otherwise token)))
+
+(defun header-value (name headers)
+  "If HEADERS is an alist of headers as returned by HTTP-REQUEST
+and NAME is a keyword naming a header, this function returns the
+corresponding value of this header \(or NIL if it's not in
+HEADERS)."
+  (cdr (assoc name headers :test #'eq)))
+
+(defun parameter-present-p (name parameters)
+  "If PARAMETERS is an alist of parameters as returned by, for
+example, READ-TOKENS-AND-PARAMETERS and NAME is a string naming a
+parameter, this function returns the full parameter \(name and
+value) - or NIL if it's not in PARAMETERS."
+  (assoc name parameters :test #'string-equal))
+
+(defun parameter-value (name parameters)
+  "If PARAMETERS is an alist of parameters as returned by, for
+example, READ-TOKENS-AND-PARAMETERS and NAME is a string naming a
+parameter, this function returns the value of this parameter - or
+NIL if it's not in PARAMETERS."
+  (cdr (parameter-present-p name parameters)))
+
+(defun make-random-string (&optional (length 50))
+  "Generates and returns a random string length LENGTH.  The
+string will consist solely of decimal digits and ASCII letters."
+  (with-output-to-string (s)
+    (dotimes (i length)
+      (write-char (ecase (random 5)
+                    ((0 1) (code-char (+ #.(char-code #\a) (random 26))))
+                    ((2 3) (code-char (+ #.(char-code #\A) (random 26))))
+                    ((4) (code-char (+ #.(char-code #\0) (random 10)))))
+                  s))))
+
+(defun split-string (string &optional (separators " ,-"))
+  "Splits STRING into a list of substrings \(which is returned)
+separated by the characters in the sequence SEPARATORS.  Empty
+substrings aren't collected."
+  (flet ((make-collector ()
+           (make-array 0
+                       :adjustable t
+                       :fill-pointer t
+                       :element-type #+:lispworks 'lw:simple-char
+                                     #-:lispworks 'character)))                       
+    (loop with collector = (make-collector)
+          for char across string
+          for counter downfrom (1- (length string))
+          when (find char separators :test #'char=)
+          when (plusp (length collector))
+          collect collector
+          and do (setq collector (make-collector)) end
+          else
+          do (vector-push-extend char collector)
+          and when (zerop counter)
+          collect collector)))
+
+(defun safe-parse-integer (string)
+  "Like PARSE-INTEGER, but returns NIL instead of signalling an error."
+  (ignore-errors (parse-integer string)))
+
+(defun interpret-as-month (string)
+  "Tries to interpret STRING as a string denoting a month and returns
+the corresponding number of the month.  Accepts three-letter
+abbreviations like \"Feb\" and full month names likes \"February\".
+Finally, the function also accepts strings representing integers from
+one to twelve."
+  (or (when-let (pos (position (subseq string 0 (min 3 (length string)))
+                               '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+                                       "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+                               :test #'string=))
+        (1+ pos))
+      (when-let (num (safe-parse-integer string))
+        (when (<= 1 num 12)
+          num))))
+
+(defun interpret-as-time-zone (string)
+  "Tries to interpret STRING as a time zone abbreviation which can
+either be something like \"PST\" or \"GMT\" with an offset like
+\"GMT-02:00\"."
+  (when-let (zone (cdr (assoc string *time-zone-map* :test #'string=)))
+    (return-from interpret-as-time-zone zone))
+  (unless (and (= (length string) 9)
+               (starts-with-p string "GMT")
+               (find (char string 3) "+-" :test #'char=)
+               (char= (char string 6) #\:)
+               (every (lambda (pos)
+                        (digit-char-p (char string pos)))
+                      '(4 5 7 8)))
+    (error "Can't interpret ~S as a time zone." string))
+  (let ((hours (parse-integer string :start 4 :end 6))
+        (minutes (parse-integer string :start 7 :end 9)))
+    (* (if (char= (char string 3) #\+) -1 1)
+       (+ hours (/ minutes 60)))))
+
+(defun set-referer (referer-uri &optional alist)
+  "Returns a fresh copy of the HTTP header list ALIST with the
+`Referer' header set to REFERER-URI.  If REFERER-URI is NIL, the
+result will be a list of headers without a `Referer' header."
+  (let ((alist-sans-referer (remove "Referer" alist :key #'car :test #'string=)))
+    (cond (referer-uri (acons "Referer" referer-uri alist-sans-referer))
+          (t alist-sans-referer))))
+
+(defun text-content-type-p (type subtype)
+  "Returns a true value iff the combination of TYPE and SUBTYPE
+matches an entry of *TEXT-CONTENT-TYPES*.  See docstring of
+*TEXT-CONTENT-TYPES* for more info."
+  (loop for (candidate-type . candidate-subtype) in *text-content-types*
+        thereis (and (or (null candidate-type)
+                         (string-equal type candidate-type))
+                     (or (null candidate-subtype)
+                         (string-equal subtype candidate-subtype)))))
+
+(defun as-keyword (string)
+  "Converts the string STRING to a keyword where all characters are
+uppercase or lowercase, taking into account the current readtable
+case."
+  (intern (funcall
+            (if (eq (readtable-case *readtable*) :upcase)
+              #'string-upcase
+              #'string-downcase)
+            string)
+          :keyword))
+


From hhubner at common-lisp.net  Wed Feb 13 20:22:23 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Wed, 13 Feb 2008 15:22:23 -0500 (EST)
Subject: [bknr-cvs] r2488 - in branches/trunk-reorg: bknr/web/src/images
	bknr/web/src/web projects/bos/web projects/quickhoney/src xhtmlgen
Message-ID: <20080213202223.F122D7A01E@common-lisp.net>

Author: hhubner
Date: Wed Feb 13 15:22:21 2008
New Revision: 2488

Modified:
   branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
   branches/trunk-reorg/bknr/web/src/web/tags.lisp
   branches/trunk-reorg/projects/bos/web/webserver.lisp
   branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp
   branches/trunk-reorg/projects/quickhoney/src/tags.lisp
   branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
Log:
Fixes for templater and toplevel, BOS templates now work a bit better.


Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	Wed Feb 13 15:22:21 2008
@@ -16,35 +16,35 @@
 
 (defun apply-imageproc-operation (operation-name args image)
   (apply (or (gethash (make-keyword-from-string operation-name) *imageproc-operations*)
-	     (error "invalid imageproc operation name ~A" operation-name))
-	 image args))
+             (error "invalid imageproc operation name ~A" operation-name))
+         image args))
 
 (defun imageproc (image operations)
   (with-store-image (input-image image)
     (setf (save-alpha-p :image input-image) t)
     (let ((working-image input-image))
       (dolist (operation operations)
-	(destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal)
-	  (let ((returned-image (apply-imageproc-operation operation-name args working-image)))
-	    (unless (not returned-image)
-	      (unless (or (eq working-image returned-image)
-			  (eq working-image input-image))
-		(destroy-image working-image))
-	      (setf working-image returned-image)))))
+        (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal)
+          (let ((returned-image (apply-imageproc-operation operation-name args working-image)))
+            (unless (not returned-image)
+              (unless (or (eq working-image returned-image)
+                          (eq working-image input-image))
+                (destroy-image working-image))
+              (setf working-image returned-image)))))
       (when (and (true-color-p working-image)
-		 (not (true-color-p input-image)))
-	(true-color-to-palette :dither t :image working-image :colors-wanted 256))
+                 (not (true-color-p input-image)))
+        (true-color-to-palette :dither t :image working-image :colors-wanted 256))
       (let ((stream (send-headers)))
-	(setf (flex:flexi-stream-element-type stream) 'flex:octet)
-	(write-image-to-stream stream (image-type-keyword image) :image working-image))
+        (setf (flex:flexi-stream-element-type stream) 'flex:octet)
+        (write-image-to-stream stream (image-type-keyword image) :image working-image))
       (unless (eq working-image input-image)
-	(destroy-image working-image)))))
+        (destroy-image working-image)))))
 
 #+(or)
 (unless (member type '(:jpg :jpeg))
   (when (true-color-p input-image)
     (true-color-to-palette :dither t :image input-image
-		       :colors-wanted 256)))
+                           :colors-wanted 256)))
 
 (defparameter *cell-border-width* 5)
 
@@ -54,38 +54,38 @@
   (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor nil))
   (setq border-width (if border-width (parse-integer border-width) *cell-border-width*))
   (let* ((width (image-width input-image))
-	 (height (image-height input-image))
-	 (ratio (max (/ width (- cell-width (* border-width 2)))
-		     (/ height (- cell-height (* border-width 2)))))
-	 (thumbnail-width (min width (round (/ width ratio))))
-	 (thumbnail-height (min height (round (/ height ratio))))
-	 (x-offset (round (/ (- cell-width thumbnail-width) 2)))
-	 (y-offset (round (/ (- cell-height thumbnail-height) 2)))
-	 (cell (create-image cell-width cell-height t)))
+         (height (image-height input-image))
+         (ratio (max (/ width (- cell-width (* border-width 2)))
+                     (/ height (- cell-height (* border-width 2)))))
+         (thumbnail-width (min width (round (/ width ratio))))
+         (thumbnail-height (min height (round (/ height ratio))))
+         (x-offset (round (/ (- cell-width thumbnail-width) 2)))
+         (y-offset (round (/ (- cell-height thumbnail-height) 2)))
+         (cell (create-image cell-width cell-height t)))
     (with-default-image (cell)
       (let ((color (if bgcolor
-		       (parse-color bgcolor)
-		       (allocate-color 255 255 255))))
-	(fill-image 0 0 :color color)
-	(copy-image input-image cell
-		    0 0
-		    x-offset
-		    y-offset
-		    width height
-		    :resize t :resample t
-		    :dest-width thumbnail-width :dest-height thumbnail-height)
-	(unless bgcolor
-	  (setf (transparent-color) color)
-	  (let ((cr (ldb (byte 8 16) color))
-		(cg (ldb (byte 8 8) color))
-		(cb (ldb (byte 8 0) color)))
-	    (flet ((color-distance (c)
-		     (+ (abs (- (ldb (byte 8 16) c) cr))
-			(abs (- (ldb (byte 8 8) c) cg))
-			(abs (- (ldb (byte 8 0) c) cb)))))
-	      (do-pixels ()
-		(when (< (color-distance (raw-pixel)) 6)
-		  (setf (raw-pixel) color))))))))
+                       (parse-color bgcolor)
+                       (allocate-color 255 255 255))))
+        (fill-image 0 0 :color color)
+        (copy-image input-image cell
+                    0 0
+                    x-offset
+                    y-offset
+                    width height
+                    :resize t :resample t
+                    :dest-width thumbnail-width :dest-height thumbnail-height)
+        (unless bgcolor
+          (setf (transparent-color) color)
+          (let ((cr (ldb (byte 8 16) color))
+                (cg (ldb (byte 8 8) color))
+                (cb (ldb (byte 8 0) color)))
+            (flet ((color-distance (c)
+                     (+ (abs (- (ldb (byte 8 16) c) cr))
+                        (abs (- (ldb (byte 8 8) c) cg))
+                        (abs (- (ldb (byte 8 0) c) cb)))))
+              (do-pixels ()
+                (when (< (color-distance (raw-pixel)) 6)
+                  (setf (raw-pixel) color))))))))
     cell))
   
 (define-imageproc-handler thumbnail (input-image &optional bgcolor max-width max-height)
@@ -93,50 +93,50 @@
   (setf max-width (if max-width (parse-integer max-width) *thumbnail-max-width*))
   (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*))
   (let ((width (image-width input-image))
-	(height (image-height input-image)))
+        (height (image-height input-image)))
     (when (or (< max-width width)
-	      (< max-height height))
+              (< max-height height))
       (let* ((ratio (max (/ width max-width)
-			 (/ height max-height)))
-	     (thumbnail-width (round (/ width ratio)))
-	     (thumbnail-height (round (/ height ratio)))
-	     (thumbnail (create-image thumbnail-width
-				      thumbnail-height
-				      t)))
-	(with-default-image (thumbnail)
-	  (fill-image 0 0 :color (parse-color bgcolor))
-	  (copy-image input-image thumbnail
-		      0 0 0 0
-		      width height
-		      :resize t :resample t
-		      :dest-width thumbnail-width :dest-height thumbnail-height))
-	thumbnail))))
+                         (/ height max-height)))
+             (thumbnail-width (round (/ width ratio)))
+             (thumbnail-height (round (/ height ratio)))
+             (thumbnail (create-image thumbnail-width
+                                      thumbnail-height
+                                      t)))
+        (with-default-image (thumbnail)
+          (fill-image 0 0 :color (parse-color bgcolor))
+          (copy-image input-image thumbnail
+                      0 0 0 0
+                      width height
+                      :resize t :resample t
+                      :dest-width thumbnail-width :dest-height thumbnail-height))
+        thumbnail))))
 
 (define-imageproc-handler double (input-image &optional (times "2"))
   (let* ((width (image-width input-image))
-	 (height (image-height input-image))
-	 (ratio (/ 1 (parse-integer times)))
-	 (double-image-width (round (/ width ratio)))
-	 (double-image-height (round (/ height ratio)))
-	 (double-image (create-image double-image-width double-image-height nil)))
+         (height (image-height input-image))
+         (ratio (/ 1 (parse-integer times)))
+         (double-image-width (round (/ width ratio)))
+         (double-image-height (round (/ height ratio)))
+         (double-image (create-image double-image-width double-image-height nil)))
     (with-default-image (double-image)
       (setf (transparent-color double-image)
-	    (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t))
+            (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t))
       (fill-image 0 0 :color (transparent-color double-image))
       (copy-image input-image double-image
-		  0 0 0 0 width height
-		  :resize t
-		  :dest-width double-image-width :dest-height double-image-height))
+                  0 0 0 0 width height
+                  :resize t
+                  :dest-width double-image-width :dest-height double-image-height))
     double-image))
 
 (define-imageproc-handler color (input-image &rest color-mappings)
   (with-default-image (input-image)
     (let ((colors (loop for (old new) on color-mappings by #'cddr
-			collect (cons (parse-color old) (parse-color new)))))
+                        collect (cons (parse-color old) (parse-color new)))))
       (do-pixels (input-image)
-	(let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors)))
-	  (when (cdr new-color)
-	    (setf (raw-pixel) (cdr new-color)))))))
+        (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors)))
+          (when (cdr new-color)
+            (setf (raw-pixel) (cdr new-color)))))))
   input-image)
 
 (defun image-url (image &key process (prefix "/image"))
@@ -146,19 +146,19 @@
   (if (string-equal color-string "transparent")
       (transparent-color image)
       (let ((components (multiple-value-bind (match strings)
-			    (scan-to-strings "^#?(..)(..)(..)?$" color-string)
-			  (if match
-			      (mapcar #'(lambda (string) (when string (parse-integer string :radix 16)))
-				      (coerce strings 'list))
-			      (progn
-				(warn "can't parse color spec ~a" color-string)
-				'(0 0 0))))))
-	(let ((color (find-color (first components) (second components) (third components)
-				 :exact t :image image)))
-	  (unless color
-	    (setf color (find-color (first components) (second components) (third components)
-				    :exact nil :resolve t :image image)))
-	  color))))
+                            (scan-to-strings "^#?(..)(..)(..)?$" color-string)
+                          (if match
+                              (mapcar #'(lambda (string) (when string (parse-integer string :radix 16)))
+                                      (coerce strings 'list))
+                              (progn
+                                (warn "can't parse color spec ~a" color-string)
+                                '(0 0 0))))))
+        (let ((color (find-color (first components) (second components) (third components)
+                                 :exact t :image image)))
+          (unless color
+            (setf color (find-color (first components) (second components) (third components)
+                                    :exact nil :resolve t :image image)))
+          color))))
 
 (defclass imageproc-handler (image-handler)
   ())
@@ -174,14 +174,14 @@
   #+(or)
   (with-http-response (:content-type (image-content-type (image-type-keyword image)))
     (let ((ims (header-in :if-modified-since))
-	  (changed-time (blob-timestamp image)))
+          (changed-time (blob-timestamp image)))
       (setf (header-out :last-modified) (rfc-1123-date changed-time))
-	(if (and ims
-		 (<= changed-time (date-to-universal-time ims)))
-	    (progn
-	      (setf (return-code) +http-not-modified+)
-	      (format t "; image ~A not changed~%" image)
-	      (with-http-body ()))
-	    (with-http-body ()
-	      (imageproc image (cdr (decoded-handler-path page-handler))))))))
+      (if (and ims
+               (<= changed-time (date-to-universal-time ims)))
+          (progn
+            (setf (return-code) +http-not-modified+)
+            (format t "; image ~A not changed~%" image)
+            (with-http-body ()))
+          (with-http-body ()
+            (imageproc image (cdr (decoded-handler-path page-handler))))))))
     

Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/tags.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/tags.lisp	Wed Feb 13 15:22:21 2008
@@ -4,7 +4,7 @@
 
 (defvar *toplevel-children*)
 
-(define-bknr-tag toplevel (&key children title (template "toplevel"))
+(define-bknr-tag toplevel (&key title (template "toplevel"))
   (setf (get-template-var :title) title)
   (when (and (not (scan "^/" template))
 	     (scan "/" (request-variable :template-path)))
@@ -14,8 +14,8 @@
   (let* ((expander *template-expander*)
          (pathname (find-template-pathname expander template))
          (toplevel (get-cached-template pathname expander))
-         (*toplevel-children* children))
-    (emit-template-node toplevel)))
+         (*toplevel-children* *tag-children*))
+    (emit-template-node *template-expander* toplevel)))
 
 (define-bknr-tag tag-body ()
   (let ((*tag-children* *toplevel-children*))

Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp	Wed Feb 13 15:22:21 2008
@@ -195,6 +195,7 @@
 
   (setf *worldpay-test-mode* worldpay-test-mode)
   (setf bknr.web:*upload-file-size-limit* 20000000)
+  (setf hunchentoot::*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
 
   (make-instance 'bos-website
 		 :name "create-rainforest.org CMS"

Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp	Wed Feb 13 15:22:21 2008
@@ -4,36 +4,35 @@
 
 (define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff"))
   (let ((button-image (create-image *button-size* *button-size* t))
-	(square-size (min (image-width input-image) (image-height input-image)))
-	(x-offset (if (> (image-width input-image) (image-height input-image))
-		      (round (/ (- (image-width input-image) (image-height input-image)) 2))
-		      0)))
+        (square-size (min (image-width input-image) (image-height input-image)))
+        (x-offset (if (> (image-width input-image) (image-height input-image))
+                      (round (/ (- (image-width input-image) (image-height input-image)) 2))
+                      0)))
     (copy-image input-image button-image
-		x-offset 0
-		0 0
-		square-size square-size
-		:resize t :resample t
-		:dest-width *button-size* :dest-height *button-size*)
+                x-offset 0
+                0 0
+                square-size square-size
+                :resize t :resample t
+                :dest-width *button-size* :dest-height *button-size*)
     (when keyword
       (let ((type-store-image (store-image-with-name (format nil "type-~(~A~)" keyword))))
-	(unless type-store-image
-	  (error "can't find type image for keyword ~A" keyword))
-	(with-store-image (type-image type-store-image)
-	  (copy-image type-image button-image
-		      0 0
-		      0 0
-		      (image-width type-image) (image-height type-image)))))
+        (unless type-store-image
+          (error "can't find type image for keyword ~A" keyword))
+        (with-store-image (type-image type-store-image)
+          (copy-image type-image button-image
+                      0 0
+                      0 0
+                      (image-width type-image) (image-height type-image)))))
     (with-store-image (mask-image (store-image-with-name "button-mask"))
-      #-(or) ;; notyet
       (let ((color (parse-color background-color :image mask-image))
-	    (white (parse-color "ffffff" :image mask-image)))
-	(do-pixels (mask-image)
-	  (if (eql (ldb (byte 24 0) (raw-pixel)) white)
-	      (setf (raw-pixel) color))))
+            (white (parse-color "ffffff" :image mask-image)))
+        (do-pixels (mask-image)
+          (when t (eql (ldb (byte 24 0) (raw-pixel)) white)
+              (setf (raw-pixel) color))))
       (copy-image mask-image button-image
-		  0 0
-		  0 0
-		  *button-size* *button-size*))
+                  0 0
+                  0 0
+                  *button-size* *button-size*))
     button-image))
 
 (define-imageproc-handler center-thumbnail (input-image width height)

Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp	Wed Feb 13 15:22:21 2008
@@ -2,6 +2,8 @@
 
 (define-bknr-tag version-and-last-change (&rest args)
   (format *debug-io* "hello world: ~A~%" args)
-  (html "v1.1 | updated " (:princ-safe (string-downcase
-					(substitute #\Space #\-
-						    (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil))))))
\ No newline at end of file
+  (html "v1.1 | updated "
+        (:princ-safe (string-downcase
+                      (substitute #\Space #\-
+                                  (format-date-time (last-image-upload-timestamp)
+                                                    :vms-style t :show-time nil))))))
\ No newline at end of file

Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
==============================================================================
--- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	(original)
+++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	Wed Feb 13 15:22:21 2008
@@ -129,6 +129,8 @@
 
 (defun emit-without-quoting (str)
   ;; das ist fuer WPDISPLAY
+  (format t "emit-without-quoting does not work~%")
+  #+(or)
   (let ((s (cxml::chained-handler *html-sink*)))
     (cxml::maybe-close-tag s)
     (map nil (lambda (c) (cxml::write-rune c s)) str)))


From ksprotte at common-lisp.net  Thu Feb 14 05:56:36 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Thu, 14 Feb 2008 00:56:36 -0500 (EST)
Subject: [bknr-cvs] r2489 - branches/trunk-reorg/projects/bos/m2
Message-ID: <20080214055636.4EE5816054@common-lisp.net>

Author: ksprotte
Date: Thu Feb 14 00:56:35 2008
New Revision: 2489

Modified:
   branches/trunk-reorg/projects/bos/m2/bos.m2.asd
Log:
in bos.m2.asd: m2.lisp depends-on on geometry
dont know why this never became apparent earlier


Modified: branches/trunk-reorg/projects/bos/m2/bos.m2.asd
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/bos.m2.asd	(original)
+++ branches/trunk-reorg/projects/bos/m2/bos.m2.asd	Thu Feb 14 00:56:35 2008
@@ -15,7 +15,8 @@
 					"utils"
 					"make-certificate"
 					"mail-generator"
-					"geo-utm"))
+					"geo-utm"
+                                        "geometry"))
 	       (:file "contract-expiry" :depends-on ("m2"))
 	       (:file "allocation" :depends-on ("m2"))
 	       (:file "allocation-cache" :depends-on ("packages" "geometry"))


From hhubner at common-lisp.net  Thu Feb 14 08:10:52 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu, 14 Feb 2008 03:10:52 -0500 (EST)
Subject: [bknr-cvs] r2490 - branches/trunk-reorg/projects/quickhoney/src
Message-ID: <20080214081052.6264C5B074@common-lisp.net>

Author: hhubner
Date: Thu Feb 14 03:10:49 2008
New Revision: 2490

Modified:
   branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp
Log:
Fix bug that was not a bug


Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp	Thu Feb 14 03:10:49 2008
@@ -27,8 +27,8 @@
       (let ((color (parse-color background-color :image mask-image))
             (white (parse-color "ffffff" :image mask-image)))
         (do-pixels (mask-image)
-          (when t (eql (ldb (byte 24 0) (raw-pixel)) white)
-              (setf (raw-pixel) color))))
+          (when (eql (ldb (byte 24 0) (raw-pixel)) white)
+            (setf (raw-pixel) color))))
       (copy-image mask-image button-image
                   0 0
                   0 0


From hhubner at common-lisp.net  Thu Feb 14 09:02:24 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu, 14 Feb 2008 04:02:24 -0500 (EST)
Subject: [bknr-cvs] r2491 - in branches/trunk-reorg/thirdparty: slime
	uffi-1.6.0/src
Message-ID: <20080214090224.0D63B4083@common-lisp.net>

Author: hhubner
Date: Thu Feb 14 04:02:22 2008
New Revision: 2491

Modified:
   branches/trunk-reorg/thirdparty/slime/swank.lisp
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp
Log:
Fixes for thirdparty packages to make quickhoney run on CCL (and it does!):

UFFI:  Support pointer-to-pointer in structures
SLIME: Fix Marco's package deletion fix again


Modified: branches/trunk-reorg/thirdparty/slime/swank.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/slime/swank.lisp	(original)
+++ branches/trunk-reorg/thirdparty/slime/swank.lisp	Thu Feb 14 04:02:22 2008
@@ -82,9 +82,12 @@
   "Abbreviate dotted package names to their last component if T.")
 
 (defvar *swank-io-package*
-  (let ((package (make-package :swank-io-package :use '())))
-    (import '(nil t quote) package)
-    package))
+  (progn
+    (when (find-package :swank-io-package)
+      (delete-package :swank-io-package))
+    (let ((package (make-package :swank-io-package :use '())))
+      (import '(nil t quote) package)
+      package)))
 
 (defconstant default-server-port 4005
   "The default TCP port for the server (when started manually).")

Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp	(original)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/primitives.lisp	Thu Feb 14 04:02:22 2008
@@ -286,7 +286,10 @@
      #+openmcl
      ((eq (car result) :address)
       (if (eq context :struct)
-	  (append '(:*) (cdr result))
+	  (append '(:*) (if (listp (cadr result))
+                            ;; hack to make pointers to pointers work
+                            (list (convert-from-uffi-type (cadr result) context))
+                            (cdr result)))
 	:address))
      #+digitool
      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))


From hhubner at common-lisp.net  Thu Feb 14 12:12:34 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu, 14 Feb 2008 07:12:34 -0500 (EST)
Subject: [bknr-cvs] r2492 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080214121234.D819F6D08E@common-lisp.net>

Author: hhubner
Date: Thu Feb 14 07:12:33 2008
New Revision: 2492

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
Log:
Fix with-bknr-page


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Thu Feb 14 07:12:33 2008
@@ -534,7 +534,8 @@
   (setf (return-code) response)
   (handler-case
       (let ((body (with-output-to-string (*html-stream*)
-		    (website-show-page *website* fn title))))
+                    (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3)))
+                      (website-show-page *website* fn title)))))
 	(with-http-response (:content-type "text/html; charset=UTF-8" :response response)
 	  (with-http-body ()
 	    (princ body *html-stream*))))


From ksprotte at common-lisp.net  Thu Feb 14 12:23:15 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Thu, 14 Feb 2008 07:23:15 -0500 (EST)
Subject: [bknr-cvs] r2493 - branches/trunk-reorg/projects/hello-web/src
Message-ID: <20080214122315.68D102F04E@common-lisp.net>

Author: ksprotte
Date: Thu Feb 14 07:23:14 2008
New Revision: 2493

Modified:
   branches/trunk-reorg/projects/hello-web/src/config.lisp
   branches/trunk-reorg/projects/hello-web/src/hello-web.asd
   branches/trunk-reorg/projects/hello-web/src/init.lisp
   branches/trunk-reorg/projects/hello-web/src/packages.lisp
   branches/trunk-reorg/projects/hello-web/src/webserver.lisp
Log:
ported hello-web for trunk-reorg


Modified: branches/trunk-reorg/projects/hello-web/src/config.lisp
==============================================================================
--- branches/trunk-reorg/projects/hello-web/src/config.lisp	(original)
+++ branches/trunk-reorg/projects/hello-web/src/config.lisp	Thu Feb 14 07:23:14 2008
@@ -3,10 +3,15 @@
 ;; URL f?r BASE HREFs
 (defparameter *website-url* "http://hello-web.bknr.net")
 
-(defparameter *root-directory* #p"home:bknr-svn/projects/hello-web/")
+(defparameter *root-directory*
+  (let ((system-path (asdf:component-pathname (asdf:find-system :hello-web))))
+    (truename
+     (merge-pathnames (make-pathname :directory '(:relative :up) :defaults system-path)
+                      system-path))))
 
 (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*))
 
 (defparameter *website-directory* (merge-pathnames #p"website/" *root-directory*))
 
-(defparameter *webserver-port* 8080)
\ No newline at end of file
+(defparameter *webserver-port* 8080)
+(defvar *webserver* nil)

Modified: branches/trunk-reorg/projects/hello-web/src/hello-web.asd
==============================================================================
--- branches/trunk-reorg/projects/hello-web/src/hello-web.asd	(original)
+++ branches/trunk-reorg/projects/hello-web/src/hello-web.asd	Thu Feb 14 07:23:14 2008
@@ -17,8 +17,7 @@
   :long-description ""
 
   :depends-on (:cl-interpol
-	       :cl-ppcre
-	       :aserve
+	       :cl-ppcre	       
 	       :cxml
 	       :bknr-modules)
 

Modified: branches/trunk-reorg/projects/hello-web/src/init.lisp
==============================================================================
--- branches/trunk-reorg/projects/hello-web/src/init.lisp	(original)
+++ branches/trunk-reorg/projects/hello-web/src/init.lisp	Thu Feb 14 07:23:14 2008
@@ -1,17 +1,29 @@
 (in-package :hello-web)
 
-(defun startup ()
+(defun startup (&key debug)
   (when *store*
     (close-store))
+  ;; XXX hack hack hack
+  (mapcar #'cl-gd::load-foreign-library
+	  '("/usr/lib/libcrypto.so"
+	    "/usr/lib/libssl.so"
+	    "/usr/local/lib/libgd.so"
+	    "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so"))
+  (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
   (make-instance 'store
 		 :directory *store-directory*
 		 :subsystems (list (make-instance 'store-object-subsystem)
 				   (make-instance 'blob-subsystem
 						  :n-blobs-per-directory 1000)))
   (unless (find-user "anonymous")
-    (make-user "anonymous")		; used for all anonymous sessions
+    (make-user "anonymous")          ; used for all anonymous sessions
     (make-user "admin" :password "admin" :full-name "Administrator" :flags '(:admin))
-    (import-image "bknr-logo.png" :keywords '(:banner :bknr))
+    (import-image (merge-pathnames #p"src/bknr-logo.png" hello-web.config:*root-directory*)
+                  :keywords '(:banner :bknr))
     (make-rss-channel "default" "BKNR Hello Web" "default RSS channel of the BKNR hello web site" *website-url*))
   
-  (publish-hello-web))
+  (publish-hello-web)
+  (setq hunchentoot:*catch-errors-p* (not debug))
+  (when *webserver*
+    (hunchentoot:stop-server *webserver*))
+  (setq *webserver* (hunchentoot:start-server :port *webserver-port*)))

Modified: branches/trunk-reorg/projects/hello-web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/hello-web/src/packages.lisp	(original)
+++ branches/trunk-reorg/projects/hello-web/src/packages.lisp	Thu Feb 14 07:23:14 2008
@@ -6,17 +6,17 @@
   (:export #:*website-url*
 	   #:*website-directory*
 	   #:*webserver-port*
-	   #:*store-directory*))
+           #:*webserver*
+	   #:*store-directory*
+           #:*root-directory*))
 
 (defpackage :hello-web.tags
   (:use :cl
 	:cl-user
-	:ext
 	:bknr.web
 	:xhtml-generator
 	:hello-web.config)
-  (:shadowing-import-from :cl-interpol #:quote-meta-chars)
-  (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)
+  (:shadowing-import-from :cl-interpol #:quote-meta-chars)  
   (:export #:hello))
 
 (defpackage :hello-web.imageproc
@@ -31,7 +31,6 @@
 (defpackage :hello-web
   (:use :cl
 	:cl-user
-	:ext
 	:cl-interpol
 	:cl-ppcre
 	:bknr.utils

Modified: branches/trunk-reorg/projects/hello-web/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/hello-web/src/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/hello-web/src/webserver.lisp	Thu Feb 14 07:23:14 2008
@@ -7,29 +7,27 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defun publish-hello-web (&key (port *webserver-port*) (listeners 20))
-
+(defun publish-hello-web ()
   (make-instance 'website
 		 :name "Hello Web CMS"
 		 :handler-definitions `(("/hello-object" hello-object-handler)
 					("/" redirect-handler
-					 :prefix "/" :to "/index")
+                                             :prefix "/" :to "/index")
 					("/rss" rss-handler)
 					("/" template-handler
-					 :prefix "/"
-					 :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*))
-					 :command-packages ((:hello-web . :hello-web.tags)
-							    (:bknr . :bknr.web)
-							    (:menu . :bknr.site-menu)))
+                                             :prefix "/"
+                                             :destination ,(namestring (merge-pathnames #p"templates/" *website-directory*))
+                                             :command-packages (("http://hello-web.bknr.net" . :hello-web.tags)
+                                                                ("http://bknr.net" . :bknr.web)))
+                                        images
+                                        user
 					("/static" directory-handler
-					 :destination ,(unix-namestring (merge-pathnames #p"static/" *website-directory*))))
-		 :modules '(images user)
+                                                   :destination ,(namestring (merge-pathnames #p"static/" *website-directory*))))	       
 		 :admin-navigation '(("user" . "/user/")
 				     ("images" . "/edit-images")
 				     ("import" . "/import")
 				     ("logout" . "/logout"))
 		 :authorizer (make-instance 'bknr-authorizer)
 		 :style-sheet-urls '("/static/styles.css")
-		 :javascript-urls '("/static/javascript.js"))
+		 :javascript-urls '("/static/javascript.js")))
 
-  (start :port port :listeners listeners))


From ksprotte at common-lisp.net  Thu Feb 14 12:25:24 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Thu, 14 Feb 2008 07:25:24 -0500 (EST)
Subject: [bknr-cvs] r2494 - branches/trunk-reorg
Message-ID: <20080214122524.9B6285C180@common-lisp.net>

Author: ksprotte
Date: Thu Feb 14 07:25:23 2008
New Revision: 2494

Modified:
   branches/trunk-reorg/   (props changed)
Log:
svn property ignore asd dir on the rootlevel



From hhubner at common-lisp.net  Thu Feb 14 14:13:32 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu, 14 Feb 2008 09:13:32 -0500 (EST)
Subject: [bknr-cvs] r2495 - branches/trunk-reorg/projects/quickhoney/src
Message-ID: <20080214141332.E8495691A3@common-lisp.net>

Author: hhubner
Date: Thu Feb 14 09:13:32 2008
New Revision: 2495

Modified:
   branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
Log:
Fix handler order so that /image-detail template is seen before /image prefix handler


Modified: branches/trunk-reorg/projects/quickhoney/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/webserver.lisp	Thu Feb 14 09:13:32 2008
@@ -33,17 +33,17 @@
 					("/admin" admin-handler)
 					("/" redirect-handler
 					 :to "/frontpage")
+					("/" template-handler
+					 :destination ,(namestring (merge-pathnames "templates/" *website-directory*))
+					 :command-packages (("http://quickhoney.com/" . :quickhoney.tags)
+							    ("http://bknr.net/" . :bknr.web)))
 					user
 					images
 					("/static" directory-handler
 					 :destination ,(merge-pathnames #p"static/" *website-directory*))
 					("/favicon.ico" file-handler
 					 :destination ,(merge-pathnames #p"static/favicon.ico" *website-directory*)
-					 :content-type "application/x-icon")
-					("/" template-handler
-					 :destination ,(namestring (merge-pathnames "templates/" *website-directory*))
-					 :command-packages (("http://quickhoney.com/" . :quickhoney.tags)
-							    ("http://bknr.net/" . :bknr.web))))
+					 :content-type "application/x-icon"))
 		 :admin-navigation '(("user" . "/user/")
 				     ("images" . "/edit-images")
 				     ("import" . "/import")


From ksprotte at common-lisp.net  Thu Feb 14 15:42:55 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Thu, 14 Feb 2008 10:42:55 -0500 (EST)
Subject: [bknr-cvs] r2496 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080214154255.8F218690E5@common-lisp.net>

Author: ksprotte
Date: Thu Feb 14 10:42:55 2008
New Revision: 2496

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
Log:
tweaked with-http-body and website-show-error-page


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Thu Feb 14 10:42:55 2008
@@ -499,10 +499,9 @@
     (ensure-directories-exist spool-dir)
     spool-dir))
 
-(defmethod website-show-page ((website website) fn title)
-  (html
-   (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*)
-   (princ #\Newline *html-stream*)
+(defmethod website-show-page ((website website) fn title)  
+  (html   
+      
    (:html
     (:head
      (header :title title))
@@ -515,34 +514,11 @@
      (funcall fn)
      (session-info)))))
 
-(defmethod website-show-error-page ((website website) error)
-  (if (website-template-handler website)
-      (send-error-response (website-template-handler website) (princ-to-string error))
-      (html
-       (princ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" *html-stream*)
-       (princ #\Newline *html-stream*)
-       (:html
-        (:head
-         (header :title "Error processing your request"))
-        ((:body :class "cms")
-         (:h1 "Error processing your request")
-         (:p "While processing your request, an error occured:")
-         ((:div :class "error")
-	  (:princ-safe error)))))))
-
 (defun show-page-with-error-handlers (fn &key (response +http-ok+) title)
   (setf (return-code) response)
-  (handler-case
-      (let ((body (with-output-to-string (*html-stream*)
-                    (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3)))
-                      (website-show-page *website* fn title)))))
-	(with-http-response (:content-type "text/html; charset=UTF-8" :response response)
-	  (with-http-body ()
-	    (princ body *html-stream*))))
-    (serious-condition (c)
-      (with-http-response (:content-type "text/html; charset=UTF-8" :response +http-internal-server-error+)
-	(with-http-body ()
-	  (website-show-error-page *website* c))))))
+  (with-http-response (:content-type "text/html; charset=UTF-8" :response response)
+    (with-http-body ()
+      (website-show-page *website* fn title))))
 
 (defmacro with-bknr-page ((&rest args) &body body)
   `(show-page-with-error-handlers (lambda () (html , at body)) , at args))

Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	Thu Feb 14 10:42:55 2008
@@ -54,7 +54,14 @@
 
 (defmacro with-http-body ((&key external-format) &body body)
   `(with-output-to-string (*html-stream*)
-    , at body))
+     (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3)))
+       (sax:start-document *html-sink*)
+       (sax:start-dtd *html-sink*
+                      "html"
+                      "-//W3C//DTD XHTML 1.0 Transitional//EN"
+                      "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")       
+       , at body
+       (sax:end-document *html-sink*))))
 
 (defmacro with-image-from-uri ((image-variable prefix) &rest body)
   `(multiple-value-bind


From hhubner at common-lisp.net  Thu Feb 14 16:11:05 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Thu, 14 Feb 2008 11:11:05 -0500 (EST)
Subject: [bknr-cvs] r2497 - in branches/trunk-reorg:
	bknr/datastore/src/utils bknr/web/src/images
	bknr/web/src/sysclasses bknr/web/src/web xhtmlgen
Message-ID: <20080214161105.B8A305C189@common-lisp.net>

Author: hhubner
Date: Thu Feb 14 11:11:03 2008
New Revision: 2497

Modified:
   branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp
   branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp
   branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
   branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp
   branches/trunk-reorg/bknr/web/src/web/authorizer.lisp
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
   branches/trunk-reorg/xhtmlgen/package.lisp
   branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
Log:
if-modified-since fixed for images
password checking fixed
login works again, needs more testing
xhtmlgen fixed, new macro with-xhtml to set up doctype


Modified: branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/crypt-md5.lisp	Thu Feb 14 11:11:03 2008
@@ -66,7 +66,7 @@
   (unless (string-equal (subseq saltpw 0 3) "$1$")
     (error "not a md5 password ~a" saltpw))
   (let ((salt (extract-salt saltpw)))
-    (string-equal (crypt-md5 password salt) saltpw)))
+    (string-equal (crypt-md5 (coerce password 'simple-string) salt) saltpw)))
 
 ;; 0 6 12 (4)
 ;; 1 7 13 (4)

Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp	Thu Feb 14 11:11:03 2008
@@ -34,7 +34,8 @@
 
 (defmethod object-handler-get-object ((handler image-handler))
   (let ((id-or-name (parse-url)))
-    (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name)))
+    (when id-or-name
+      (find-store-object id-or-name :class 'store-image :query-function #'store-image-with-name))))
 
 (defclass browse-image-handler (image-handler)
   ())

Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	Thu Feb 14 11:11:03 2008
@@ -167,21 +167,8 @@
   (error-404))
 
 (defmethod handle-object ((page-handler imageproc-handler) image)
-  (format t "if-modfied-since not implemented for hunchentoot~%")
   (with-http-response (:content-type (image-content-type (image-type-keyword image)))
-    (with-http-body ()
-      (imageproc image (cdr (decoded-handler-path page-handler)))))
-  #+(or)
-  (with-http-response (:content-type (image-content-type (image-type-keyword image)))
-    (let ((ims (header-in :if-modified-since))
-          (changed-time (blob-timestamp image)))
-      (setf (header-out :last-modified) (rfc-1123-date changed-time))
-      (if (and ims
-               (<= changed-time (date-to-universal-time ims)))
-          (progn
-            (setf (return-code) +http-not-modified+)
-            (format t "; image ~A not changed~%" image)
-            (with-http-body ()))
-          (with-http-body ()
-            (imageproc image (cdr (decoded-handler-path page-handler))))))))
+    (handle-if-modified-since (blob-timestamp image))
+    (setf (header-out "Last-Modified") (rfc-1123-date (blob-timestamp image)))
+    (imageproc image (cdr (decoded-handler-path page-handler)))))
     

Modified: branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/sysclasses/user.lisp	Thu Feb 14 11:11:03 2008
@@ -110,10 +110,11 @@
 (defmethod verify-password ((user user) password)
   (when password
     (let ((upw (user-password user)))
-      (if (string-equal "$1$" (subseq upw 0 3))
+      (if (equal "$1$" (and (> (length upw) 3) (subseq upw 0 3)))
 	  (verify-md5-password password (user-password user))
-	  (equal upw
-		 (crypt password (subseq upw 0 +salt-length+)))))))
+          (when (> (length upw) +salt-length+)
+            (equal upw
+                   (crypt password (subseq upw 0 +salt-length+))))))))
 
 (defmethod user-disabled ((user user))
   (user-has-flag user :disabled))

Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp	Thu Feb 14 11:11:03 2008
@@ -21,15 +21,24 @@
   "check whether the request has a valid session id in either the bknr-sessionid cookie or query parameter"
   (session-value 'bknr-session))
 
-(defmethod find-user-from-request-parameters ((authorizer bknr-authorizer))
+(define-condition login-failure (serious-condition)
+  ()
+  (:report (lambda (c s)
+             (declare (ignore c))
+             (format s "Login failed"))))
+
+(defun find-user-from-request-parameters ()
   (with-query-params (__username __password)
-    (when (and __username (not (equal __username "")))
-      (let ((user (find-user __username)))
-	(when user
-	  (if (and (not (user-disabled user))
+    (unless (and __username __password
+                 (not (equal __username ""))
+                 (not (equal __password "")))
+      (return-from find-user-from-request-parameters nil))
+    (let ((user (find-user __username)))
+	(when (and user
+                   (not (user-disabled user))
 		   (verify-password user __password))
-	      user
-	      (warn "login failure for user ~a~%" user)))))))
+          (return-from find-user-from-request-parameters user)))
+    (error 'login-failure)))
 
 (defmethod authorize ((authorizer bknr-authorizer))
   ;; Catch any errors that occur during request body processing

Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Thu Feb 14 11:11:03 2008
@@ -221,10 +221,6 @@
 	t)))
 
 (defmethod invoke-handler ((handler page-handler))
-  (start-session)
-  (unless (session-value 'bknr-session)
-    (setf (session-value 'bknr-session)
-	  (make-instance 'bknr-session :user (find-user "anonymous"))))
   (let* ((*website* (page-handler-site handler))
 	 (*req-var-hash* (or *req-var-hash*
 			     (make-hash-table))))
@@ -255,10 +251,28 @@
 
 (defvar *handlers* nil)
 
+(defun ensure-bknr-session ()
+  "Ensure that the BKNR-SESSION session variable is set and that it
+belongs to the user that is specified in the request."
+  (let ((request-user (find-user-from-request-parameters)))
+    (unless (and (session-value 'bknr-session)
+                 (equal (bknr-session-user)
+                        (find-user-from-request-parameters)))
+      (setf (session-value 'bknr-session)
+            (make-instance 'bknr-session :user (or request-user
+                                                   (find-user "anonymous")))))))
+
 (defun bknr-dispatch (request)
   (declare (ignore request))
-  (when-let ((handler (find-if #'handler-matches (website-handlers *website*))))
-    (curry #'invoke-handler handler)))
+  (let ((handler (find-if #'handler-matches (website-handlers *website*))))
+    (cond
+      (handler
+       (start-session)
+       (ensure-bknr-session)
+       (when (authorize (website-authorizer *website*))
+         (curry #'invoke-handler handler)))
+      (t
+       'error-404))))
 
 (defmethod publish-handler ((website website) (handler page-handler))
   (setf *handlers* (append *handlers* (list handler))))
@@ -309,6 +323,12 @@
 (defclass prefix-handler (page-handler)
   ())
 
+#+(or)
+(defmethod initialize-instance :after ((handler prefix-handler) &key)
+  (unless (eql #\/ (aref (page-handler-prefix handler)
+                         (1- (length (page-handler-prefix handler)))))
+    (warn "prefix handler ~A does not have prefix ending with / - may match unexpectedly" handler)))
+
 (defmethod handler-matches ((handler prefix-handler))
   (and (>= (length (script-name))
 	   (length (page-handler-prefix handler)))

Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	Thu Feb 14 11:11:03 2008
@@ -24,10 +24,10 @@
   (let ((vars (loop for param in params
 		    when (and (symbolp param)
 			      (not (null param)))
-		    collect (list param `(get-parameter ,(symbol-name param)))
+		    collect (list param `(get-parameter ,(string-downcase (symbol-name param))))
 		    when (consp param)
 		    collect (list (car param)
-				  `(or (get-parameter ,(symbol-name (car param)))
+				  `(or (get-parameter ,(string-downcase (symbol-name (car param))))
 				    ,(second param))))))
     (if vars
 	`(let ,vars
@@ -54,14 +54,8 @@
 
 (defmacro with-http-body ((&key external-format) &body body)
   `(with-output-to-string (*html-stream*)
-     (let ((*html-sink* (cxml:make-character-stream-sink *html-stream* :canonical nil :indentation 3)))
-       (sax:start-document *html-sink*)
-       (sax:start-dtd *html-sink*
-                      "html"
-                      "-//W3C//DTD XHTML 1.0 Transitional//EN"
-                      "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")       
-       , at body
-       (sax:end-document *html-sink*))))
+    (with-xhtml (*html-stream*)
+      , at body)))
 
 (defmacro with-image-from-uri ((image-variable prefix) &rest body)
   `(multiple-value-bind

Modified: branches/trunk-reorg/xhtmlgen/package.lisp
==============================================================================
--- branches/trunk-reorg/xhtmlgen/package.lisp	(original)
+++ branches/trunk-reorg/xhtmlgen/package.lisp	Thu Feb 14 11:11:03 2008
@@ -4,6 +4,6 @@
   (:use :common-lisp)
   (:export #:html
 	   #:html-stream
-	   #:*html-sink*
-	   #:set-string-encoding))
+           #:with-xhtml
+	   #:*html-sink*))
 

Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
==============================================================================
--- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	(original)
+++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	Thu Feb 14 11:11:03 2008
@@ -53,13 +53,26 @@
 	  (,body)
 	  (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3)))
 	    (,body)
-	    (sax:end-document *html-sink*))))))
+            (sax:end-document *html-sink*))))))
 
 (defmacro html-stream (stream &rest forms &environment env)
   `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3)))
     ,(process-html-forms forms env)
     (sax:end-document *html-sink*)))
 
+(defmacro with-xhtml ((&optional stream &key (indentation 3)) &body body)
+  `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation ,indentation)))
+    (sax:start-document *html-sink*)
+    (sax:start-dtd *html-sink*
+     "html"
+     "-//W3C//DTD XHTML 1.0 Transitional//EN"
+     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
+    (sax:end-dtd *html-sink*)
+    (multiple-value-prog1
+        (html
+          , at body)
+      (sax:end-document *html-sink*))))
+
 (defun get-process (form)
   (let ((ent (gethash form *html-process-table*)))
     (unless ent


From hhubner at common-lisp.net  Fri Feb 15 06:42:31 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 01:42:31 -0500 (EST)
Subject: [bknr-cvs] r2498 - branches/bos/projects/bos/web
Message-ID: <20080215064231.A524C5F061@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 01:42:26 2008
New Revision: 2498

Modified:
   branches/bos/projects/bos/web/sponsor-handlers.lisp
Log:
merge 2462, fix password setting through CMS

Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/sponsor-handlers.lisp	Fri Feb 15 01:42:26 2008
@@ -181,9 +181,7 @@
 	(let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
 		     (not (equal field-value (slot-value sponsor field-name))))
-            (if (eq field-name 'password)
-                (set-user-password sponsor field-value)
-                (change-slot-values sponsor field-name field-value))
+	    (change-slot-values sponsor field-name field-value)
 	    (setf changed t)
 	    (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
       (dolist (contract (sponsor-contracts sponsor))


From ksprotte at common-lisp.net  Fri Feb 15 11:51:11 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri, 15 Feb 2008 06:51:11 -0500 (EST)
Subject: [bknr-cvs] r2499 - in branches/trunk-reorg/projects/bos: m2 web
Message-ID: <20080215115111.14AC54F052@common-lisp.net>

Author: ksprotte
Date: Fri Feb 15 06:51:09 2008
New Revision: 2499

Modified:
   branches/trunk-reorg/projects/bos/m2/geometry.lisp
   branches/trunk-reorg/projects/bos/m2/make-certificate.lisp
   branches/trunk-reorg/projects/bos/m2/packages.lisp
   branches/trunk-reorg/projects/bos/web/tags.lisp
Log:
manually merged over some chs from bos branch

Modified: branches/trunk-reorg/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/geometry.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/geometry.lisp	Fri Feb 15 06:51:09 2008
@@ -214,3 +214,56 @@
       (traverse boundary-point initial-direction)
       (nreverse polygon))))
 
+
+;;; formatting
+;; proposed by Michael Weber on alexandria-devel
+(defun format-mixed-radix-number (stream number radix-list format-list
+                                  &key lsb-first leading-zeros
+				  (trailing-zeros t))
+  "Prints NUMBER to STREAM in mixed-radix RADIX.
+representation-LIST is a list of radixes, least-significant first.
+FORMAT-LIST is a list of format directives, one for each digit.
+When LSB-FIRST is nil (default), print most-significant digit first,
+otherwise least-significant digit first.
+When LEADING-ZEROS and TRAILING-ZEROS are nil, leading and
+trailing zero digits are not printed, respectively. \(default: remove
+leading zeros, keep trailing zeros)"
+  (let ((format-pairs
+         (loop with digit and fraction
+	    initially (setf (values number fraction)
+			    (truncate number))
+	    for f-list on format-list
+	    and r-list = radix-list then (rest r-list)
+	    collect (list (first f-list)
+			  (cond ((endp r-list)
+				 (shiftf number 0))
+				((rest f-list)
+				 (setf (values number digit)
+				       (truncate number (first r-list)))
+				 digit)
+				(t number)))
+	    into list
+	    finally (progn
+		      (incf (cadar list) fraction)
+		      (return (nreverse list))))))
+    (unless trailing-zeros
+      (setf format-pairs (member-if #'plusp format-pairs :key
+				    #'second)))
+    (when lsb-first
+      (setf format-pairs (nreverse format-pairs)))
+    (unless leading-zeros
+      (setf format-pairs (member-if #'plusp format-pairs :key
+				    #'second)))
+    (format stream "~{~{~@?~}~}" format-pairs)))
+
+
+(defun format-decimal-degree (degree)
+  (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F??" " ~D?" "~D?")))
+
+(defun format-lon-lat (stream lon lat)
+  (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]"
+	  (format-decimal-degree (abs lat))
+	  (plusp lat)
+	  (format-decimal-degree (abs lon))
+	  (plusp lon)))
+

Modified: branches/trunk-reorg/projects/bos/m2/make-certificate.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/make-certificate.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/make-certificate.lisp	Fri Feb 15 06:51:09 2008
@@ -42,8 +42,19 @@
 		   :sponsor-id (sponsor-id sponsor)
 		   :master-code (sponsor-master-code sponsor)
 		   :sqm-count (length (contract-m2s contract))
-		   :sqm-ids (with-output-to-string (s)
-			      (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*)
-				    do (loop for nums on group
-					     do (princ (car nums) s)
-					     do (princ (if (cdr nums) #\Tab #\Newline) s)))))))
+		   ;; :sqm-ids (with-output-to-string (s)
+		   ;; 			      (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*)
+		   ;; 				 do (loop for nums on group
+		   ;; 				       do (princ (car nums) s)
+		   ;; 				       do (princ (if (cdr nums) #\Tab #\Newline) s))))
+		   ;; should later be called :sqm-coordinates
+		   :sqm-ids
+		   (flet ((format-point (stream x y)
+			    (apply #'geometry:format-lon-lat stream
+				   (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x)
+							       (- +nw-utm-y+ y) +utm-zone+ t))))
+		     (destructuring-bind (left top width height)
+			 (contract-bounding-box contract)
+		       (with-output-to-string (out)
+			 (format-point out left top) (terpri out)			 
+			 (format-point out (+ left width) (+ top height)) (terpri out)))))))

Modified: branches/trunk-reorg/projects/bos/m2/packages.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/packages.lisp	(original)
+++ branches/trunk-reorg/projects/bos/m2/packages.lisp	Fri Feb 15 06:51:09 2008
@@ -9,7 +9,8 @@
 	   #:point-in-polygon-p
 	   #:point-in-circle-p
 	   #:find-boundary-point
-	   #:region-to-polygon))
+	   #:region-to-polygon
+	   #:format-lon-lat))
 
 (defpackage :geo-utm
   (:use :cl)

Modified: branches/trunk-reorg/projects/bos/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/tags.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/tags.lisp	Fri Feb 15 06:51:09 2008
@@ -167,8 +167,14 @@
     (setf (get-template-var :country) (sponsor-country sponsor))
     (setf (get-template-var :infotext) (sponsor-info-text sponsor))
     (setf (get-template-var :name) (user-full-name sponsor))
-    (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract)))))
-    (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract)))))
+    (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) 
+    (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) 
+    (setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore)
+                                            (contract-bounding-box contract)
+                                          (declare (ignore ignore))
+                                          (apply #'geometry:format-lon-lat nil
+                                                 (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left)
+                                                                             (- +nw-utm-y+ top) +utm-zone+ t))))
     (setf (get-template-var :numsqm)
 	  (format nil "~D"
 		  (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))


From ksprotte at common-lisp.net  Fri Feb 15 12:21:24 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri, 15 Feb 2008 07:21:24 -0500 (EST)
Subject: [bknr-cvs] r2500 - in branches/bos/projects/bos:
	payment-website/infosystem payment-website/templates/da
	payment-website/templates/de payment-website/templates/en web
Message-ID: <20080215122124.1F1C32F067@common-lisp.net>

Author: ksprotte
Date: Fri Feb 15 07:21:20 2008
New Revision: 2500

Modified:
   branches/bos/projects/bos/payment-website/infosystem/javascript.js
   branches/bos/projects/bos/payment-website/templates/da/profil.xml
   branches/bos/projects/bos/payment-website/templates/de/profil.xml
   branches/bos/projects/bos/payment-website/templates/en/profil.xml
   branches/bos/projects/bos/web/sponsor-handlers.lisp
Log:
removed Google Earth links

Modified: branches/bos/projects/bos/payment-website/infosystem/javascript.js
==============================================================================
--- branches/bos/projects/bos/payment-website/infosystem/javascript.js	(original)
+++ branches/bos/projects/bos/payment-website/infosystem/javascript.js	Fri Feb 15 07:21:20 2008
@@ -397,9 +397,6 @@
 		+ ' m?</td></tr><tr> <td width="60" class="PoiNavigation">'
 		+ msg('seit') + ':</td><td class="PoiNavigation">' + n_profil.contracts[0].date
 		+ '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="10"/></td></tr>'		
-		+ '</td></tr><tr><td colspan="2" class="PoiNavigation"><a href="' + http_pfad +
-		  '/contract-kml/' + n_profil.contracts[0].id + '">Google Earth View</a></td></tr>'
-		+ '</td></tr><tr> <td colspan="2" class="PoiNavigation"><img src="/infosystem/bilder/spacer.gif" width="1" height="20"/></td></tr>'
 		+ '<tr> <td colspan="2" class="PoiNavigation">'
 		+ n_profil['nachricht']
 		+ '</td></tr></table>';

Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/da/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/da/profil.xml	Fri Feb 15 07:21:20 2008
@@ -55,8 +55,7 @@
      </tr>
      <tr>
       <td class="Label">kvardratmeter</td>
-      <td class="Input">til v?rdi af $(numsqm) m? er blevet opk?bt<br></br>kordinater: $(geo-coord)
-	<br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td>      
+      <td class="Input">til v?rdi af $(numsqm) m? er blevet opk?bt<br></br>kordinater: $(geo-coord)</td>
       <td class="Info"></td>
      </tr>
      <tr>

Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/de/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/de/profil.xml	Fri Feb 15 07:21:20 2008
@@ -60,8 +60,7 @@
      </tr>
      <tr>
       <td class="Label">Quadratmeter</td>
-      <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />Koordinate: $(geo-coord)
-      <br /><a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td>
+      <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft<br />Koordinate: $(geo-coord)</td>
       <td class="Info"></td>
      </tr>
      <tr>

Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml
==============================================================================
--- branches/bos/projects/bos/payment-website/templates/en/profil.xml	(original)
+++ branches/bos/projects/bos/payment-website/templates/en/profil.xml	Fri Feb 15 07:21:20 2008
@@ -60,8 +60,7 @@
      </tr>
      <tr>
       <td class="Label">square metres</td>
-      <td class="Input">a total of $(numsqm) m? has been bought<br />coordinate: $(geo-coord)
-      <br /><a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td>
+      <td class="Input">a total of $(numsqm) m? has been bought<br />coordinate: $(geo-coord)</td>
       <td class="Info"></td>
      </tr>
      <tr>

Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/sponsor-handlers.lisp	Fri Feb 15 07:21:20 2008
@@ -160,9 +160,7 @@
 					 (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor)))))
 					 (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor))))))))
 		    (:td (:princ-safe (if (contract-paidp contract) "paid" "not paid")))
-		    (:td (cmslink (format nil "contract-kml/~A" (store-object-id contract)) "Google Earth")
-			 :br
-			 (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
+		    (:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
 			 (when (probe-file (contract-pdf-pathname contract))
 			   (html :br (cmslink (contract-pdf-url contract) "Show Certificate")))
 			 (when (contract-worldpay-trans-id contract)


From ksprotte at common-lisp.net  Fri Feb 15 12:36:38 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri, 15 Feb 2008 07:36:38 -0500 (EST)
Subject: [bknr-cvs] r2501 - branches/bos/projects/bos/web
Message-ID: <20080215123638.7D4CC44052@common-lisp.net>

Author: ksprotte
Date: Fri Feb 15 07:36:38 2008
New Revision: 2501

Modified:
   branches/bos/projects/bos/web/sponsor-handlers.lisp
Log:
fix in sponsor-handlers for changing password by explicitly using SET-USER-PASSWORD


Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/sponsor-handlers.lisp	Fri Feb 15 07:36:38 2008
@@ -179,7 +179,9 @@
 	(let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
 		     (not (equal field-value (slot-value sponsor field-name))))
-	    (change-slot-values sponsor field-name field-value)
+	    (case field-name
+              (password (set-user-password sponsor field-value))
+              (t (change-slot-values sponsor field-name field-value)))
 	    (setf changed t)
 	    (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
       (dolist (contract (sponsor-contracts sponsor))


From ksprotte at common-lisp.net  Fri Feb 15 12:39:33 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Fri, 15 Feb 2008 07:39:33 -0500 (EST)
Subject: [bknr-cvs] r2502 - branches/trunk-reorg/projects/bos/web
Message-ID: <20080215123933.E287469139@common-lisp.net>

Author: ksprotte
Date: Fri Feb 15 07:39:33 2008
New Revision: 2502

Modified:
   branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
Log:
fix in sponsor-handlers for changing password by explicitly using SET-USER-PASSWORD


Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	(original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp	Fri Feb 15 07:39:33 2008
@@ -181,7 +181,9 @@
 	(let ((field-value (query-param (string-downcase (symbol-name field-name)))))
 	  (when (and field-value
 		     (not (equal field-value (slot-value sponsor field-name))))
-	    (change-slot-values sponsor field-name field-value)
+	    (case field-name
+              (password (set-user-password sponsor field-value))
+              (t (change-slot-values sponsor field-name field-value)))
 	    (setf changed t)
 	    (html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
       (dolist (contract (sponsor-contracts sponsor))


From hhubner at common-lisp.net  Fri Feb 15 13:41:20 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 08:41:20 -0500 (EST)
Subject: [bknr-cvs] r2503 - branches/trunk-reorg/bknr/datastore/src/data
Message-ID: <20080215134120.D1F216913C@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 08:41:20 2008
New Revision: 2503

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/object.lisp
Log:
Rename and document some things.


Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/object.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp	Fri Feb 15 08:41:20 2008
@@ -5,8 +5,9 @@
 (cl-interpol:enable-interpol-syntax)
 
 (defclass store-object-subsystem ()
-  ((id-counter :initform 0
-	       :accessor id-counter)))
+  ((next-object-id :initform 0
+                   :accessor next-object-id
+                   :documentation "Next object ID to assign to a new object")))
 
 (defun store-object-subsystem ()
   (let ((subsystem (find-if (lambda (subsystem)
@@ -163,17 +164,16 @@
 	      (anonymous-transaction-transactions *current-transaction*)))
       (call-next-method)))
 
-(defmethod initialize-instance :after
-    ((object store-object) &key id &allow-other-keys)
+(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys)
   (let ((subsystem (store-object-subsystem)))
     (cond (id
 	   ;; during restore, use the given ID
-	   (when (>= id (id-counter subsystem))
-	     (setf (id-counter subsystem) (1+ id))))
+	   (when (>= id (next-object-id subsystem))
+	     (setf (next-object-id subsystem) (1+ id))))
 	  (t
 	   ;; normal transaction: assign a new ID
-	   (setf id (id-counter subsystem))
-	   (incf (id-counter subsystem))
+	   (setf id (next-object-id subsystem))
+	   (incf (next-object-id subsystem))
 	   (setf (slot-value object 'id) id)))))
 
 (defmethod print-object ((object store-object) stream)
@@ -476,9 +476,9 @@
 		     id slot-name (type-of container) (store-object-id container))
 	       (warn "Reference to inexistent object with id ~A from unnamed container, returning NIL." id))
 
-	   ;; noch die ID hochzaehlen wenn notwendig
-	   (when (>= id (id-counter (store-object-subsystem)))
-	     (setf (id-counter (store-object-subsystem)) (1+ id)))
+	   ;; Possibly determine new "current object id"
+	   (when (>= id (next-object-id (store-object-subsystem)))
+	     (setf (next-object-id (store-object-subsystem)) (1+ id)))
 	   nil)
 	  
 	  (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A." id slot-name (type-of container)
@@ -512,7 +512,7 @@
     ;;; check on first instatiation of a class?
     (dolist (class-name (cons 'store-object (all-store-classes)))
       (clear-class-indices (find-class class-name)))
-    (setf (id-counter subsystem) 0)
+    (setf (next-object-id subsystem) 0)
     (when (probe-file snapshot)
       (format *trace-output* "loading snapshot file ~A~%" snapshot)
       (with-open-file (s snapshot
@@ -586,7 +586,7 @@
   (execute (make-instance 'transaction
 			  :function-symbol 'tx-make-object
 			  :args (append (list class-name
-					      :id (id-counter (store-object-subsystem)))
+					      :id (next-object-id (store-object-subsystem)))
 					initargs))))
 
 (defun tx-delete-object (id)


From hhubner at common-lisp.net  Fri Feb 15 16:33:57 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:33:57 -0500 (EST)
Subject: [bknr-cvs] r2504 - in branches/trunk-reorg/projects/quickhoney: src
	website/static website/templates
Message-ID: <20080215163357.8AE8D490A1@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:33:56 2008
New Revision: 2504

Modified:
   branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
   branches/trunk-reorg/projects/quickhoney/src/tags.lisp
   branches/trunk-reorg/projects/quickhoney/website/static/javascript.js
   branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
Log:
Fix Javascript handling so that it works with current CXML.
Fix direct navigation to category page.
Reformats.


Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp	Fri Feb 15 11:33:56 2008
@@ -5,13 +5,17 @@
 (defclass javascript-handler ()
   ())
 
+(defvar *js-stream*)
+
 (defmethod handle :around ((handler javascript-handler))
   (with-http-response (:content-type "text/html; charset=UTF-8")
     (no-cache)
     (with-http-body ()
-      (format *html-stream* "<script language=\"JavaScript\">~%")
-      (call-next-method)
-      (format *html-stream* "~%</script>~%"))))
+      (html
+       ((:script :language "JavaScript")
+        (:princ
+         (with-output-to-string (*js-stream*)
+           (call-next-method))))))))
 
 (defclass random-image-handler (object-handler)
   ())
@@ -29,7 +33,7 @@
   (let ((content-type (blob-type (quickhoney-animation-image-animation animation))))
     (with-http-response (:content-type content-type)
       (with-http-body ()
-	(blob-to-stream (quickhoney-animation-image-animation animation) *html-stream*)))))
+	(blob-to-stream (quickhoney-animation-image-animation animation) *js-stream*)))))
 
 (defclass image-query-js-handler (javascript-handler object-handler)
   ())
@@ -62,19 +66,19 @@
     (format t "]~%")))
 
 (defmethod handle-object ((handler image-query-js-handler) images)
-  (format *html-stream* "parent.process_query_result(~%")
+  (format *js-stream* "parent.process_query_result(~%")
   (with-query-params (layout)
     (princ (layout-to-javascript (make-instance (case (make-keyword-from-string layout)
 						  (:smallworld 'quickhoney-name-layout)
 						  (t 'quickhoney-standard-layout))
-						:objects images)) *html-stream*))
-  (format *html-stream* ");~%"))
+						:objects images)) *js-stream*))
+  (format *js-stream* ");~%"))
 
 (defclass login-js-handler (javascript-handler page-handler)
   ())
 
 (defmethod handle ((handler login-js-handler))
-  (format *html-stream* "parent.login_complete(~A, ~S);~%"
+  (format *js-stream* "parent.login_complete(~A, ~S);~%"
 	  (if (admin-p (bknr-session-user)) "true" "false")
 	  (user-login (bknr-session-user))))
 
@@ -84,7 +88,7 @@
 (defmethod handle ((handler clients-js-handler))
   (let ((clients (sort (remove "" (all-clients) :test #'equal)
 		       #'string-lessp)))
-    (format *html-stream* "parent.set_clients([~S~{, ~S~}]);~%"
+    (format *js-stream* "parent.set_clients([~S~{, ~S~}]);~%"
 	    (car clients) (cdr clients))))
 
 (defclass edit-image-js-handler (admin-only-handler javascript-handler edit-object-handler)
@@ -97,11 +101,11 @@
 (defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :edit)) image)
   (with-query-params (client)
     (change-slot-values image 'client client)
-    (format *html-stream* "parent.image_edited()~%")))
+    (format *js-stream* "parent.image_edited()~%")))
 
 (defmethod handle-object-form ((handler edit-image-js-handler) (action (eql :delete)) (image quickhoney-image))
   (delete-object image)
-  (format *html-stream* "parent.image_deleted();~%"))
+  (format *js-stream* "parent.image_deleted();~%"))
 
 (defclass buttons-js-handler (javascript-handler prefix-handler)
   ())
@@ -138,11 +142,11 @@
 		       collect (list category subcategory (button-for-category category subcategory background-color))))))
 
 (defmethod handle ((handler buttons-js-handler))
-  (format *html-stream* "var buttons = [];~%")
+  (format *js-stream* "var buttons = [];~%")
   (loop for (category subcategory image-url) in (find-button-images (decoded-handler-path handler))
 	when image-url
-	do (format *html-stream* "buttons['~(~A/~A~)'] = ~S;~%" category subcategory image-url))
-  (format *html-stream* "parent.set_button_images(buttons);~%"))
+	do (format *js-stream* "buttons['~(~A/~A~)'] = ~S;~%" category subcategory image-url))
+  (format *js-stream* "parent.set_button_images(buttons);~%"))
 
 (defclass upload-image-handler (admin-only-handler prefix-handler)
   ())
@@ -259,7 +263,9 @@
 		(error "invalid image size, buttons must be 208 by 208 pixels"))
 	      (let* ((image (make-store-image :name (pathname-name uploaded-file)
 					      :class-name 'store-image
-					      :keywords (list :button (make-keyword-from-string directory) (make-keyword-from-string subdirectory)))))
+					      :keywords (list :button
+                                                              (make-keyword-from-string directory)
+                                                              (make-keyword-from-string subdirectory)))))
 		(with-http-response ()
 		  (with-http-body ()
 		    (html (:html

Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp	Fri Feb 15 11:33:56 2008
@@ -1,7 +1,6 @@
 (in-package :quickhoney.tags)
 
 (define-bknr-tag version-and-last-change (&rest args)
-  (format *debug-io* "hello world: ~A~%" args)
   (html "v1.1 | updated "
         (:princ-safe (string-downcase
                       (substitute #\Space #\-

Modified: branches/trunk-reorg/projects/quickhoney/website/static/javascript.js
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/static/javascript.js	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/static/javascript.js	Fri Feb 15 11:33:56 2008
@@ -607,8 +607,10 @@
 	var components = document.jump_to.split("/");
 	document.jump_to = null;
 	show_page(components[0]);
-	subdirectory(components[1]);
-	document.show_picture = components[2];
+        if (components[1]) {
+            subdirectory(components[1]);
+        }
+        document.show_picture = components[2];
     }
 }
 

Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	Fri Feb 15 11:33:56 2008
@@ -127,7 +127,7 @@
 			</div>
 	
 			<div id="footer" class="text">
-				?1998-2006 QuickHoney Nana Rausch &amp; Peter Stemmler. No part of
+				?1998-2008 QuickHoney Nana Rausch &amp; Peter Stemmler. No part of
 				this website may be reproduced in any manner without permission.
 				Programming by H?bner/Odendahl <a href="http://headcraft.de/" target="_new">
 				headcraft</a>


From hhubner at common-lisp.net  Fri Feb 15 16:36:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:36:28 -0500 (EST)
Subject: [bknr-cvs] r2505 - branches/trunk-reorg/thirdparty/chunga-0.4.1
Message-ID: <20080215163628.583802332C@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:36:25 2008
New Revision: 2505

Modified:
   branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp
   branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp
Log:
Fix CCL warnings


Modified: branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp	(original)
+++ branches/trunk-reorg/thirdparty/chunga-0.4.1/input.lisp	Fri Feb 15 11:36:25 2008
@@ -31,15 +31,18 @@
 
 (defmethod chunked-input-stream-extensions (object)
   "The default method which always returns the empty list."
+  (declare (ignore object))
   nil)
 
 (defmethod chunked-input-stream-trailers (object)
   "The default method which always returns the empty list."
+  (declare (ignore object))
   nil)
 
 (defmethod chunked-stream-input-chunking-p (object)
   "The default method for all objects which are not of type
 CHUNKED-INPUT-STREAM."
+  (declare (ignore object))
   nil)
 
 (defmethod (setf chunked-stream-input-chunking-p) (new-value (stream chunked-input-stream))

Modified: branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp	(original)
+++ branches/trunk-reorg/thirdparty/chunga-0.4.1/output.lisp	Fri Feb 15 11:36:25 2008
@@ -32,6 +32,7 @@
 (defmethod chunked-stream-output-chunking-p (object)
   "The default method for all objects which are not of type
 CHUNKED-OUTPUT-STREAM."
+  (declare (ignore object))
   nil)
 
 (defmethod write-chunk ((stream chunked-output-stream) sequence


From hhubner at common-lisp.net  Fri Feb 15 16:37:08 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:37:08 -0500 (EST)
Subject: [bknr-cvs] r2506 -
	branches/trunk-reorg/thirdparty/usocket-0.3.5/backend
Message-ID: <20080215163708.4AA414D043@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:37:07 2008
New Revision: 2506

Modified:
   branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp
Log:
Fix openmcl implementation of select (partly)


Modified: branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/usocket-0.3.5/backend/openmcl.lisp	Fri Feb 15 11:37:07 2008
@@ -37,15 +37,15 @@
       (ccl::fd-zero infds)
       (ccl::fd-zero errfds)
       (dolist (sock sockets)
-        (ccl::fd-set (socket-os-fd sock infds))
-        (ccl::fd-set (socket-os-fd sock errfds)))
+        (ccl::fd-set (ccl::socket-os-fd sock) infds)
+        (ccl::fd-set (ccl::socket-os-fd sock) errfds))
       (let* ((res (ccl::syscall syscalls::select
-                                (1+ (apply #'max fds))
+                                (1+ (apply #'max (mapcar #'ccl::socket-os-fd sockets)))
                                 infds (ccl::%null-ptr) errfds
                                 (if ticks-to-wait tv (ccl::%null-ptr)))))
         (when (> res 0)
           (remove-if #'(lambda (x)
-                         (not (ccl::fd-is-set (socket-os-fd x) infds)))
+                         (not (ccl::fd-is-set (ccl::socket-os-fd x) infds)))
                      sockets))))))
 
 (defun wait-for-input (sockets &optional ticks-to-wait)
@@ -67,7 +67,7 @@
      (raise-error-from-id (openmcl-socket:socket-error-identifier condition)
                           socket condition))
     (ccl::socket-creation-error #| ugh! |#
-     (raise-error-from-id (ccl::socket-creationg-error-identifier condition)
+     (raise-error-from-id (ccl::socket-creation-error-identifier condition)
                           socket condition))
     (error (error 'unknown-error :socket socket :real-error condition))
     (condition (signal 'unknown-condition :real-condition condition))))


From hhubner at common-lisp.net  Fri Feb 15 16:39:21 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:39:21 -0500 (EST)
Subject: [bknr-cvs] r2507 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080215163921.2462E70ED@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:39:19 2008
New Revision: 2507

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
Log:
Fixes for CXML compatibility.
Create new random state for each request invocation (which is not good, but
better than having all requests start with the same seed).


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Fri Feb 15 11:39:19 2008
@@ -223,7 +223,8 @@
 (defmethod invoke-handler ((handler page-handler))
   (let* ((*website* (page-handler-site handler))
 	 (*req-var-hash* (or *req-var-hash*
-			     (make-hash-table))))
+			     (make-hash-table)))
+         (*random-state* (make-random-state t)))
     (do-log-request)
     (unwind-protect
 	 (if (not (authorized-p handler))
@@ -446,8 +447,8 @@
 
 (defmethod handle :around ((handler xml-handler))
   (with-http-response (:content-type "text/xml")
-    (with-http-body ()
-      (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t))
+    (with-output-to-string (stream)
+      (let ((sink (cxml:make-character-stream-sink stream :canonical t))
 	    (style-path (or (query-param "style")
 			    (xml-handler-style-path handler))))
 	(cxml:with-xml-output sink


From hhubner at common-lisp.net  Fri Feb 15 16:40:33 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:40:33 -0500 (EST)
Subject: [bknr-cvs] r2508 - in branches/trunk-reorg/bknr: datastore/src/data
	datastore/src/indices datastore/src/skip-list
	modules/imagemap modules/mail web/src web/src/images web/src/web
Message-ID: <20080215164033.9F3C9232D3@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:40:28 2008
New Revision: 2508

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/object.lisp
   branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp
   branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
   branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp
   branches/trunk-reorg/bknr/modules/mail/mail.lisp
   branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp
   branches/trunk-reorg/bknr/web/src/images/image.lisp
   branches/trunk-reorg/bknr/web/src/packages.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
   branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
   branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
Log:
Several changes to remove references to *html-stream*, not complete.
Minor edits and reformats.


Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/object.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp	Fri Feb 15 11:40:28 2008
@@ -561,7 +561,7 @@
        collect keyword
        and
        collect value))
-	      
+
 ;;; create object transaction, should not be called from user code, as we have to give it
 ;;; a unique id in the initargs. After the object is created, the persistent and the
 ;;; transient instances are initialized

Modified: branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/indices/indexed-class.lisp	Fri Feb 15 11:40:28 2008
@@ -281,8 +281,7 @@
 
 (defvar *indexed-class-override* nil)
 
-(defmethod slot-value-using-class :before
-    ((class indexed-class) object slot)
+(defmethod slot-value-using-class :before ((class indexed-class) object slot)
   (when (and (not (eql (slot-definition-name slot) 'destroyed-p))
 	     (object-destroyed-p object)
 	     (not *indexed-class-override*))

Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	Fri Feb 15 11:40:28 2008
@@ -7,7 +7,7 @@
 ;;; Pseudo-random number generator from FreeBSD
 
 (defparameter *sl-random-state*
-  (make-random-state)
+  (make-random-state t)
   "Internal status of the random number generator.")
 
 (defun sl-random ()

Modified: branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/modules/imagemap/imagemap-handlers.lisp	Fri Feb 15 11:40:28 2008
@@ -77,11 +77,10 @@
 	  (t (html (:p #?"unknown operation $(operation-string)"))))
 	(html ((:form :action (self-url :command "make-polygon"))
 	       (if (session-value :map-points)
-		   (progn
-		     (format *html-stream* "~a point~:P collected "
-			     (/ (length (session-value :map-points)) 2))
-		     (html (cmslink (self-url :command "clear-points")
-			     (:princ "clear")))
+		   (html
+		     (:princ (format nil "~A point~:P collected "
+                                     (/ (length (session-value :map-points)) 2)))
+                     (cmslink (self-url :command "clear-points") (:princ "clear"))
 		     (when (< 4 (length (session-value :map-points)))
 		       (html " link to url: " ((:input :type "text" :name "url" :width 40))
 			     " " ((:input :type "submit" :value "make polygon")))))

Modified: branches/trunk-reorg/bknr/modules/mail/mail.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/mail/mail.lisp	(original)
+++ branches/trunk-reorg/bknr/modules/mail/mail.lisp	Fri Feb 15 11:40:28 2008
@@ -43,15 +43,15 @@
 
 (defmacro with-html-output-to-mail ((&rest mail-initargs &key headers &allow-other-keys) &rest body)
   (let ((new-headers (gensym)))
-  `(let ((,new-headers (make-headers :content-type "text/html; charset=\"utf-8\""
-				     :mime-version "1.0")))
-    (when ,headers
-      (setf ,new-headers (append ,new-headers ,headers)))
-    (make-object 'mail
-     :headers ,new-headers
-     ,@(remove-keys '(:headers) mail-initargs)
-     :body (with-output-to-string (*html-stream*)
-	     (html , at body))))))
+    `(let ((,new-headers (make-headers :content-type "text/html; charset=\"utf-8\""
+                                       :mime-version "1.0")))
+      (when ,headers
+        (setf ,new-headers (append ,new-headers ,headers)))
+      (make-object 'mail
+       :headers ,new-headers
+       ,@(remove-keys '(:headers) mail-initargs)
+       :body (with-output-to-string (s)
+               (html-stream s , at body))))))
 
 ;;; converted from macho (by Miles Egan)
 (defun parse-header-string (headerstr)

Modified: branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/edit-image-handler.lisp	Fri Feb 15 11:40:28 2008
@@ -126,10 +126,10 @@
   (with-bknr-page (:title #?"edit image $(name)")
     (when remove-keywords
       (store-object-remove-keywords image 'keywords remove-keywords)
-      (html (:h2 (format *html-stream* "Removed keywords ~a from image" remove-keywords))))
+      (html (:h2 (:princ (format nil "Removed keywords ~a from image" remove-keywords)))))
     (when add-keywords
       (store-object-add-keywords image 'keywords add-keywords)
-      (html (:h2 (format *html-stream* "Added keywords ~a to image" add-keywords))))
+      (html (:h2 (:princ (format nil "Added keywords ~a to image" add-keywords)))))
     (unless (or add-keywords remove-keywords)
       (html (:h2 "No keywords added or removed")))
     (show-image-editor image))))
\ No newline at end of file

Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/image.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/image.lisp	Fri Feb 15 11:40:28 2008
@@ -115,13 +115,12 @@
 		   :title (store-image-name image)
 		   :link browse-url
 		   :desc (with-output-to-string (s)
-			   (html-stream
-			    s ((:a :href image-url)
-			       ((:img :src
-				      (concatenate 'string
-						   image-url
-						   "/thumbnail,,320,200")
-				     :align "left")))))
+			   (html-stream s ((:a :href image-url)
+                                           ((:img :src
+                                                  (concatenate 'string
+                                                               image-url
+                                                               "/thumbnail,,320,200")
+                                                  :align "left")))))
 		   :date (blob-timestamp image))))
 
 ;;; import

Modified: branches/trunk-reorg/bknr/web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/packages.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/packages.lisp	Fri Feb 15 11:40:28 2008
@@ -192,8 +192,7 @@
   (:shadowing-import-from :cl-interpol #:quote-meta-chars)
   (:shadowing-import-from :hunchentoot #:host)
   (:shadowing-import-from :alexandria #:array-index)
-  (:export #:*html-stream*
-	   #:*user*
+  (:export #:*user*
 	   #:with-http-request
 	   #:with-http-body
 	   #:request-variable

Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Fri Feb 15 11:40:28 2008
@@ -265,9 +265,9 @@
 (defun send-error-response (handler message &key (response-code +http-internal-server-error+))
   (with-http-response (:content-type "text/html; charset=UTF-8"
 				     :response response-code)
-    (with-http-body ()
+    (with-output-to-string (stream)
       (emit-template handler
-		     *html-stream*
+		     stream
 		     (get-cached-template (find-template-pathname handler "user-error") handler)
 		     (acons :error-message message
 			    (initial-template-environment
@@ -316,8 +316,7 @@
       (if body
           (with-http-response (:content-type "text/html; charset=UTF-8"
 					     :response +http-ok+)
-            (with-http-body ()
-              (write-string body *html-stream*)))
+            body)
           (error-404)))))
 
 ;; XXX documentation-handler sieht interessant aus, unbedingt reparieren

Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	Fri Feb 15 11:40:28 2008
@@ -50,11 +50,9 @@
     (setf (return-code) ,response)
     , at body))
 
-(defvar *html-stream*)
-
 (defmacro with-http-body ((&key external-format) &body body)
-  `(with-output-to-string (*html-stream*)
-    (with-xhtml (*html-stream*)
+  `(with-output-to-string (stream)
+    (with-xhtml (stream)
       , at body)))
 
 (defmacro with-image-from-uri ((image-variable prefix) &rest body)
@@ -83,7 +81,7 @@
 
 (defmacro html-warn (&rest warning)
   `(progn
-    (format *html-stream* "<!-- ~a -->~%" (format nil , at warning))
+    (html (:princ-safe (format nil "<!-- ~a -->~%" (format nil , at warning))))
     (warn , at warning)))
 
 (defmacro cmslink (url &body body)

Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp	Fri Feb 15 11:40:28 2008
@@ -137,7 +137,6 @@
 (defun http-error (response message)
   (with-bknr-page (:title #?"error: $(message)" :response response)
     (:princ-safe message))
-  (finish-output *html-stream*)
   (error message))
 
 (defun keywords-from-query-param-list (param &key (remove-empty t))
@@ -190,7 +189,7 @@
     #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))"))
 
 (defmethod html-link ((object store-object))
-  (format *html-stream* "[persistent object with id #~a]" (store-object-id object)))
+  (html (:princ (format nil "[persistent object with id #~a]" (store-object-id object)))))
 
 (defun text-to-html (string)
   "Perform simple text to HTML conversion.  http urls are replaced by links, internal links to


From hhubner at common-lisp.net  Fri Feb 15 16:43:15 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 11:43:15 -0500 (EST)
Subject: [bknr-cvs] r2509 - branches/trunk-reorg/bknr/datastore/src/skip-list
Message-ID: <20080215164315.5AE854D043@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 11:43:14 2008
New Revision: 2509

Modified:
   branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
Log:
Remove stale comment


Modified: branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/skip-list/skip-list.lisp	Fri Feb 15 11:43:14 2008
@@ -4,8 +4,6 @@
 ;;; index-protokoll fuer cursor
 ;;; range-queries
 
-;;; Pseudo-random number generator from FreeBSD
-
 (defparameter *sl-random-state*
   (make-random-state t)
   "Internal status of the random number generator.")


From hhubner at common-lisp.net  Fri Feb 15 21:22:22 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Fri, 15 Feb 2008 16:22:22 -0500 (EST)
Subject: [bknr-cvs] r2510 - in branches/trunk-reorg: bknr/web/src/web
	projects/quickhoney/website/static xhtmlgen
Message-ID: <20080215212222.A6D0E1502A@common-lisp.net>

Author: hhubner
Date: Fri Feb 15 16:22:21 2008
New Revision: 2510

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
   branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
   branches/trunk-reorg/projects/quickhoney/website/static/styles.css
   branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
Log:
More xhtmlgen fixes.
Make error handling work again.  Errors are displayed to the user unless
*catch-errors-p* is true.


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Fri Feb 15 16:22:21 2008
@@ -233,15 +233,16 @@
 		     (redirect-uri (parse-uri (script-name))))
 	       (redirect (website-make-path *website* "login")))
 	     (if *catch-errors-p*
-		 (handle handler)
-		 (handler-bind ((error #'(lambda (e)
-					   (with-http-response (:content-type "text/html; charset=UTF-8"
-									      :response +http-internal-server-error+)
-					     (with-http-body ()
-					       (website-show-error-page *website* e)))
-					   (do-error-log-request e)
-					   (error e))))
-		   (handle handler))))
+		 (handler-bind
+                     ((error #'(lambda (e)
+                                 (with-http-response (:content-type "text/html; charset=UTF-8"
+                                                                    :response +http-internal-server-error+)
+                                   (return-from invoke-handler (prog1
+                                                                   (with-http-body ()
+                                                                     (website-show-error-page *website* e))
+                                                                 (do-error-log-request e)))))))
+		   (handle handler))
+                 (handle handler)))
       (handler-case
 	  (mapcar #'delete-file (mapcar #'cdr (request-uploaded-files)))
 	(error (e)
@@ -468,8 +469,7 @@
 (defgeneric xml-object-handler-show-object (handler object))
 
 (defmethod xml-object-handler-show-object ((handler xml-object-handler) object)
-  (write-to-xml object
-		:string-rod-fn #'cxml::utf8-string-to-rod))
+  (write-to-xml object))
 
 (defmethod handle-object ((handler xml-object-handler) object)
   (xml-object-handler-show-object handler object))
@@ -499,8 +499,8 @@
 (defmethod handle-object ((handler blob-handler) (blob blob))
   (with-http-response (:content-type (blob-mime-type blob))
     (setf (content-length) (blob-size blob))
-    (with-http-body (:external-format '(unsigned-byte 8))
-      (blob-to-stream blob *html-stream*))))
+    (let ((stream (send-headers)))
+      (blob-to-stream blob stream))))
 
 (defclass import-handler (form-handler)
   ((require-user-flag :initform :admin)
@@ -522,7 +522,6 @@
 
 (defmethod website-show-page ((website website) fn title)  
   (html   
-      
    (:html
     (:head
      (header :title title))
@@ -535,6 +534,20 @@
      (funcall fn)
      (session-info)))))
 
+(defmethod website-show-error-page ((website website) error)
+  (if (and (website-template-handler website)
+           (error-template-pathname (website-template-handler website)))
+      (send-error-response (website-template-handler website) (princ-to-string error))
+      (html
+       (:html
+        (:head
+         (header :title "Error processing your request"))
+        ((:body :class "cms")
+         (:h1 "Error processing your request")
+         (:p "While processing your request, an error occured:")
+         ((:div :class "error")
+	  (:princ-safe error)))))))
+
 (defun show-page-with-error-handlers (fn &key (response +http-ok+) title)
   (setf (return-code) response)
   (with-http-response (:content-type "text/html; charset=UTF-8" :response response)

Modified: branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp	Fri Feb 15 16:22:21 2008
@@ -10,5 +10,5 @@
 
 (defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel))
   (with-http-response (:content-type "text/xml; charset=UTF-8")
-    (with-http-body ()
-      (bknr.rss:rss-channel-xml channel *html-stream*))))
+    (with-output-to-string (stream)
+      (bknr.rss:rss-channel-xml channel stream))))

Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Fri Feb 15 16:22:21 2008
@@ -262,13 +262,16 @@
 			   env)))
         (template-not-found template-pathname))))
 
+(defmethod error-template-pathname (handler &optional (error-type "user-error"))
+  (find-template-pathname handler error-type))
+
 (defun send-error-response (handler message &key (response-code +http-internal-server-error+))
   (with-http-response (:content-type "text/html; charset=UTF-8"
 				     :response response-code)
     (with-output-to-string (stream)
       (emit-template handler
 		     stream
-		     (get-cached-template (find-template-pathname handler "user-error") handler)
+		     (get-cached-template (error-template-pathname handler) handler)
 		     (acons :error-message message
 			    (initial-template-environment
 			     handler))))))

Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp	Fri Feb 15 16:22:21 2008
@@ -120,8 +120,7 @@
     value))
 
 (defun query-param-list (param-name)
-  (format *debug-io* "questionable: query-param-list~%")
-  (assoc-values param-name (request-query) :test #'string-equal))
+  (assoc-values param-name (get-parameters) :test #'string-equal))
 
 (defun request-variable (var)
   (gethash var *req-var-hash*))

Modified: branches/trunk-reorg/projects/quickhoney/website/static/styles.css
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/static/styles.css	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/static/styles.css	Fri Feb 15 16:22:21 2008
@@ -425,3 +425,11 @@
 	width: 0px;
 	border: 0px none #FFFFFF;
 }
+
+.error {
+        margin: 2em;
+        padding: 1em;
+        border: 1pt solid #aa0000;
+	color:#f00;
+	font-size: 110%;
+}
\ No newline at end of file

Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
==============================================================================
--- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	(original)
+++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp	Fri Feb 15 16:22:21 2008
@@ -142,11 +142,8 @@
 
 (defun emit-without-quoting (str)
   ;; das ist fuer WPDISPLAY
-  (format t "emit-without-quoting does not work~%")
-  #+(or)
-  (let ((s (cxml::chained-handler *html-sink*)))
-    (cxml::maybe-close-tag s)
-    (map nil (lambda (c) (cxml::write-rune c s)) str)))
+  (cxml::maybe-close-tag *html-sink*)
+  (map nil (lambda (c) (cxml::%write-rune c *html-sink*)) str))
 
 (defun princ-http (val)
   #+(or)


From ksprotte at common-lisp.net  Sat Feb 16 12:40:31 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sat, 16 Feb 2008 07:40:31 -0500 (EST)
Subject: [bknr-cvs] r2511 - branches/bos/projects/bos
Message-ID: <20080216124031.B303A6A005@common-lisp.net>

Author: ksprotte
Date: Sat Feb 16 07:40:30 2008
New Revision: 2511

Modified:
   branches/bos/projects/bos/Makefile
Log:
bos make cleanall use rm -f

Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile	(original)
+++ branches/bos/projects/bos/Makefile	Sat Feb 16 07:40:30 2008
@@ -26,7 +26,7 @@
 
 .PHONY: cleanfasl
 cleanfasl:
-	(cd ../.. && find . -name '*.x86f' | xargs rm)
+	(cd ../.. && find . -name '*.x86f' | xargs rm -f)
 
 .PHONY: cleanall
 cleanall: cleancore cleanfasl


From hhubner at common-lisp.net  Sat Feb 16 12:43:24 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat, 16 Feb 2008 07:43:24 -0500 (EST)
Subject: [bknr-cvs] r2512 - branches/trunk-reorg/thirdparty/uffi-1.6.0/tests
Message-ID: <20080216124324.CDDCF5C182@common-lisp.net>

Author: hhubner
Date: Sat Feb 16 07:43:24 2008
New Revision: 2512

Modified:
   branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp
Log:
Add unit test that verifies pointer-to-pointer structure fields.


Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp	(original)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/tests/structs.lisp	Sat Feb 16 07:43:24 2008
@@ -19,7 +19,8 @@
 
 
 (uffi:def-struct foo
-    (bar :pointer-self))
+    (bar :pointer-self)
+  (pointer-pointer (* (* :unsigned-char))))
 
 (uffi:def-foreign-type foo-ptr (* foo))
 


From ksprotte at common-lisp.net  Sat Feb 16 13:03:23 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sat, 16 Feb 2008 08:03:23 -0500 (EST)
Subject: [bknr-cvs] r2513 - branches/bos/projects/bos
Message-ID: <20080216130323.356005D086@common-lisp.net>

Author: ksprotte
Date: Sat Feb 16 08:03:04 2008
New Revision: 2513

Modified:
   branches/bos/projects/bos/Makefile
   branches/bos/projects/bos/build.sh
Log:
bos added -batch option to build.sh

Modified: branches/bos/projects/bos/Makefile
==============================================================================
--- branches/bos/projects/bos/Makefile	(original)
+++ branches/bos/projects/bos/Makefile	Sat Feb 16 08:03:04 2008
@@ -5,7 +5,7 @@
 	lisp -load make-base-lisp.lisp
 
 bos.core: cmucl.core build.sh load.lisp build.lisp
-	./build.sh
+	./build.sh -batch
 
 # run with slime
 .PHONY: slime

Modified: branches/bos/projects/bos/build.sh
==============================================================================
--- branches/bos/projects/bos/build.sh	(original)
+++ branches/bos/projects/bos/build.sh	Sat Feb 16 08:03:04 2008
@@ -2,4 +2,4 @@
 
 set -x
 (cd ../../thirdparty/cl-gd && make)
-lisp -core cmucl.core -noinit -load load.lisp -load build.lisp
+lisp "$@" -core cmucl.core -noinit -load load.lisp -load build.lisp


From ksprotte at common-lisp.net  Sat Feb 16 14:06:42 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sat, 16 Feb 2008 09:06:42 -0500 (EST)
Subject: [bknr-cvs] r2514 - branches/bos/modules/mail
Message-ID: <20080216140642.D832C5C185@common-lisp.net>

Author: ksprotte
Date: Sat Feb 16 09:06:42 2008
New Revision: 2514

Modified:
   branches/bos/modules/mail/mail.lisp
Log:
fix for regex-replace-all in mail.lisp
third arg was missing


Modified: branches/bos/modules/mail/mail.lisp
==============================================================================
--- branches/bos/modules/mail/mail.lisp	(original)
+++ branches/bos/modules/mail/mail.lisp	Sat Feb 16 09:06:42 2008
@@ -97,7 +97,8 @@
 				*message-id-re*
 				(first (if (header :in-reply-to)
 					   (split #?/\s+/ (header :in-reply-to))
-					   (last (split #?/\s+/ (header :references))))))
+					   (last (split #?/\s+/ (header :references)))))
+                                #?/\1/)
 		     :headers headers
 		     :body body)))))
 


From ksprotte at common-lisp.net  Sat Feb 16 16:10:42 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sat, 16 Feb 2008 11:10:42 -0500 (EST)
Subject: [bknr-cvs] r2515 - branches/bos/projects/bos
Message-ID: <20080216161042.11B956A161@common-lisp.net>

Author: ksprotte
Date: Sat Feb 16 11:10:41 2008
New Revision: 2515

Modified:
   branches/bos/projects/bos/build.lisp
Log:
dummy commit - nothing changed

Modified: branches/bos/projects/bos/build.lisp
==============================================================================
--- branches/bos/projects/bos/build.lisp	(original)
+++ branches/bos/projects/bos/build.lisp	Sat Feb 16 11:10:41 2008
@@ -10,7 +10,7 @@
 
 ;;;
 ;;; Lisp-Image fuer das Deployment dumpen
-;;;
+;;; 
 
 (defun read-configuration (pathname)
   (with-open-file (s pathname)


From hhubner at common-lisp.net  Sat Feb 16 20:00:18 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sat, 16 Feb 2008 15:00:18 -0500 (EST)
Subject: [bknr-cvs] r2516 - branches/trunk-reorg/bknr/web/src/web
Message-ID: <20080216200018.B0D5A6912C@common-lisp.net>

Author: hhubner
Date: Sat Feb 16 15:00:17 2008
New Revision: 2516

Modified:
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
Log:
Docstrings


Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Sat Feb 16 15:00:17 2008
@@ -66,7 +66,11 @@
     :import-spool-directory #p"/home/bknr/spool/"
     :template-base-directory nil
     :template-command-packages nil
-    :rss-feed-url nil))
+    :rss-feed-url nil)
+  (:documentation "Class to hold all information on a web server that
+is served within BKNR.  Currently, this is a singleton object, and
+*WEBSITE* will point to the only instance.  Eventually, multiple
+WEBSITE instances for virtual hosts may be supported."))
 
 (defmethod initialize-instance :after ((website website) &key &allow-other-keys)
   (when *website*
@@ -86,9 +90,20 @@
 (defmethod website-make-path ((website website) path)
   (format nil "~A~A" (website-base-href website) (relative path)))
 
-(defgeneric publish-handler (website handler))
-(defgeneric handler-matches (handler))
-(defgeneric publish-site (website))
+(defgeneric publish-handler (website handler)
+  (:documentation "Publish HANDLER on WEBSITE, thereby adding it to
+the chain of handlers that is searched to handle an incoming
+request."))
+
+(defgeneric handler-matches-p (handler)
+  (:documentation "Determine whether HANDLER is willing to handle the
+current request.  Returns non-NIL if the HANDLER wants to handle the request
+NIL otherwise."))
+
+(defgeneric publish-site (website)
+  (:documentation "Publish all handlers defined in WEBSITE.
+
+XXX When is this called?"))
 
 (defun handler-definition-name (handler-definition)
   (first handler-definition))
@@ -191,9 +206,21 @@
   (print-unreadable-object (handler stream :type t)
     (format stream "~A" (page-handler-prefix handler))))
 
-(defgeneric handle (page-handler))
-(defgeneric authorized-p (page-handler))
-(defgeneric page-handler-url (page-handler))
+(defgeneric handle (page-handler)
+  (:documentation "Handle an incoming HTTP request, returning either a
+string or an (array (unsigned-byte 8) (*)) with the response
+contents.  Alternatively, the handler may call (SEND-HEADERS) to
+get access to the response stream and output the data to it."))
+
+(defgeneric authorized-p (page-handler)
+  (:documentation "Return non-nil if the request is authorized to be
+executed on PAGE-HANDLER
+
+XXX wouldn't it be better if handler-matches-p checked
+authorization?"))
+
+(defgeneric page-handler-url (page-handler)
+  (:documentation "Return the full base URL for PAGE-HANDLER."))
 
 (defmethod handler-path ((handler page-handler))
   (subseq (script-name)
@@ -266,7 +293,7 @@
 
 (defun bknr-dispatch (request)
   (declare (ignore request))
-  (let ((handler (find-if #'handler-matches (website-handlers *website*))))
+  (let ((handler (find-if #'handler-matches-p (website-handlers *website*))))
     (cond
       (handler
        (start-session)
@@ -279,7 +306,7 @@
 (defmethod publish-handler ((website website) (handler page-handler))
   (setf *handlers* (append *handlers* (list handler))))
 
-(defmethod handler-matches ((handler page-handler))
+(defmethod handler-matches-p ((handler page-handler))
   (string-equal (page-handler-prefix handler)
 		(script-name)))
 
@@ -296,7 +323,10 @@
   (redirect (random-elt (redirect-handler-to page-handler))))
 
 (defclass form-handler (page-handler)
-  ())
+  ()
+  (:documentation "A FORM-HANDLER is a handler that processes form
+submissions.  The handler generic function for FORM-HANDLER subclasses
+is called HANDLE-FORM."))
 
 (define-condition form-condition (condition)
   ((reason :initarg :reason
@@ -315,7 +345,12 @@
     (signal (make-condition 'form-field-missing-condition
 	     :field ',field-name))))
 
-(defgeneric handle-form (page-handler action))
+(defgeneric handle-form (page-handler action)
+  (:documentation "Handle form submission for PAGE-HANDLER.  The
+form variable \"action\" will be parsed into a keyword and passwd to
+the invocation of this generic function as ACTION.  Methods are meant
+to specialize on individual keywords to handle different actions that
+the form supports."))
 
 (defmethod handle ((page-handler form-handler))
   (let* ((form (query-param "action"))
@@ -323,7 +358,11 @@
     (handle-form page-handler form-keyword)))
 
 (defclass prefix-handler (page-handler)
-  ())
+  ()
+  (:documentation "A PREFIX-HANDLER is a handler that is invoked for
+URLs with a certain prefix, as determined by the :PREFIX
+initialization argument.  It is used as a mixin class and only
+provides for a HANDLER-MATCHES-P method."))
 
 #+(or)
 (defmethod initialize-instance :after ((handler prefix-handler) &key)
@@ -331,7 +370,7 @@
                          (1- (length (page-handler-prefix handler)))))
     (warn "prefix handler ~A does not have prefix ending with / - may match unexpectedly" handler)))
 
-(defmethod handler-matches ((handler prefix-handler))
+(defmethod handler-matches-p ((handler prefix-handler))
   (and (>= (length (script-name))
 	   (length (page-handler-prefix handler)))
        (string-equal (page-handler-prefix handler)
@@ -340,20 +379,26 @@
 
 (defclass directory-handler (prefix-handler)
   ((destination :initarg :destination
-		:reader page-handler-destination)))
+		:reader page-handler-destination))
+  (:documentation
+   "Handler for a directory in the file system.  Publishes all files
+in the directory DESTINATION under their relative path name."))
+
+(defgeneric request-relative-pathname (directory-handler)
+  (:documentation "Return the relative pathname for the current
+request as determined by DIRECTORY-HANDLER.")
+  (:method ((handler directory-handler))
+    (or (aux-request-value 'request-relative-pathname)
+        (setf (aux-request-value 'request-relative-pathname)
+              (pathname (subseq (script-name) (1+ (length (page-handler-prefix handler)))))))))
 
-(defmethod request-pathname ((handler directory-handler))
-  (or (aux-request-value 'request-pathname)
-      (setf (aux-request-value 'request-pathname)
-	    (subseq (script-name) (1+ (length (page-handler-prefix handler)))))))
-
-(defmethod handler-matches ((handler directory-handler))
+(defmethod handler-matches-p ((handler directory-handler))
   (and (call-next-method)
-       (probe-file (merge-pathnames (request-pathname handler)
+       (probe-file (merge-pathnames (request-relative-pathname handler)
 				    (page-handler-destination handler)))))
 
 (defmethod handle ((handler directory-handler))
-  (handle-static-file (merge-pathnames (request-pathname handler)
+  (handle-static-file (merge-pathnames (request-relative-pathname handler)
 				       (page-handler-destination handler))))
 
 (defclass file-handler (page-handler)
@@ -361,34 +406,64 @@
 		:reader page-handler-destination)
    (content-type :initarg :content-type
 		 :reader page-handler-content-type))
-  (:default-initargs :content-type "text/plain"))
+  (:default-initargs :content-type "text/plain")
+  (:documentation "A FILE-HANDLER is used to publish a single file
+under an URL.  :DESTINATION is the pathname of the file to publish,
+:CONTENT-TYPE is the content type to use."))
 
 (defmethod handle ((handler file-handler))
-  (handle-static-file (page-handler-destination handler)))
+  (handle-static-file (page-handler-destination handler) (page-handler-content-type handler)))
 
 (defclass object-handler (prefix-handler)
   ((query-function :initarg :query-function :reader object-handler-query-function)
    (object-class :initarg :object-class :reader object-handler-object-class))
-  (:default-initargs :object-class t :query-function nil))
-
-(defgeneric object-handler-get-object (object-handler))
-(defgeneric handle-object (object-handler object))
-
-(defmethod object-handler-get-object ((handler object-handler))
-  (let ((id (parse-url)))
-    (when id
-      (find-store-object id
-			 :class (object-handler-object-class handler)
-			 :query-function (object-handler-query-function handler)))))
+  (:default-initargs :object-class t :query-function nil)
+  (:documentation "An OBJECT-HANDLER handles requests for a persistent
+object in the BKNR datastore.  The first component of the relative
+path of the request is used as the key to locate the object.  The
+object is looked up using the OBJECT-HANDLER-GET-OBJECT generic
+function, which will, by default, call FIND-STORE-OBJECT with the key
+as argument.
+
+The :QUERY-FUNCTION initarg may be supplied to set up a query function
+that maps from the key to an object.  It is typically used to
+implement lookup by name.
+
+The :OBJECT-CLASS initarg may be supplied to restrict the handler to
+operate on objects of that class or its subclass.  If the key
+specifies the ID of an object that has a different class or if the
+QUERY-FUNCTION returns an object of a different class, a run-time
+error is signaled."))
+
+(defgeneric object-handler-get-object (object-handler)
+  (:documentation "Implement object lookup.  Methods return the object
+that the current request should operate upon.  The default method for
+the OBJECT handler class performs a lookup using FIND-STORE-OBJECT.")
+  (:method ((handler object-handler))
+    (let ((id (parse-url)))
+      (when id
+        (find-store-object id
+                           :class (object-handler-object-class handler)
+                           :query-function (object-handler-query-function handler))))))
+
+(defgeneric handle-object (object-handler object)
+  (:documentation "Handle the current to the OBJECT-HANDLER.  OBJECT
+is the object as looked up by OBJECT-HANDLER-GET-OBJECT."))
 
 (defmethod handle ((handler object-handler))
   (let ((object (object-handler-get-object handler)))
     (handle-object handler object)))
 
 (defclass edit-object-handler (form-handler object-handler)
-  ())
-
-(defgeneric handle-object-form (handler action object))
+  ()
+  (:documentation "Combined FORM-HANDLER and OBJECT-HANDLER class that
+is used as a base class for handlers that edit an object using a HTML
+form."))
+
+(defgeneric handle-object-form (handler action object)
+  (:documentation "Perform ACTION, a keyword that has been determined by
+parsing the \"action\" input element of the current HTML form, on
+OBJECT, which is parsed using the mechanism of an OBJECT-HANDLER."))
 
 (defmethod handle-form ((handler edit-object-handler) action)
   (let ((object (object-handler-get-object handler)))


From hhubner at common-lisp.net  Sun Feb 17 07:26:35 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 02:26:35 -0500 (EST)
Subject: [bknr-cvs] r2517 -
	branches/trunk-reorg/projects/lisp-ecoop/website/templates
Message-ID: <20080217072635.DBCB025119@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 02:26:33 2008
New Revision: 2517

Modified:
   branches/trunk-reorg/projects/lisp-ecoop/website/templates/menu.xml
Log:
Remove "people" and "submissions" menu entries as long as they are
empty.


Modified: branches/trunk-reorg/projects/lisp-ecoop/website/templates/menu.xml
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/website/templates/menu.xml	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/website/templates/menu.xml	Sun Feb 17 02:26:33 2008
@@ -2,15 +2,12 @@
 <menu name="main">
   <item url="home" title="Home" />
   <item url="news" title="News" />
+  <!--
   <item url="people" title="People" />
+  -->
   <item url="programme" title="Programme" />
-  <item url="submissions" title="Submissions" />
-  <item url="contact" title="Organization / Contact" />
   <!--
-  <item url="schedule" title="Schedule" />
-  <item url="registration" title="Registration" />
-  <item url="papers" title="Papers" />
-  <item url="groups" title ="Breakout Groups" />
-  <item url="guidelines" title="Submission" />
+  <item url="submissions" title="Submissions" />
   -->
+  <item url="contact" title="Organization / Contact" />
 </menu>


From hhubner at common-lisp.net  Sun Feb 17 07:29:02 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 02:29:02 -0500 (EST)
Subject: [bknr-cvs] r2518 - trunk/projects/lisp-ecoop/website/templates
Message-ID: <20080217072902.8892514160@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 02:29:01 2008
New Revision: 2518

Modified:
   trunk/projects/lisp-ecoop/website/templates/menu.xml
Log:
Remove "people" and "submissions" from menu as long as they are empty

Modified: trunk/projects/lisp-ecoop/website/templates/menu.xml
==============================================================================
--- trunk/projects/lisp-ecoop/website/templates/menu.xml	(original)
+++ trunk/projects/lisp-ecoop/website/templates/menu.xml	Sun Feb 17 02:29:01 2008
@@ -2,15 +2,12 @@
 <menu name="main">
   <item url="home" title="Home" />
   <item url="news" title="News" />
+  <!--
   <item url="people" title="People" />
+  -->
   <item url="programme" title="Programme" />
-  <item url="submissions" title="Submissions" />
-  <item url="contact" title="Organization / Contact" />
   <!--
-  <item url="schedule" title="Schedule" />
-  <item url="registration" title="Registration" />
-  <item url="papers" title="Papers" />
-  <item url="groups" title ="Breakout Groups" />
-  <item url="guidelines" title="Submission" />
+  <item url="submissions" title="Submissions" />
   -->
+  <item url="contact" title="Organization / Contact" />
 </menu>


From hhubner at common-lisp.net  Sun Feb 17 10:22:51 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 05:22:51 -0500 (EST)
Subject: [bknr-cvs] r2519 - branches/trunk-reorg/thirdparty/uffi-1.6.0/src
Message-ID: <20080217102251.16D885D086@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 05:22:50 2008
New Revision: 2519

Modified:
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
Log:
Another CCL fix.  DEFSETF is not required if the read expansion is setfable.  The previous implementation did not work.

Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	(original)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	Sun Feb 17 05:22:50 2008
@@ -118,13 +118,6 @@
   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
   )
 
-#+(or openmcl digitool)
-(defmacro set-slot-value (obj type slot value) ;use setf to set values
-  `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
-
-#+(or openmcl digitool)
-(defsetf get-slot-value set-slot-value)
-
 
 (defmacro get-slot-pointer (obj type slot)
   #+(or lispworks cmu sbcl scl) (declare (ignore type))


From ksprotte at common-lisp.net  Sun Feb 17 14:26:58 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sun, 17 Feb 2008 09:26:58 -0500 (EST)
Subject: [bknr-cvs] r2520 - in branches/trunk-reorg/thirdparty:
	closure-common-2007-10-21 cxml-2007-08-05 cxml-2007-10-21
	cxml-2007-10-21/contrib cxml-2007-10-21/doc
	cxml-2007-10-21/dom cxml-2007-10-21/klacks
	cxml-2007-10-21/test cxml-2007-10-21/xml
	cxml-2007-10-21/xml/sax-tests
Message-ID: <20080217142658.DC2B95F05E@common-lisp.net>

Author: ksprotte
Date: Sun Feb 17 09:26:33 2008
New Revision: 2520

Added:
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/characters.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/closure-common.asd
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/definline.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings-data.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/hax.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/package.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/runes.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/stream-scl.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/syntax.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/utf8.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/xstream.lisp
   branches/trunk-reorg/thirdparty/closure-common-2007-10-21/ystream.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/COPYING
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/DOMTEST
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/GNUmakefile
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/OLDNEWS
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/README
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/TIMES
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLCONF
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLS-SYMBOLS.diff
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/catalog.dtd
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/contrib/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/contrib/xhtmlgen.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/cxml.asd
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/GNUmakefile
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/bg.png   (contents, props changed)
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/cxml.css
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/html.xsl
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.html
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.xml
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/documentation.css
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-builder.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-impl.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-sax.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/package.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks-impl.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/package.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/tap-source.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/mlisp-patch.diff
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/domtest.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/misc.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/utf8domtest.diff
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf-base.diff
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/catalog.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/package.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/recoder.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-handler.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-proxy.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/event-collecting-handler.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/package.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/tests.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/space-normalizer.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/split-sequence.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/unparse.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/util.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-name-rune-p.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-parse.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmlns-normalizer.lisp
   branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmls-compat.lisp
Removed:
   branches/trunk-reorg/thirdparty/cxml-2007-08-05/
Log:
pulled cxml-2007-10-21, latest cxml release


Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/characters.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/characters.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,148 @@
+;;; copyright (c) 2004 knowledgeTools Int. GmbH
+;;; Author of this version: David Lichteblau <david at knowledgetools.de>
+;;;
+;;; derived from runes.lisp, (c) copyright 1998,1999 by Gilbert Baumann
+;;;
+;;; License: Lisp-LGPL (See file COPYING for details).
+;;;
+;;; This code is free software; you can redistribute it and/or modify it
+;;; under the terms of the version 2.1 of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, as clarified
+;;; by the "Preamble to the Gnu Lesser General Public License" found in
+;;; the file COPYING.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; Version 2.1 of the GNU Lesser General Public License is in the file
+;;; COPYING that was distributed with this file.  If it is not present,
+;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
+;;; superseded by a newer version) or write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(in-package :runes)
+
+(deftype rune () #-lispworks 'character #+lispworks 'lw:simple-char)
+(deftype rod () '(vector rune))
+(deftype simple-rod () '(simple-array rune))
+
+(definline rune (rod index)
+  (char rod index))
+
+(defun (setf rune) (new rod index)
+  (setf (char rod index) new))
+
+(definline %rune (rod index)
+  (aref (the simple-string rod) (the fixnum index)))
+
+(definline (setf %rune) (new rod index)
+  (setf (aref (the simple-string rod) (the fixnum index)) new))
+
+(defun rod-capitalize (rod)
+  (string-upcase rod))
+
+(definline code-rune (x) (code-char x))
+(definline rune-code (x) (char-code x))
+
+(definline rune= (x y) 
+  (char= x y))
+
+(defun rune-downcase (rune)
+  (char-downcase rune))
+
+(definline rune-upcase (rune)
+  (char-upcase rune))
+
+(defun rune-upper-case-letter-p (rune)
+  (upper-case-p rune))
+
+(defun rune-lower-case-letter-p (rune)
+  (lower-case-p rune))
+
+(defun rune-equal (x y)
+  (char-equal x y))
+
+(defun rod-downcase (rod)
+  (string-downcase rod))
+
+(defun rod-upcase (rod)
+  (string-upcase rod))
+
+(definline white-space-rune-p (char)
+  (or (char= char #\tab)
+      (char= char #.(code-char 10))     ;Linefeed
+      (char= char #.(code-char 13))     ;Carriage Return
+      (char= char #\space)))
+
+(definline digit-rune-p (char &optional (radix 10))
+  (digit-char-p char radix))
+
+(defun rod (x)
+  (cond
+    ((stringp x)    x)
+    ((symbolp x)    (string x))
+    ((characterp x) (string x))
+    ((vectorp x)    (coerce x 'string))
+    ((integerp x)   (string (code-char x)))
+    (t              (error "Cannot convert ~S to a ~S" x 'rod))))
+
+(defun runep (x)
+  (characterp x))
+
+(defun sloopy-rod-p (x)
+  (stringp x))
+
+(defun rod= (x y)
+  (if (zerop (length x))
+      (zerop (length y))
+      (and (plusp (length y)) (string= x y))))
+
+(defun rod-equal (x y)
+  (string-equal x y))
+
+(definline make-rod (size)
+  (make-string size :element-type 'rune))
+
+(defun char-rune (char)
+  char)
+
+(defun rune-char (rune &optional default)
+  (declare (ignore default))
+  rune)
+
+(defun rod-string (rod &optional (default-char #\?))
+  (declare (ignore default-char))
+  rod)
+
+(defun string-rod (string)
+  string)
+
+;;;;
+
+(defun rune<= (rune &rest more-runes)
+  (loop
+      for (a b) on (cons rune more-runes)
+      while b
+      always (char<= a b)))
+
+(defun rune>= (rune &rest more-runes)
+  (loop
+      for (a b) on (cons rune more-runes)
+      while b
+      always (char>= a b)))
+
+(defun rodp (object)
+  (stringp object))
+
+(defun rod-subseq (source start &optional (end (length source)))
+  (unless (stringp source)
+    (error "~S is not of type ~S." source 'rod))
+  (subseq source start end))
+
+(defun rod-subseq* (source start &optional (end (length source)))
+  (rod-subseq source start end))
+
+(defun rod< (rod1 rod2)
+  (string< rod1 rod2))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/closure-common.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/closure-common.asd	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,56 @@
+(defpackage :closure-common-system
+  (:use :asdf :cl)
+  (:export #:*utf8-runes-readtable*))
+
+(in-package :closure-common-system)
+
+(defvar *utf8-runes-readtable*)
+
+(defclass closure-source-file (cl-source-file) ())
+
+#+sbcl
+(defmethod perform :around ((o compile-op) (s closure-source-file))
+  ;; shut up already.  Correctness first.
+  (handler-bind ((sb-ext:compiler-note #'muffle-warning))
+    (let (#+sbcl (*compile-print* nil))
+      (call-next-method))))
+
+#-(or rune-is-character rune-is-integer)
+(progn
+  (format t "~&;;; Checking for wide character support...")
+  (force-output)
+  (pushnew (dotimes (x 65536
+                      (progn
+                        (format t " ok, characters have at least 16 bits.~%")
+                        :rune-is-character))
+             (unless (or (<= #xD800 x #xDFFF)
+			 (and (< x char-code-limit) (code-char x)))
+               (format t " no, reverting to octet strings.~%")
+               (return :rune-is-integer)))
+           *features*))
+
+#-rune-is-character
+(format t "~&;;; Building Closure with (UNSIGNED-BYTE 16) RUNES~%")
+
+#+rune-is-character
+(format t "~&;;; Building Closure with CHARACTER RUNES~%") 
+
+(defsystem :closure-common
+    :default-component-class closure-source-file
+    :serial t
+    :components
+    ((:file "package")
+     (:file "definline")
+     (:file runes
+            :pathname
+             #-rune-is-character "runes"
+             #+rune-is-character "characters")
+     #+rune-is-integer (:file "utf8")
+     (:file "syntax")
+     #-x&y-streams-are-stream (:file "encodings")
+     #-x&y-streams-are-stream (:file "encodings-data")
+     #-x&y-streams-are-stream (:file "xstream")
+     #-x&y-streams-are-stream (:file "ystream")
+     #+x&y-streams-are-stream (:file #+scl "stream-scl")
+     (:file "hax"))
+    :depends-on (#-scl :trivial-gray-streams))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/definline.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/definline.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,63 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: definline
+;;;   Created: 1999-05-25 22:32
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999 by Gilbert Baumann
+
+;;; This code is free software; you can redistribute it and/or modify it
+;;; under the terms of the version 2.1 of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, as clarified
+;;; by the "Preamble to the Gnu Lesser General Public License" found in
+;;; the file COPYING.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; Version 2.1 of the GNU Lesser General Public License is in the file
+;;; COPYING that was distributed with this file.  If it is not present,
+;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
+;;; superseded by a newer version) or write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(in-package :runes)
+
+#-(or allegro openmcl)
+(defmacro definline (name args &body body)
+  `(progn
+     (declaim (inline ,name))
+     (defun ,name ,args .,body)))
+
+#+openmcl
+(defmacro runes::definline (fun args &body body)
+  (if (consp fun)
+      `(defun ,fun ,args
+         , at body)
+      `(progn
+         (defun ,fun ,args .,body)
+         (define-compiler-macro ,fun (&rest .args.)
+           (cons '(lambda ,args .,body)
+                 .args.)))))
+
+#+allegro
+(defmacro definline (fun args &body body)
+  (if (and (consp fun) (eq (car fun) 'setf))
+      (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")")
+                          (symbol-package (cadr fun)))))
+        `(progn
+           (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap))
+           (definline ,fnam ,args .,body)))
+    (labels ((declp (x)
+               (and (consp x) (eq (car x) 'declare))))
+      `(progn
+         (defun ,fun ,args .,body)
+         (define-compiler-macro ,fun (&rest .args.)
+           (cons '(lambda ,args
+                   ,@(remove-if-not #'declp body)
+                   (block ,fun 
+                     ,@(remove-if #'declp body)))
+                 .args.))))))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings-data.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings-data.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,568 @@
+(in-package :runes-encoding)
+
+(progn
+  (add-name :us-ascii "ANSI_X3.4-1968") 
+  (add-name :us-ascii "iso-ir-6") 
+  (add-name :us-ascii "ANSI_X3.4-1986") 
+  (add-name :us-ascii "ISO_646.irv:1991") 
+  (add-name :us-ascii "ASCII") 
+  (add-name :us-ascii "ISO646-US") 
+  (add-name :us-ascii "US-ASCII") 
+  (add-name :us-ascii "us") 
+  (add-name :us-ascii "IBM367") 
+  (add-name :us-ascii "cp367") 
+  (add-name :us-ascii "csASCII") 
+
+  (add-name :iso-8859-1 "ISO_8859-1:1987") 
+  (add-name :iso-8859-1 "iso-ir-100") 
+  (add-name :iso-8859-1 "ISO_8859-1") 
+  (add-name :iso-8859-1 "ISO-8859-1") 
+  (add-name :iso-8859-1 "latin1") 
+  (add-name :iso-8859-1 "l1") 
+  (add-name :iso-8859-1 "IBM819") 
+  (add-name :iso-8859-1 "CP819") 
+  (add-name :iso-8859-1 "csISOLatin1") 
+
+  (add-name :iso-8859-2 "ISO_8859-2:1987") 
+  (add-name :iso-8859-2 "iso-ir-101") 
+  (add-name :iso-8859-2 "ISO_8859-2") 
+  (add-name :iso-8859-2 "ISO-8859-2") 
+  (add-name :iso-8859-2 "latin2") 
+  (add-name :iso-8859-2 "l2") 
+  (add-name :iso-8859-2 "csISOLatin2") 
+
+  (add-name :iso-8859-3 "ISO_8859-3:1988") 
+  (add-name :iso-8859-3 "iso-ir-109") 
+  (add-name :iso-8859-3 "ISO_8859-3") 
+  (add-name :iso-8859-3 "ISO-8859-3") 
+  (add-name :iso-8859-3 "latin3") 
+  (add-name :iso-8859-3 "l3") 
+  (add-name :iso-8859-3 "csISOLatin3") 
+
+  (add-name :iso-8859-4 "ISO_8859-4:1988") 
+  (add-name :iso-8859-4 "iso-ir-110") 
+  (add-name :iso-8859-4 "ISO_8859-4") 
+  (add-name :iso-8859-4 "ISO-8859-4") 
+  (add-name :iso-8859-4 "latin4") 
+  (add-name :iso-8859-4 "l4") 
+  (add-name :iso-8859-4 "csISOLatin4") 
+
+  (add-name :iso-8859-6 "ISO_8859-6:1987") 
+  (add-name :iso-8859-6 "iso-ir-127") 
+  (add-name :iso-8859-6 "ISO_8859-6") 
+  (add-name :iso-8859-6 "ISO-8859-6") 
+  (add-name :iso-8859-6 "ECMA-114") 
+  (add-name :iso-8859-6 "ASMO-708") 
+  (add-name :iso-8859-6 "arabic") 
+  (add-name :iso-8859-6 "csISOLatinArabic") 
+
+  (add-name :iso-8859-7 "ISO_8859-7:1987") 
+  (add-name :iso-8859-7 "iso-ir-126") 
+  (add-name :iso-8859-7 "ISO_8859-7") 
+  (add-name :iso-8859-7 "ISO-8859-7") 
+  (add-name :iso-8859-7 "ELOT_928") 
+  (add-name :iso-8859-7 "ECMA-118") 
+  (add-name :iso-8859-7 "greek") 
+  (add-name :iso-8859-7 "greek8") 
+  (add-name :iso-8859-7 "csISOLatinGreek") 
+
+  (add-name :iso-8859-8 "ISO_8859-8:1988") 
+  (add-name :iso-8859-8 "iso-ir-138") 
+  (add-name :iso-8859-8 "ISO_8859-8") 
+  (add-name :iso-8859-8 "ISO-8859-8") 
+  (add-name :iso-8859-8 "hebrew") 
+  (add-name :iso-8859-8 "csISOLatinHebrew") 
+
+  (add-name :iso-8859-5 "ISO_8859-5:1988") 
+  (add-name :iso-8859-5 "iso-ir-144") 
+  (add-name :iso-8859-5 "ISO_8859-5") 
+  (add-name :iso-8859-5 "ISO-8859-5") 
+  (add-name :iso-8859-5 "cyrillic") 
+  (add-name :iso-8859-5 "csISOLatinCyrillic") 
+
+  (add-name :iso-8859-9 "ISO_8859-9:1989") 
+  (add-name :iso-8859-9 "iso-ir-148") 
+  (add-name :iso-8859-9 "ISO_8859-9") 
+  (add-name :iso-8859-9 "ISO-8859-9") 
+  (add-name :iso-8859-9 "latin5") 
+  (add-name :iso-8859-9 "l5") 
+  (add-name :iso-8859-9 "csISOLatin5") 
+
+  (add-name :iso-8859-15 "ISO_8859-15") 
+  (add-name :iso-8859-15 "ISO-8859-15") 
+
+  (add-name :iso-8859-14 "ISO_8859-14") 
+  (add-name :iso-8859-14 "ISO-8859-14") 
+
+  (add-name :koi8-r "KOI8-R") 
+  (add-name :koi8-r "csKOI8R") 
+
+  (add-name :utf-8 "UTF-8") 
+
+  (add-name :utf-16 "UTF-16") 
+
+  (add-name :ucs-4 "ISO-10646-UCS-4") 
+  (add-name :ucs-4 "UCS-4") 
+
+  (add-name :ucs-2 "ISO-10646-UCS-2") 
+  (add-name :ucs-2 "UCS-2") )
+
+
+(progn
+  (define-encoding :iso-8859-1
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-1)))
+
+  (define-encoding :iso-8859-2
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-2)))
+
+  (define-encoding :iso-8859-3
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-3)))
+
+  (define-encoding :iso-8859-4
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-4)))
+
+  (define-encoding :iso-8859-5
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-5)))
+
+  (define-encoding :iso-8859-6
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-6)))
+
+  (define-encoding :iso-8859-7
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-7)))
+
+  (define-encoding :iso-8859-8
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-8)))
+
+  (define-encoding :iso-8859-14
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-14)))
+
+  (define-encoding :iso-8859-15
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :iso-8859-15)))
+
+  (define-encoding :koi8-r
+      (make-simple-8-bit-encoding 
+        :charset (find-charset :koi8-r)))
+
+  (define-encoding :utf-8 :utf-8)
+  )
+
+(progn
+  (define-8-bit-charset :iso-8859-1
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
+      #| #o25x |#   #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
+      #| #o26x |#   #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
+      #| #o27x |#   #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
+      #| #o30x |#   #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
+      #| #o31x |#   #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
+      #| #o32x |#   #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
+      #| #o33x |#   #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
+      #| #o34x |#   #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
+      #| #o35x |#   #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
+      #| #o36x |#   #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
+      #| #o37x |#   #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
+
+  (define-8-bit-charset :iso-8859-2
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7
+      #| #o25x |#   #x00A8 #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B
+      #| #o26x |#   #x00B0 #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7
+      #| #o27x |#   #x00B8 #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C
+      #| #o30x |#   #x0154 #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7
+      #| #o31x |#   #x010C #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E
+      #| #o32x |#   #x0110 #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7
+      #| #o33x |#   #x0158 #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF
+      #| #o34x |#   #x0155 #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7
+      #| #o35x |#   #x010D #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F
+      #| #o36x |#   #x0111 #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7
+      #| #o37x |#   #x0159 #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9)
+
+  (define-8-bit-charset :iso-8859-3
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x0126 #x02D8 #x00A3 #x00A4 #xFFFF #x0124 #x00A7
+      #| #o25x |#   #x00A8 #x0130 #x015E #x011E #x0134 #x00AD #xFFFF #x017B
+      #| #o26x |#   #x00B0 #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7
+      #| #o27x |#   #x00B8 #x0131 #x015F #x011F #x0135 #x00BD #xFFFF #x017C
+      #| #o30x |#   #x00C0 #x00C1 #x00C2 #xFFFF #x00C4 #x010A #x0108 #x00C7
+      #| #o31x |#   #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
+      #| #o32x |#   #xFFFF #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7
+      #| #o33x |#   #x011C #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF
+      #| #o34x |#   #x00E0 #x00E1 #x00E2 #xFFFF #x00E4 #x010B #x0109 #x00E7
+      #| #o35x |#   #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
+      #| #o36x |#   #xFFFF #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7
+      #| #o37x |#   #x011D #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
+
+  (define-8-bit-charset :iso-8859-4
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7
+      #| #o25x |#   #x00A8 #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF
+      #| #o26x |#   #x00B0 #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7
+      #| #o27x |#   #x00B8 #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B
+      #| #o30x |#   #x0100 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E
+      #| #o31x |#   #x010C #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A
+      #| #o32x |#   #x0110 #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7
+      #| #o33x |#   #x00D8 #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF
+      #| #o34x |#   #x0101 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F
+      #| #o35x |#   #x010D #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B
+      #| #o36x |#   #x0111 #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7
+      #| #o37x |#   #x00F8 #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9)
+
+  (define-8-bit-charset :iso-8859-5
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407
+      #| #o25x |#   #x0408 #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F
+      #| #o26x |#   #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
+      #| #o27x |#   #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E #x041F
+      #| #o30x |#   #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
+      #| #o31x |#   #x0428 #x0429 #x042A #x042B #x042C #x042D #x042E #x042F
+      #| #o32x |#   #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
+      #| #o33x |#   #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E #x043F
+      #| #o34x |#   #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
+      #| #o35x |#   #x0448 #x0449 #x044A #x044B #x044C #x044D #x044E #x044F
+      #| #o36x |#   #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457
+      #| #o37x |#   #x0458 #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F)
+
+  (define-8-bit-charset :iso-8859-6
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667
+      #| #o07x |#   #x0668 #x0669 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #xFFFF #xFFFF #xFFFF #x00A4 #xFFFF #xFFFF #xFFFF
+      #| #o25x |#   #xFFFF #xFFFF #xFFFF #xFFFF #x060C #x00AD #xFFFF #xFFFF
+      #| #o26x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o27x |#   #xFFFF #xFFFF #xFFFF #x061B #xFFFF #xFFFF #xFFFF #x061F
+      #| #o30x |#   #xFFFF #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627
+      #| #o31x |#   #x0628 #x0629 #x062A #x062B #x062C #x062D #x062E #x062F
+      #| #o32x |#   #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637
+      #| #o33x |#   #x0638 #x0639 #x063A #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o34x |#   #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647
+      #| #o35x |#   #x0648 #x0649 #x064A #x064B #x064C #x064D #x064E #x064F
+      #| #o36x |#   #x0650 #x0651 #x0652 #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o37x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
+
+  (define-8-bit-charset :iso-8859-7
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x02BD #x02BC #x00A3 #xFFFF #xFFFF #x00A6 #x00A7
+      #| #o25x |#   #x00A8 #x00A9 #xFFFF #x00AB #x00AC #x00AD #xFFFF #x2015
+      #| #o26x |#   #x00B0 #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7
+      #| #o27x |#   #x0388 #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F
+      #| #o30x |#   #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397
+      #| #o31x |#   #x0398 #x0399 #x039A #x039B #x039C #x039D #x039E #x039F
+      #| #o32x |#   #x03A0 #x03A1 #xFFFF #x03A3 #x03A4 #x03A5 #x03A6 #x03A7
+      #| #o33x |#   #x03A8 #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF
+      #| #o34x |#   #x03B0 #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7
+      #| #o35x |#   #x03B8 #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF
+      #| #o36x |#   #x03C0 #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7
+      #| #o37x |#   #x03C8 #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #xFFFF)
+
+  (define-8-bit-charset :iso-8859-8
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #xFFFF #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
+      #| #o25x |#   #x00A8 #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x203E
+      #| #o26x |#   #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
+      #| #o27x |#   #x00B8 #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #xFFFF
+      #| #o30x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o31x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o32x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o33x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #x2017
+      #| #o34x |#   #x05D0 #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7
+      #| #o35x |#   #x05D8 #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF
+      #| #o36x |#   #x05E0 #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7
+      #| #o37x |#   #x05E8 #x05E9 #x05EA #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
+
+  (define-8-bit-charset :iso-8859-9
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
+      #| #o25x |#   #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
+      #| #o26x |#   #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
+      #| #o27x |#   #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
+      #| #o30x |#   #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
+      #| #o31x |#   #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
+      #| #o32x |#   #x011E #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
+      #| #o33x |#   #x00D8 #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF
+      #| #o34x |#   #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
+      #| #o35x |#   #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
+      #| #o36x |#   #x011F #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
+      #| #o37x |#   #x00F8 #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF)
+
+  (define-8-bit-charset :iso-8859-14
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7
+      #| #o25x |#   #x1E80 #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178
+      #| #o26x |#   #x1E1E #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56
+      #| #o27x |#   #x1E81 #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61
+      #| #o30x |#   #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
+      #| #o31x |#   #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
+      #| #o32x |#   #x0174 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A
+      #| #o33x |#   #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF
+      #| #o34x |#   #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
+      #| #o35x |#   #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
+      #| #o36x |#   #x0175 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B
+      #| #o37x |#   #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF)
+
+  (define-8-bit-charset :iso-8859-15
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o21x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o22x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o23x |#   #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
+      #| #o24x |#   #x00A0 #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7
+      #| #o25x |#   #x0161 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
+      #| #o26x |#   #x00B0 #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7
+      #| #o27x |#   #x017E #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF
+      #| #o30x |#   #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
+      #| #o31x |#   #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
+      #| #o32x |#   #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
+      #| #o33x |#   #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
+      #| #o34x |#   #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
+      #| #o35x |#   #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
+      #| #o36x |#   #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
+      #| #o37x |#   #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
+
+  (define-8-bit-charset :koi8-r
+      #| #o00x |#   #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
+      #| #o01x |#   #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
+      #| #o02x |#   #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
+      #| #o03x |#   #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
+      #| #o04x |#   #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
+      #| #o05x |#   #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
+      #| #o06x |#   #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
+      #| #o07x |#   #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
+      #| #o10x |#   #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
+      #| #o11x |#   #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
+      #| #o12x |#   #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
+      #| #o13x |#   #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
+      #| #o14x |#   #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
+      #| #o15x |#   #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
+      #| #o16x |#   #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
+      #| #o17x |#   #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
+      #| #o20x |#   #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
+      #| #o21x |#   #x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
+      #| #o22x |#   #x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
+      #| #o23x |#   #x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
+      #| #o24x |#   #x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
+      #| #o25x |#   #x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
+      #| #o26x |#   #x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
+      #| #o27x |#   #x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
+      #| #o30x |#   #x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
+      #| #o31x |#   #x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
+      #| #o32x |#   #x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
+      #| #o33x |#   #x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
+      #| #o34x |#   #x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
+      #| #o35x |#   #x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
+      #| #o36x |#   #x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
+      #| #o37x |#   #x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
+  )
+

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/encodings.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,396 @@
+(in-package :runes-encoding)
+
+(define-condition encoding-error (simple-error) ())
+
+(defun xerror (fmt &rest args)
+  (error 'encoding-error :format-control fmt :format-arguments args))
+
+;;;; ---------------------------------------------------------------------------
+;;;; Encoding names
+;;;;
+
+(defvar *names* (make-hash-table :test #'eq))
+
+(defun canon-name (string)
+  (with-output-to-string (bag)
+    (map nil (lambda (ch)
+               (cond ((char= ch #\_) (write-char #\- bag))
+                     (t (write-char (char-upcase ch) bag))))
+         string)))
+
+(defun canon-name-2 (string)
+  (with-output-to-string (bag)
+    (map nil (lambda (ch)
+               (cond ((char= ch #\_))
+                     ((char= ch #\-))
+                     (t (write-char (char-upcase ch) bag))))
+         string)))
+
+(defmethod encoding-names ((encoding symbol))
+  (gethash encoding *names*))
+
+(defmethod (setf encoding-names) (new-value (encoding symbol))
+  (setf (gethash encoding *names*) new-value))
+
+(defun add-name (encoding name)
+  (pushnew (canon-name name) (encoding-names encoding) :test #'string=))
+
+(defun resolve-name (string)
+  (cond ((symbolp string)
+         string)
+        (t
+         (setq string (canon-name string))
+         (or
+          (block nil
+            (maphash (lambda (x y) 
+                       (when (member string y :test #'string=)
+                         (return x)))
+                     *names*)
+            nil)
+          (block nil
+            (maphash (lambda (x y) 
+                       (when (member string y 
+                                     :test #'(lambda (x y)
+                                               (string= (canon-name-2 x) 
+                                                        (canon-name-2 y))))
+                         (return x)))
+                     *names*)
+            nil)))))
+
+;;;; ---------------------------------------------------------------------------
+;;;;  Encodings
+;;;;
+
+(defvar *encodings* (make-hash-table :test #'eq))
+
+(defmacro define-encoding (name init-form)
+  `(progn
+     (setf (gethash ',name *encodings*)
+       (list nil (lambda () ,init-form)))
+     ',name))
+
+(defun find-encoding (name)
+  (let ((x (gethash (resolve-name name) *encodings*)))
+    (and x
+         (or (first x)
+             (setf (first x) (funcall (second x)))))))
+
+(defclass encoding () ())
+
+(defclass simple-8-bit-encoding (encoding)
+  ((table :initarg :table)))
+
+(defun make-simple-8-bit-encoding (&key charset)
+  (make-instance 'simple-8-bit-encoding
+    :table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256)))))
+
+;;;;;;;
+
+(defmacro fx-op (op &rest xs) 
+  `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
+(defmacro fx-pred (op &rest xs) 
+  `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
+
+(defmacro %+   (&rest xs) `(fx-op + , at xs))
+(defmacro %-   (&rest xs) `(fx-op - , at xs))
+(defmacro %*   (&rest xs) `(fx-op * , at xs))
+(defmacro %/   (&rest xs) `(fx-op floor , at xs))
+(defmacro %and (&rest xs) `(fx-op logand , at xs))
+(defmacro %ior (&rest xs) `(fx-op logior , at xs))
+(defmacro %xor (&rest xs) `(fx-op logxor , at xs))
+(defmacro %ash (&rest xs) `(fx-op ash , at xs))
+(defmacro %mod (&rest xs) `(fx-op mod , at xs))
+
+(defmacro %=  (&rest xs)  `(fx-pred = , at xs))
+(defmacro %<= (&rest xs)  `(fx-pred <= , at xs))
+(defmacro %>= (&rest xs)  `(fx-pred >= , at xs))
+(defmacro %<  (&rest xs)  `(fx-pred < , at xs))
+(defmacro %>  (&rest xs)  `(fx-pred > , at xs))
+
+;;; Decoders
+
+;; The decoders share a common signature:
+;;
+;; DECODE input input-start input-end
+;;        output output-start output-end
+;;        eof-p
+;; -> first-not-written ; first-not-read
+;;
+;; These decode functions should decode as much characters off `input'
+;; into the `output' as possible and return the indexes to the first
+;; not read and first not written element of `input' and `output'
+;; respectively.  If there are not enough bytes in `input' to decode a
+;; full character, decoding shold be abandomed; the caller has to
+;; ensure that the remaining bytes of `input' are passed to the
+;; decoder again with more bytes appended.
+;;
+;; `eof-p' now in turn indicates, if the given input sequence, is all
+;; the producer does have and might be used to produce error messages
+;; in case of incomplete codes or decided what to do.
+;;
+;; Decoders are expected to handle the various CR/NL conventions and
+;; canonicalize each end of line into a single NL rune (#xA) in good
+;; old Lisp tradition.
+;;
+
+;; TODO: change this to an encoding class, which then might carry
+;; additional state. Stateless encodings could been represented by
+;; keywords. e.g.
+;;
+;;  defmethod DECODE-SEQUENCE ((encoding (eql :utf-8)) ...)
+;;
+
+(defmethod decode-sequence ((encoding (eql :utf-16-big-endian))
+                            in in-start in-end out out-start out-end eof?)
+  ;; -> new wptr, new rptr
+  (let ((wptr out-start)
+        (rptr in-start))
+    (loop
+      (when (%= wptr out-end)
+        (return))
+      (when (>= (%+ rptr 1) in-end)
+        (return))
+      (let ((hi (aref in rptr))
+            (lo (aref in (%+ 1 rptr))))
+        (setf rptr (%+ 2 rptr))
+	;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste
+	;; Zeichen abwarten und nachgucken, dass nicht etwa die andere
+	;; Haelfte fehlt!
+        (let ((x (logior (ash hi 8) lo)))
+	  (when (or (eql x #xFFFE) (eql x #xFFFF))
+	    (xerror "not a valid code point: #x~X" x))
+	  (setf (aref out wptr) x))
+        (setf wptr (%+ 1 wptr))))
+    (values wptr rptr)))
+
+(defmethod decode-sequence ((encoding (eql :utf-16-little-endian))
+                            in in-start in-end out out-start out-end eof?)
+  ;; -> new wptr, new rptr
+  (let ((wptr out-start)
+        (rptr in-start))
+    (loop
+      (when (%= wptr out-end)
+        (return))
+      (when (>= (%+ rptr 1) in-end)
+        (return))
+      (let ((lo (aref in (%+ 0 rptr)))
+            (hi (aref in (%+ 1 rptr))))
+        (setf rptr (%+ 2 rptr))
+	;; FIXME: Wenn wir hier ein Surrogate sehen, muessen wir das naechste
+	;; Zeichen abwarten und nachgucken, dass nicht etwa die andere
+	;; Haelfte fehlt!
+        (let ((x (logior (ash hi 8) lo)))
+	  (when (or (eql x #xFFFE) (eql x #xFFFF))
+	    (xerror "not a valid code point: #x~X" x))
+	  (setf (aref out wptr) x))
+        (setf wptr (%+ 1 wptr))))
+    (values wptr rptr)))
+
+(defmethod decode-sequence ((encoding (eql :utf-8))
+                            in in-start in-end out out-start out-end eof?)
+  (declare (optimize (speed 3) (safety 0))
+           (type (simple-array (unsigned-byte 8) (*)) in)
+           (type (simple-array (unsigned-byte 16) (*)) out)
+           (type fixnum in-start in-end out-start out-end))
+  (let ((wptr out-start)
+        (rptr in-start)
+        byte0)
+    (macrolet ((put (x)
+                 `((lambda (x)
+                     (when (or (<= #xD800 x #xDBFF)
+			       (<= #xDC00 x #xDFFF))
+		       (xerror "surrogate encoded in UTF-8: #x~X." x))
+                     (cond ((or (%> x #x10FFFF)
+				(eql x #xFFFE)
+				(eql x #xFFFF))
+                            (xerror "not a valid code point: #x~X" x))
+		           ((%> x #xFFFF)
+                            (setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10))
+                                  (aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF)))
+                            (setf wptr (%+ wptr 2)))
+                           (t
+                            (setf (aref out wptr) x)
+                            (setf wptr (%+ wptr 1)))))
+                   ,x))
+               (put1 (x)
+                 `(progn
+                    (setf (aref out wptr) ,x)
+                    (setf wptr (%+ wptr 1)))))
+      (loop
+        (when (%= (+ wptr 1) out-end) (return))
+        (when (%>= rptr in-end) (return))
+        (setq byte0 (aref in rptr))
+        (cond ((= byte0 #x0D)
+               ;; CR handling
+               ;; we need to know the following character
+               (cond ((>= (%+ rptr 1) in-end)
+                      ;; no characters in buffer
+                      (cond (eof?
+                             ;; at EOF, pass it as NL
+                             (put #x0A)
+                             (setf rptr (%+ rptr 1)))
+                            (t
+                             ;; demand more characters
+                             (return))))
+                     ((= (aref in (%+ rptr 1)) #x0A)
+                      ;; we see CR NL, so forget this CR and the next NL will be
+                      ;; inserted literally
+                      (setf rptr (%+ rptr 1)))
+                     (t
+                      ;; singleton CR, pass it as NL
+                      (put #x0A)
+                      (setf rptr (%+ rptr 1)))))
+                    
+              ((%<= #|#b00000000|# byte0 #b01111111)
+               (put1 byte0)
+               (setf rptr (%+ rptr 1)))
+            
+              ((%<= #|#b10000000|# byte0 #b10111111)
+               (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)
+               (setf rptr (%+ rptr 1)))
+            
+              ((%<= #|#b11000000|# byte0 #b11011111)
+               (cond ((<= (%+ rptr 2) in-end)
+                      (put
+                       (dpb (ldb (byte 5 0) byte0) (byte 5 6)
+                            (dpb (ldb (byte 6 0) (aref in (%+ rptr 1))) (byte 6 0)
+                                 0)))
+                      (setf rptr (%+ rptr 2)))
+                     (t
+                      (return))))
+            
+              ((%<= #|#b11100000|# byte0 #b11101111)
+               (cond ((<= (%+ rptr 3) in-end)
+                      (put
+                       (dpb (ldb (byte 4 0) byte0) (byte 4 12)
+                            (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 6)
+                                 (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 0)
+                                      0))))
+                      (setf rptr (%+ rptr 3)))
+                     (t
+                      (return))))
+            
+              ((%<= #|#b11110000|# byte0 #b11110111)
+               (cond ((<= (%+ rptr 4) in-end)
+                      (put
+                       (dpb (ldb (byte 3 0) byte0) (byte 3 18)
+                            (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 12)
+                                 (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 6)
+                                      (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 0)
+                                           0)))))
+                      (setf rptr (%+ rptr 4)))
+                     (t
+                      (return))))
+            
+              ((%<= #|#b11111000|# byte0 #b11111011)
+               (cond ((<= (%+ rptr 5) in-end)
+                      (put
+                       (dpb (ldb (byte 2 0) byte0) (byte 2 24)
+                            (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 18)
+                                 (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 12)
+                                      (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 6)
+                                           (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 0)
+                                                0))))))
+                      (setf rptr (%+ rptr 5)))
+                     (t
+                      (return))))
+            
+              ((%<= #|#b11111100|# byte0 #b11111101)
+               (cond ((<= (%+ rptr 6) in-end)
+                      (put
+                       (dpb (ldb (byte 1 0) byte0) (byte 1 30)
+                            (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 24)
+                                 (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 18)
+                                      (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 12)
+                                           (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 6)
+                                                (dpb (ldb (byte 6 0) (aref in (%+ 5 rptr))) (byte 6 0)
+                                                     0)))))))
+                      (setf rptr (%+ rptr 6)))
+                     (t
+                      (return))))
+            
+              (t
+               (xerror "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) )) 
+    (values wptr rptr))  )
+
+(defmethod encoding-p ((object (eql :utf-16-little-endian))) t)
+(defmethod encoding-p ((object (eql :utf-16-big-endian))) t)
+(defmethod encoding-p ((object (eql :utf-8))) t)
+
+(defmethod encoding-p ((object encoding)) t)
+
+(defmethod decode-sequence ((encoding simple-8-bit-encoding)
+                            in in-start in-end
+                            out out-start out-end 
+                            eof?)
+  (declare (optimize (speed 3) (safety 0))
+           (type (simple-array (unsigned-byte 8) (*)) in)
+           (type (simple-array (unsigned-byte 16) (*)) out)
+           (type fixnum in-start in-end out-start out-end))
+  (let ((wptr out-start)
+        (rptr in-start)
+        (byte 0)
+        (table (slot-value encoding 'table))) 
+    (declare (type fixnum wptr rptr)
+             (type (unsigned-byte 8) byte)
+             (type (simple-array (unsigned-byte 16) (*)) table))
+    (loop
+      (when (%= wptr out-end) (return))
+      (when (%>= rptr in-end) (return))
+      (setq byte (aref in rptr))
+      (cond ((= byte #x0D)
+             ;; CR handling
+             ;; we need to know the following character
+             (cond ((>= (%+ rptr 1) in-end)
+                    ;; no characters in buffer
+                    (cond (eof?
+                           ;; at EOF, pass it as NL
+                           (setf (aref out wptr) #x0A)
+                           (setf wptr (%+ wptr 1))
+                           (setf rptr (%+ rptr 1)))
+                          (t
+                           ;; demand more characters
+                           (return))))
+                   ((= (aref in (%+ rptr 1)) #x0A)
+                    ;; we see CR NL, so forget this CR and the next NL will be
+                    ;; inserted literally
+                    (setf rptr (%+ rptr 1)))
+                   (t
+                    ;; singleton CR, pass it as NL
+                    (setf (aref out wptr) #x0A)
+                    (setf wptr (%+ wptr 1))
+                    (setf rptr (%+ rptr 1)))))
+                    
+            (t
+             (setf (aref out wptr) (aref table byte))
+             (setf wptr (%+ wptr 1))
+             (setf rptr (%+ rptr 1))) ))
+    (values wptr rptr)))
+
+;;;; ---------------------------------------------------------------------------
+;;;;  Character sets
+;;;;
+
+(defvar *charsets* (make-hash-table :test #'eq))
+
+(defclass 8-bit-charset ()
+  ((name :initarg :name)
+   (to-unicode-table 
+    :initarg :to-unicode-table
+    :reader to-unicode-table)))
+
+(defmacro define-8-bit-charset (name &rest codes)
+  (assert (= 256 (length codes)))
+  `(progn
+     (setf (gethash ',name *charsets*)
+         (make-instance '8-bit-charset
+           :name ',name
+           :to-unicode-table
+           ',(make-array 256 
+                         :element-type '(unsigned-byte 16)
+                         :initial-contents codes)))
+     ',name))
+
+(defun find-charset (name)
+  (or (gethash name *charsets*)
+      (xerror "There is no character set named ~S." name)))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/hax.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/hax.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,404 @@
+;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: An event API for the HTML parser, inspired by SAX
+;;;   Created: 2007-10-14
+;;;    Author: David Lichteblau
+;;;   License: BSD
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2005,2007 David Lichteblau
+
+;;; Redistribution and use  in source and binary   forms, with or  without
+;;; modification, are permitted provided that the following conditions are
+;;; met:
+;;;
+;;; 1. Redistributions  of  source  code  must retain  the above copyright
+;;;    notice, this list of conditions and the following disclaimer.
+;;;
+;;; 2. Redistributions in  binary form must reproduce  the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution
+;;;
+;;; THIS  SOFTWARE   IS PROVIDED ``AS  IS''   AND ANY  EXPRESS  OR IMPLIED
+;;; WARRANTIES, INCLUDING, BUT NOT LIMITED  TO, THE IMPLIED WARRANTIES  OF
+;;; MERCHANTABILITY  AND FITNESS FOR A  PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;;; INDIRECT,  INCIDENTAL,  SPECIAL, EXEMPLARY,  OR CONSEQUENTIAL  DAMAGES
+;;; (INCLUDING, BUT NOT LIMITED TO,   PROCUREMENT OF SUBSTITUTE GOODS   OR
+;;; SERVICES;  LOSS OF  USE,  DATA, OR  PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER  CAUSED AND ON ANY THEORY  OF LIABILITY,  WHETHER IN CONTRACT,
+;;; STRICT LIABILITY, OR  TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+;;; IN ANY WAY  OUT OF THE  USE OF THIS SOFTWARE,  EVEN IF ADVISED OF  THE
+;;; POSSIBILITY OF SUCH DAMAGE.
+
+(defpackage :hax
+  (:use :common-lisp)
+  (:export #:abstract-handler
+	   #:default-handler
+
+	   #:make-attribute
+	   #:standard-attribute
+           #:find-attribute
+           #:attribute-name
+           #:attribute-value
+           #:attribute-specified-p
+
+           #:start-document
+           #:start-element
+           #:characters
+           #:end-element
+           #:end-document
+           #:comment
+
+	   #+rune-is-integer
+	   #:%want-strings-p))
+
+(in-package :hax)
+
+
+;;;; ATTRIBUTE
+
+(defgeneric attribute-name (attribute))
+(defgeneric attribute-value (attribute))
+(defgeneric attribute-specified-p (attribute))
+
+(defclass standard-attribute ()
+  ((name :initarg :name :accessor attribute-name)
+   (value :initarg :value :accessor attribute-value)
+   (specified-p :initarg :specified-p :accessor attribute-specified-p)))
+
+(defun make-attribute (name value &optional (specified-p t))
+  (make-instance 'standard-attribute
+                 :name name
+                 :value value
+                 :specified-p specified-p))
+
+(defun %rod= (x y)
+  ;; allow rods *and* strings *and* null
+  (cond
+    ((zerop (length x)) (zerop (length y)))
+    ((zerop (length y)) nil)
+    ((stringp x) (string= x y))
+    (t (runes:rod= x y))))
+
+(defun find-attribute (name attrs)
+  (find name attrs :key #'attribute-name :test #'%rod=))
+
+
+;;;; ABSTRACT-HANDLER and DEFAULT-HANDLER
+
+(defclass abstract-handler () ())
+(defclass default-handler (abstract-handler) ())
+
+#+rune-is-integer
+(defgeneric %want-strings-p (handler)
+  (:method ((handler null)) nil)
+  (:method ((handler abstract-handler)) t))
+
+(defgeneric start-document (handler name public-id system-id)
+  (:method ((handler null) name public-id system-id)
+    (declare (ignore name public-id system-id))
+    nil)
+  (:method ((handler default-handler) name public-id system-id)
+    (declare (ignore name public-id system-id))
+    nil))
+
+(defgeneric start-element (handler name attributes)
+  (:method ((handler null) name attributes)
+    (declare (ignore name attributes))
+    nil)
+  (:method ((handler default-handler) name attributes)
+    (declare (ignore name attributes))
+    nil))
+
+(defgeneric characters (handler data)
+  (:method ((handler null) data)
+    (declare (ignore data))
+    nil)
+  (:method ((handler default-handler) data)
+    (declare (ignore data))
+    nil))
+
+(defgeneric end-element (handler name)
+  (:method ((handler null) name)
+    (declare (ignore name))
+    nil)
+  (:method ((handler default-handler) name)
+    (declare (ignore name))
+    nil))
+
+(defgeneric end-document (handler)
+  (:method ((handler null)) nil)
+  (:method ((handler default-handler)) nil))
+
+(defgeneric comment (handler data)
+  (:method ((handler null) data)
+    (declare (ignore data))
+    nil)
+  (:method ((handler default-handler) data)
+    (declare (ignore data))
+    nil))
+
+
+;;;; documentation
+
+(setf (documentation (find-package :hax) t)
+      "An event protocol for HTML serialization, this package is similar
+       to the SAX protocol defined by cxml for XML serialization.
+
+       (Technically, this package should have been spelled SAH, but HAX
+       sounds better.)
+
+       Note that Closure HTML is not a streaming parser yet.  Documents
+       are always parsed in full before the first HAX event is emitted.
+       In spite of this restriction, the HAX API is useful for HTML
+       serialization and transformation purposes, and for integration
+       with SAX.
+
+       @begin[HAX handlers]{section}
+       @aboutclass{abstract-handler}
+       @aboutclass{default-handler}
+       @end{section}
+       @begin[The attribute protocol]{section}
+       @aboutclass{standard-attribute}
+       @aboutfun{make-attribute}
+       @aboutfun{attribute-name}
+       @aboutfun{attribute-value}
+       @aboutfun{attribute-specified-p}
+       @end{section}
+       @begin[HAX events]{section}
+       @aboutfun{start-document}
+       @aboutfun{start-element}
+       @aboutfun{end-element}
+       @aboutfun{characters}
+       @aboutfun{comment}
+       @aboutfun{end-document}
+       @end{section}")
+
+(setf (documentation 'abstract-handler 'type)
+      "@short{The superclass of all HAX handlers.}
+
+       Direct subclasses have to implement all event methods, since
+       no default methods are defined on this class.
+
+       Note that it is permissible to use handlers that are not
+       instances of this class in some circumstances.
+
+       In particular,
+       @code{nil} is a valid HAX handler and ignores all events.
+
+       In addition,
+       @a[http://common-lisp.net/project/cxml/sax.html#sax]{SAX handlers}
+       are valid HAX handlers (and vice versa), even though
+       hax:abstract-handler and sax:abstract-handler do not
+       share a specific superclass.  HAX events sent to SAX handlers are
+       automatically re-signalled as XHTML SAX events, and SAX events sent
+       to HAX handlers are re-signalled as namespace-less HAX events.
+
+       However, user code should define subclasses of the documented
+       superclasses to enable the HAX/SAX bridging described above.
+
+       @see{chtml:parse}
+       @see{chtml:serialize-lhtml}
+       @see{chtml:serialize-pt}
+       @see{start-document}
+       @see{end-document}
+       @see{start-element}
+       @see{end-element}
+       @see{characters}
+       @see{comment}")
+
+(setf (documentation 'default-handler 'type)
+      "@short{A no-op HAX handler.}
+
+       This class defines methods for all HAX events that do nothing.
+       It is useful as a superclass when implementing a HAX handler that
+       is interested in only some events and not others.
+
+       @see{chtml:parse}
+       @see{chtml:serialize-lhtml}
+       @see{chtml:serialize-pt}
+       @see{start-document}
+       @see{end-document}
+       @see{start-element}
+       @see{end-element}
+       @see{characters}
+       @see{comment}")
+
+(setf (documentation 'standard-attribute 'type)
+      "@short{An implementation of the HAX attribute protocol.}
+
+       A standard class implementing the generic functions for HAX
+       attributes.  Instances of this class can be passed to
+       @fun{hax:start-element} in the list of attributes.
+
+       @see-slot{attribute-name}
+       @see-slot{attribute-value}
+       @see-slot{attribute-specified-p}
+       @see-constructor{make-instance}")
+
+(setf (documentation 'make-attribute 'function)
+      "@arg[name]{a string/rod}
+       @arg[value]{a string/rod}
+       @arg[specified-p]{a boolean, default is @code{t}}
+       @return{an instance of @class{standard-attribute}.}
+       @short{Creates a HAX attribute.}
+
+       Creates an instance that can be used with the generic functions
+       for HAX attributes.  The result can be passed to
+       @fun{hax:start-element} in the list of attributes.
+
+       @see{attribute-name}
+       @see{attribute-value}
+       @see{attribute-specified-p}")
+
+(setf (documentation 'find-attribute 'function)
+      "@arg[name]{a string/rod}
+       @arg[attrs]{a list of attributes}
+       @return{an attribute, or nil}
+       @short{Searches for an attribute by name.}
+
+       Returns the first attribute in @var{attrs} with the specified name,
+       or @code{nil} if no such attribute was found.
+
+       @see{attribute-name}")
+
+(setf (documentation 'attribute-name 'function)
+      "@arg[instance]{any class implementing this function}
+       @return{a string/rod}
+       @short{Return an attribute's name.}
+
+       Instances of this classes implementing this function can be passed to
+       @fun{hax:start-element} in the list of attributes.
+
+       @see{attribute-value}
+       @see{attribute-specified-p}")
+
+(setf (documentation 'attribute-value 'function)
+      "@arg[instance]{any class implementing this function}
+       @return{a string/rod}
+       @short{Return an attribute's value.}
+
+       Instances of this classes implementing this function can be passed to
+       @fun{hax:start-element} in the list of attributes.
+
+       @see{attribute-name}
+       @see{attribute-specified-p}")
+
+(setf (documentation 'attribute-specified-p 'function)
+      "@arg[instance]{any class implementing this function}
+       @return{a string/rod}
+       @short{Return whether the attribute was contained the parsed document.}
+
+       Attributes return @code{nil} here if they resulted from a default
+       value declaration in a DTD.
+
+       Instances of this classes implementing this function can be passed to
+       @fun{hax:start-element} in the list of attributes.
+
+       @see{attribute-name}
+       @see{attribute-value}")
+
+(setf (documentation 'start-document 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @arg[name]{root element name, a rod/string}
+       @arg[public-id]{nil or the Public ID, a rod/string}
+       @arg[system-id]{nil or the System ID/URI, a rod/string}
+       @return{unspecified}
+       @short{Signals the beginning of an HTML document.}
+
+       This is the first event sent to any handler.
+
+       If @var{system-id} is non-nil, the document includes a doctype
+       declaration.
+
+       @see{start-element}
+       @see{end-element}
+       @see{characters}
+       @see{comment}
+       @see{end-document}")
+
+(setf (documentation 'start-element 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @arg[name]{root element name, a rod/string}
+       @arg[attributes]{a list of attributes}
+       @return{unspecified}
+       @short{Signals the beginning of an HTML element.}
+
+       This event corresponds to the opening tag of an element.
+
+       Elements of the attribute list can have any class, but must implement
+       the generic functions for attributes.  See @class{standard-attribute}
+       for the built-in attribute implementation.
+
+       @see{find-attribute}
+       @see{start-document}
+       @see{end-element}
+       @see{characters}
+       @see{comment}
+       @see{end-document}")
+
+(setf (documentation 'end-element 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @arg[name]{root element name, a rod/string}
+       @return{unspecified}
+       @short{Signals the end of an HTML element.}
+
+       This event corresponds to the closing tag of an element.
+
+       @see{start-document}
+       @see{start-element}
+       @see{characters}
+       @see{comment}
+       @see{end-document}")
+
+(setf (documentation 'characters 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @arg[data]{rod/string}
+       @return{unspecified}
+       @short{Signals character data.}
+
+       This event represents character data in a document.
+
+       @see{start-document}
+       @see{start-element}
+       @see{end-element}
+       @see{comment}
+       @see{end-document}")
+
+(setf (documentation 'comment 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @arg[data]{rod/string}
+       @return{unspecified}
+       @short{Signals a comment.}
+
+       This event represents a comment.
+
+       @see{start-document}
+       @see{start-element}
+       @see{end-element}
+       @see{characters}
+       @see{end-document}")
+
+(setf (documentation 'end-document 'function)
+      "@arg[handler]{a HAX/SAX handler
+         (see @class{abstract-handler} for details)}
+       @return{The return value of this function depends on the handler class.}
+       @short{Signals the end of an HTML document.}
+
+       This is the last event sent to any handler, and signals the end of
+       serialization.
+
+       The return value of this function is usually returned to user code
+       by higher-level serialization functions and can be considered the
+       result of serialization and \"return value\" of the handler.
+
+       @see{start-document}
+       @see{start-element}
+       @see{end-element}
+       @see{characters}
+       @see{comment}")

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/package.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,99 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Generating a sane DEFPACKAGE for RUNES
+;;;   Created: 1999-05-25
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999,2000 by Gilbert Baumann
+
+(in-package :cl-user)
+
+(defpackage :runes
+  (:use :cl #-scl :trivial-gray-streams)
+  (:export #:definline
+
+           ;; runes.lisp
+           #:rune
+           #:rod
+           #:simple-rod
+           #:%rune
+           #:rod-capitalize
+           #:code-rune
+           #:rune-code
+           #:rune-downcase
+           #:rune-upcase
+           #:rod-downcase
+           #:rod-upcase
+           #:white-space-rune-p
+           #:digit-rune-p
+           #:rune=
+           #:rune<=
+           #:rune>=
+           #:rune-equal
+           #:runep
+           #:sloopy-rod-p
+           #:rod=
+           #:rod-equal
+           #:make-rod
+           #:char-rune
+           #:rune-char
+           #:rod-string
+           #:string-rod
+           #:rod-subseq
+           #:rod<
+
+           ;; xstream.lisp
+           #:xstream
+           #:make-xstream
+           #:make-rod-xstream
+           #:close-xstream
+           #:xstream-p
+           #:read-rune
+           #:peek-rune
+           #:fread-rune
+           #:fpeek-rune
+           #:consume-rune
+           #:unread-rune
+           #:xstream-position
+           #:xstream-line-number
+           #:xstream-column-number
+           #:xstream-plist
+           #:xstream-encoding
+           #:set-to-full-speed
+           #:xstream-name
+
+           ;; ystream.lisp
+	   #:ystream
+	   #:close-ystream
+	   #:write-rune
+	   #:write-rod
+	   #:ystream-column
+           #:make-octet-vector-ystream
+           #:make-octet-stream-ystream
+           #:make-rod-ystream
+           #+rune-is-character #:make-character-stream-ystream
+	   ;; These don't make too much sense on Unicode-enabled,
+	   ;; implementations but for those applications using them anyway,
+	   ;; I have commented out the reader conditionals now:
+           ;; #+rune-is-integer
+	   #:make-string-ystream/utf8
+           ;; #+rune-is-integer
+	   #:make-character-stream-ystream/utf8
+	   #:runes-to-utf8/adjustable-string
+
+	   #:rod-to-utf8-string
+	   #:utf8-string-to-rod
+	   #:make-octet-input-stream))
+
+(defpackage :utf8-runes
+  (:use :cl)
+  (:export *utf8-runes-readtable*
+	   #:rune #:rod #:simple-rod #:rod-string #:rod= #:make-rod
+	   #:string-rod))
+
+(defpackage :runes-encoding
+  (:use :cl :runes)
+  (:export
+   #:encoding-error
+   #:find-encoding
+   #:decode-sequence))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/runes.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/runes.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,230 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Unicode strings (called RODs)
+;;;   Created: 1999-05-25 22:29
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1998,1999 by Gilbert Baumann
+
+;;; This code is free software; you can redistribute it and/or modify it
+;;; under the terms of the version 2.1 of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, as clarified
+;;; by the "Preamble to the Gnu Lesser General Public License" found in
+;;; the file COPYING.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; Version 2.1 of the GNU Lesser General Public License is in the file
+;;; COPYING that was distributed with this file.  If it is not present,
+;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
+;;; superseded by a newer version) or write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;; Changes
+;;
+;;  When        Who     What
+;; ----------------------------------------------------------------------------
+;;  1999-08-15  GB      - ROD=, ROD-EQUAL
+;;                        RUNE<=, RUNE>=
+;;                        MAKE-ROD, ROD-SUBSEQ
+;;                        CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
+;;                        new functions
+;;                      - Added rune reader
+;;
+
+(in-package :runes)
+
+(deftype rune () '(unsigned-byte 16))
+(deftype rod () '(array rune (*)))
+(deftype simple-rod () '(simple-array rune (*)))
+
+(definline rune (rod index)
+  (aref rod index))
+
+(defun (setf rune) (new rod index)
+  (setf (aref rod index) new))
+
+(definline %rune (rod index)
+  (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)))
+
+(definline (setf %rune) (new rod index)
+  (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new))
+
+(defun rod-capitalize (rod)
+  (warn "~S is not implemented." 'rod-capitalize)
+  rod)
+
+(definline code-rune (x) x)
+(definline rune-code (x) x)
+
+(definline rune= (x y) 
+  (= x y))
+
+(defun rune-downcase (rune)
+  (cond ((<= #x0041 rune #x005a) (+ rune #x20))
+        ((= rune #x00d7) rune)
+        ((<= #x00c0 rune #x00de) (+ rune #x20))
+        (t rune)))
+
+(definline rune-upcase (rune)
+  (cond ((<= #x0061 rune #x007a) (- rune #x20))
+        ((= rune #x00f7) rune)
+        ((<= #x00e0 rune #x00fe) (- rune #x20))
+        (t rune)))
+
+(defun rune-upper-case-letter-p (rune)
+  (or (<= #x0041 rune #x005a) (<= #x00c0 rune #x00de)))
+
+(defun rune-lower-case-letter-p (rune)
+  (or (<= #x0061 rune #x007a) (<= #x00e0 rune #x00fe)
+      (= rune #x00d7)))
+
+
+(defun rune-equal (x y)
+  (rune= (rune-upcase x) (rune-upcase y)))
+
+(defun rod-downcase (rod)
+  ;; FIXME
+  (map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod))
+
+(defun rod-upcase (rod)
+  ;; FIXME
+  (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod))
+
+(definline white-space-rune-p (char)
+  (or (= char 9)        ;TAB
+      (= char 10)       ;Linefeed
+      (= char 13)       ;Carriage Return
+      (= char 32)))     ;Space
+
+(definline digit-rune-p (char &optional (radix 10))
+  (cond ((<= #.(char-code #\0) char #.(char-code #\9))
+         (and (< (- char #.(char-code #\0)) radix)
+              (- char #.(char-code #\0))))
+        ((<= #.(char-code #\A) char #.(char-code #\Z))
+         (and (< (- char #.(char-code #\A) -10) radix)
+              (- char #.(char-code #\A) -10)))
+        ((<= #.(char-code #\a) char #.(char-code #\z))
+         (and (< (- char #.(char-code #\a) -10) radix)
+              (- char #.(char-code #\a) -10))) ))
+
+(defun rod (x)
+  (cond ((stringp x)    (map 'rod #'char-code x))
+        ((symbolp x)    (rod (string x)))
+        ((characterp x) (rod (string x)))
+        ((vectorp x)    (coerce x 'rod))
+        ((integerp x)   (map 'rod #'identity (list x)))
+        (t              (error "Cannot convert ~S to a ~S" x 'rod))))
+
+(defun runep (x)
+  (and (integerp x)
+       (<= 0 x #xFFFF)))
+
+(defun sloopy-rod-p (x)
+  (and (not (stringp x))
+       (vectorp x)
+       (every #'runep x)))
+
+(defun rod= (x y)
+  (and (= (length x) (length y))
+       (dotimes (i (length x) t)
+         (unless (rune= (rune x i) (rune y i))
+           (return nil)))))
+
+(defun rod-equal (x y)
+  (and (= (length x) (length y))
+       (dotimes (i (length x) t)
+         (unless (rune-equal (rune x i) (rune y i))
+           (return nil)))))
+
+(definline make-rod (size)
+  (make-array size :element-type 'rune))
+
+(defun char-rune (char)
+  (code-rune (char-code char)))
+
+(defparameter *invalid-rune* nil ;;#\?
+  "Rune to use as a replacement in RUNE-CHAR and ROD-STRING for runes not
+   representable as characters.  If NIL, an error is signalled instead.")
+
+(defun rune-char (rune &optional (default *invalid-rune*))
+  (or (if (>= rune char-code-limit)
+          default
+          (or (code-char rune) default))
+      (error "rune cannot be represented as a character: ~A" rune)))
+
+(defun rod-string (rod &optional (default-char *invalid-rune*))
+  (map 'string (lambda (x) (rune-char x default-char)) rod))
+
+(defun string-rod (string)
+  (let* ((n (length string))
+         (res (make-rod n)))
+    (dotimes (i n)
+      (setf (%rune res i) (char-rune (char string i))))
+    res))
+
+;;;;
+
+(defun rune<= (rune &rest more-runes)
+  (apply #'<= rune more-runes))
+
+(defun rune>= (rune &rest more-runes)
+  (apply #'>= rune more-runes))
+
+(defun rodp (object)
+  (typep object 'rod))
+
+(defun rod-subseq (source start &optional (end (length source)))
+  (unless (rodp source)
+    (error "~S is not of type ~S." source 'rod))
+  (unless (and (typep start 'fixnum) (>= start 0))
+    (error "~S is not a non-negative fixnum." start))
+  (unless (and (typep end 'fixnum) (>= end start))
+    (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
+  (when (> start (length source))
+    (error "START argument, ~S, should be no greater than length of rod." start))
+  (when (> end (length source))
+    (error "END argument, ~S, should be no greater than length of rod." end))
+  (locally
+      (declare (type rod source)
+               (type fixnum start end))
+    (let ((res (make-rod (- end start))))
+      (declare (type rod res))
+      (do ((i (- (- end start) 1) (the fixnum (- i 1))))
+          ((< i 0) res)
+        (declare (type fixnum i))
+        (setf (%rune res i) (%rune source (the fixnum (+ i start))))))))
+
+(defun rod-subseq* (source start &optional (end (length source)))
+  (unless (and (typep start 'fixnum) (>= start 0))
+    (error "~S is not a non-negative fixnum." start))
+  (unless (and (typep end 'fixnum) (>= end start))
+    (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
+  (when (> start (length source))
+    (error "START argument, ~S, should be no greater than length of rod." start))
+  (when (> end (length source))
+    (error "END argument, ~S, should be no greater than length of rod." end))
+  (locally
+      (declare (type fixnum start end))
+    (let ((res (make-rod (- end start))))
+      (declare (type rod res))
+      (do ((i (- (- end start) 1) (the fixnum (- i 1))))
+          ((< i 0) res)
+        (declare (type fixnum i))
+        (setf (%rune res i) (aref source (the fixnum (+ i start))))))))
+
+(defun rod< (rod1 rod2)
+  (do ((i 0 (+ i 1)))
+      (nil)
+    (cond ((= i (length rod1))
+           (return t))
+          ((= i (length rod2))
+           (return nil))
+          ((< (aref rod1 i) (aref rod2 i))
+           (return t))
+          ((> (aref rod1 i) (aref rod2 i))
+           (return nil)))))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/stream-scl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/stream-scl.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,253 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Fast streams
+;;;   Created: 1999-07-17
+;;;    Author: Douglas Crosher
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2007 by Douglas Crosher
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :runes)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *fast* '(optimize (speed 3) (safety 3))))
+
+(deftype runes-encoding:encoding-error ()
+  'ext:character-conversion-error)
+
+

+;;; xstream
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defclass xstream (ext:character-stream)
+  ((name :initarg :name :initform nil
+	 :accessor xstream-name)
+   (column :initarg :column :initform 0)
+   (line :initarg :line :initform 1)
+   (unread-column :initarg :unread-column :initform 0)))
+
+(defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream)
+  ())
+
+) ; eval-when
+
+(defun make-eol-conversion-xstream (source-stream)
+  "Returns a character stream that conversion CR-LF pairs and lone CR
+  characters into single linefeed character."
+  (declare (type stream source-stream))
+  (let ((stream (ext:make-eol-conversion-stream source-stream
+						:input t
+						:close-stream-p t)))
+    (change-class stream 'eol-conversion-xstream)))
+
+(definline xstream-p (stream)
+  (typep stream 'xstream))
+
+(defun close-xstream (input)
+  (close input))
+
+(definline read-rune (input)
+  (declare (type stream input)
+	   (inline read-char)
+	   #.*fast*)
+  (let ((char (read-char input nil :eof)))
+    (cond ((member char '(#\UFFFE #\UFFFF))
+	   ;; These characters are illegal within XML documents.
+	   (simple-error 'ext:character-conversion-error
+			 "~@<Illegal XML document character: ~S~:@>" char))
+	  ((eql char #\linefeed)
+	   (setf (slot-value input 'unread-column) (slot-value input 'column))
+	   (setf (slot-value input 'column) 0)
+	   (incf (the kernel:index (slot-value input 'line))))
+	  (t
+	   (incf (the kernel:index (slot-value input 'column)))))
+    char))
+
+(definline peek-rune (input)
+  (declare (type stream input)
+	   (inline peek-char)
+	   #.*fast*)
+  (peek-char nil input nil :eof))
+
+(definline consume-rune (input)
+  (declare (type stream input)
+	   (inline read-rune)
+	   #.*fast*)
+  (read-rune input)
+  nil)
+
+(definline unread-rune (rune input)
+  (declare (type stream input)
+	   (inline unread-char)
+	   #.*fast*)
+  (unread-char rune input)
+  (cond ((eql rune #\linefeed)
+	 (setf (slot-value input 'column) (slot-value input 'unread-column))
+	 (setf (slot-value input 'unread-column) 0)
+	 (decf (the kernel:index (slot-value input 'line))))
+	(t
+	 (decf (the kernel:index (slot-value input 'column)))))
+  nil)
+
+(defun fread-rune (input)
+  (read-rune input))
+
+(defun fpeek-rune (input)
+  (peek-rune input))
+
+(defun xstream-position (input)
+  (file-position input))
+
+(defun runes-encoding:find-encoding (encoding)
+  encoding)
+
+(defun make-xstream (os-stream &key name
+                                    (speed 8192)
+                                    (initial-speed 1)
+                                    (initial-encoding :guess))
+  (declare (ignore speed))
+  (assert (eql initial-speed 1))
+  (assert (eq initial-encoding :guess))
+  (let* ((stream (ext:make-xml-character-conversion-stream os-stream
+							   :input t
+							   :close-stream-p t))
+	 (xstream (make-eol-conversion-xstream stream)))
+    (setf (xstream-name xstream) name)
+    xstream))
+
+
+(defclass xstream-string-input-stream (lisp::string-input-stream xstream)
+  ())
+
+(defun make-rod-xstream (string &key name)
+  (declare (type string string))
+  (let ((stream (make-string-input-stream string)))
+    (change-class stream 'xstream-string-input-stream :name name)))
+
+;;; already at 'full speed' so just return the buffer size.
+(defun set-to-full-speed (stream)
+  (length (ext:stream-in-buffer stream)))
+
+(defun xstream-speed (stream)
+  (length (ext:stream-in-buffer stream)))
+
+(defun xstream-line-number (stream)
+  (slot-value stream 'line))
+
+(defun xstream-column-number (stream)
+  (slot-value stream 'column))
+
+(defun xstream-encoding (stream)
+  (stream-external-format stream))
+
+;;; the encoding will have already been detected, but it is checked against the
+;;; declared encoding here.
+(defun (setf xstream-encoding) (declared-encoding stream)
+  (let* ((initial-encoding (xstream-encoding stream))
+	 (canonical-encoding
+	  (cond ((and (eq initial-encoding :utf-16le)
+		      (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le)
+			      :test 'string-equal))
+		 :utf-16le)
+		((and (eq initial-encoding :utf-16be)
+		      (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be)
+			      :test 'string-equal))
+		 :utf-16be)
+		((and (eq initial-encoding :ucs-4be)
+		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be)
+			      :test 'string-equal))
+		 :ucs4-be)
+		((and (eq initial-encoding :ucs-4le)
+		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le)
+			      :test 'string-equal))
+		 :ucs4-le)
+		(t
+		 declared-encoding))))
+    (unless (string-equal initial-encoding canonical-encoding)
+      (warn "Unable to change xstream encoding from ~S to ~S (~S)~%"
+	    initial-encoding declared-encoding canonical-encoding))
+    declared-encoding))
+
+

+;;; ystream - a run output stream.
+
+(deftype ystream () 'stream)
+
+(defun ystream-column (stream)
+  (ext:line-column stream))
+
+(definline write-rune (rune stream)
+  (declare (inline write-char))
+  (write-char rune stream))
+
+(defun write-rod (rod stream)
+  (declare (type rod rod)
+	   (type stream stream))
+  (write-string rod stream))
+
+(defun make-rod-ystream ()
+  (make-string-output-stream))
+
+(defun close-ystream (stream)
+  (etypecase stream
+    (ext:string-output-stream
+     (get-output-stream-string stream))
+    (ext:character-conversion-output-stream
+     (let ((target (slot-value stream 'stream)))
+       (close stream)
+       (if (typep target 'ext:byte-output-stream)
+	   (ext:get-output-stream-bytes target)
+	   stream)))))
+
+;;;; CHARACTER-STREAM-YSTREAM
+
+(defun make-character-stream-ystream (target-stream)
+  target-stream)
+
+
+;;;; OCTET-VECTOR-YSTREAM
+
+(defun make-octet-vector-ystream ()
+  (let ((target (ext:make-byte-output-stream)))
+    (ext:make-character-conversion-stream target :output t
+					  :external-format :utf-8
+					  :close-stream-p t)))
+
+;;;; OCTET-STREAM-YSTREAM
+
+(defun make-octet-stream-ystream (os-stream)
+  (ext:make-character-conversion-stream os-stream :output t
+					:external-format :utf-8
+					:close-stream-p t))
+
+

+;;;; helper functions
+
+(defun rod-to-utf8-string (rod)
+  (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8)
+			      :iso-8859-1))
+
+(defun utf8-string-to-rod (str)
+  (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)))
+    (ext:make-string-from-bytes bytes :utf-8)))
+
+(defun make-octet-input-stream (octets)
+  (ext:make-byte-input-stream octets))
+
+


Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/syntax.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/syntax.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,181 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Unicode strings (called RODs)
+;;;   Created: 1999-05-25 22:29
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1998,1999 by Gilbert Baumann
+
+;;; This code is free software; you can redistribute it and/or modify it
+;;; under the terms of the version 2.1 of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, as clarified
+;;; by the "Preamble to the Gnu Lesser General Public License" found in
+;;; the file COPYING.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; Version 2.1 of the GNU Lesser General Public License is in the file
+;;; COPYING that was distributed with this file.  If it is not present,
+;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
+;;; superseded by a newer version) or write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;; Changes
+;;
+;;  When        Who     What
+;; ----------------------------------------------------------------------------
+;;  1999-08-15  GB      - ROD=, ROD-EQUAL
+;;                        RUNE<=, RUNE>=
+;;                        MAKE-ROD, ROD-SUBSEQ
+;;                        CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
+;;                        new functions
+;;                      - Added rune reader
+;;
+
+(in-package :runes)
+
+;;;;
+;;;; RUNE Reader
+;;;;
+
+;; Portable implementation of WHITE-SPACE-P with regard to the current
+;; read table -- this is bit tricky.
+
+(defun rt-white-space-p (char)
+  (let ((stream (make-string-input-stream (string char))))
+    (eq :eof (peek-char t stream nil :eof))))
+
+(defun read-rune-name (input)
+  ;; the first char is unconditionally read
+  (let ((char0 (read-char input t nil t)))
+    (when (char= char0 #\\)
+      (setf char0 (read-char input t nil t)))
+    (with-output-to-string (res)
+      (write-char char0 res)
+      (do ((ch (peek-char nil input nil :eof t) (peek-char nil input nil :eof t)))
+          ((or (eq ch :eof)
+               (rt-white-space-p ch)
+               (multiple-value-bind (function non-terminating-p) (get-macro-character ch)
+                 (and function (not non-terminating-p)))))
+        (write-char ch res)
+        (read-char input)))))           ;consume this character
+
+(defun iso-10646-char-code (char)
+  (char-code char))
+
+(defvar *rune-names* (make-hash-table :test #'equal)
+  "Hashtable, which maps all known rune names to rune codes;
+   Names are stored in uppercase.")
+
+(defun define-rune-name (name code)
+  (setf (gethash (string-upcase name) *rune-names*) code)
+  name)
+
+(defun lookup-rune-name (name)
+  (gethash (string-upcase name) *rune-names*))
+
+(define-rune-name "null"        #x0000)
+(define-rune-name "space"       #x0020)
+(define-rune-name "newline"     #x000A)
+(define-rune-name "return"      #x000D)
+(define-rune-name "tab"         #x0009)
+(define-rune-name "page"        #x000C)
+
+;; and just for fun:
+(define-rune-name "euro"        #x20AC)
+
+;; ASCII control characters
+(define-rune-name "nul"  #x0000)        ;null
+(define-rune-name "soh"  #x0001)        ;start of header
+(define-rune-name "stx"  #x0002)        ;start of text
+(define-rune-name "etx"  #x0003)        ;end of text
+(define-rune-name "eot"  #x0004)        ;end of transmission
+(define-rune-name "enq"  #x0005)        ;
+(define-rune-name "ack"  #x0006)        ;acknowledge
+(define-rune-name "bel"  #x0007)        ;bell
+(define-rune-name "bs"   #x0008)        ;backspace
+(define-rune-name "ht"   #x0009)        ;horizontal tab
+(define-rune-name "lf"   #X000A)        ;line feed, new line
+(define-rune-name "vt"   #X000B)        ;vertical tab
+(define-rune-name "ff"   #x000C)        ;form feed
+(define-rune-name "cr"   #x000D)        ;carriage return
+(define-rune-name "so"   #x000E)        ;shift out
+(define-rune-name "si"   #x000F)        ;shift in
+(define-rune-name "dle"  #x0010)        ;device latch enable ?
+(define-rune-name "dc1"  #x0011)        ;device control 1
+(define-rune-name "dc2"  #x0012)        ;device control 2
+(define-rune-name "dc3"  #x0013)        ;device control 3
+(define-rune-name "dc4"  #x0014)        ;device control 4
+(define-rune-name "nak"  #x0015)        ;negative acknowledge
+(define-rune-name "syn"  #x0016)        ;
+(define-rune-name "etb"  #x0017)        ;
+(define-rune-name "can"  #x0018)        ;
+(define-rune-name "em"   #x0019)        ;end of message
+(define-rune-name "sub"  #x001A)        ;
+(define-rune-name "esc"  #x001B)        ;escape
+(define-rune-name "fs"   #x001C)        ;field separator ?
+(define-rune-name "gs"   #x001D)        ;group separator
+(define-rune-name "rs"   #x001E)        ;
+(define-rune-name "us"   #x001F)        ;
+ 
+(define-rune-name "del"  #x007F)        ;delete
+
+;; iso-latin
+(define-rune-name "nbsp" #x00A0)        ;non breakable space
+(define-rune-name "shy"  #x00AD)        ;soft hyphen
+
+(defun rune-from-read-name (name)
+  (code-rune
+   (cond ((= (length name) 1)
+           (iso-10646-char-code (char name 0)))
+     ((and (= (length name) 2)
+           (char= (char name 0) #\\))
+       (iso-10646-char-code (char name 1)))
+     ((and (>= (length name) 3)
+           (char-equal (char name 0) #\u)
+           (char-equal (char name 1) #\+)
+           (every (lambda (x) (digit-char-p x 16)) (subseq name 2)))
+       (parse-integer name :start 2 :radix 16))
+     ((lookup-rune-name name))
+     (t
+       (error "Meaningless rune name ~S." name)))))
+
+(defun rune-reader (stream subchar arg)
+  subchar arg
+  (values (rune-from-read-name (read-rune-name stream))))
+
+(set-dispatch-macro-character #\# #\/ 'rune-reader)
+
+;;; ROD ext syntax
+
+(defun rod-reader (stream subchar arg)
+  (declare (ignore arg))
+  (rod
+   (with-output-to-string (bag)
+     (do ((c (read-char stream t nil t)
+             (read-char stream t nil t)))
+         ((char= c subchar))
+       (cond ((char= c #\\)
+              (setf c (read-char stream t nil t))))
+       (princ c bag)))))
+
+#-rune-is-character
+(defun rod-printer (stream rod)
+  (princ #\# stream)
+  (princ #\" stream)
+  (loop for x across rod do
+        (cond ((or (rune= x #.(char-rune #\\))
+                   (rune= x #.(char-rune #\")))
+               (princ #\\ stream)
+               (princ (code-char x) stream))
+              ((< x char-code-limit)
+               (princ (code-char x) stream))
+              (t
+               (format stream "\\u~4,'0X" x))))
+  (princ #\" stream))
+
+(set-dispatch-macro-character #\# #\" 'rod-reader)

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/utf8.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/utf8.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,36 @@
+;;; copyright (c) 2005 David Lichteblau <david at lichteblau.com>
+;;; License: Lisp-LGPL (See file COPYING for details).
+;;;
+;;; Rune emulation for the UTF-8-compatible DOM implementation.
+;;; Used only with 8 bit characters on non-unicode Lisps.
+
+(in-package :utf8-runes)
+
+(deftype rune () 'character)
+(deftype rod () '(vector rune))
+(deftype simple-rod () '(simple-array rune))
+
+(defun rod= (r s)
+  (string= r s))
+
+(defun rod-string (rod &optional default)
+  (declare (ignore default))
+  rod)
+
+(defun string-rod (string)
+  string)
+
+(defun make-rod (size)
+  (make-string size :element-type 'rune))
+
+(defun rune-reader (stream subchar arg)
+  (runes::rune-char (runes::rune-reader stream subchar arg)))
+
+(defun rod-reader (stream subchar arg)
+  (runes::rod-string (runes::rod-reader stream subchar arg)))
+
+(setf closure-common-system:*utf8-runes-readtable*
+      (let ((rt (copy-readtable)))
+	(set-dispatch-macro-character #\# #\/ 'rune-reader rt)
+	(set-dispatch-macro-character #\# #\" 'rod-reader rt)
+	rt))

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/xstream.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/xstream.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,411 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Fast streams
+;;;   Created: 1999-07-17
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999 by Gilbert Baumann
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :runes)
+
+;;; API
+;; 
+;; MAKE-XSTREAM cl-stream &key name! speed initial-speed initial-encoding
+;;                                                              [function]
+;; MAKE-ROD-XSTREAM rod &key name                               [function]
+;; CLOSE-XSTREAM xstream                                        [function]
+;; XSTREAM-P object                                             [function]
+;;
+;; READ-RUNE xstream                                               [macro]
+;; PEEK-RUNE xstream                                               [macro]
+;; FREAD-RUNE xstream                                           [function]
+;; FPEEK-RUNE xstream                                           [function]
+;; CONSUME-RUNE xstream                                            [macro]
+;; UNREAD-RUNE rune xstream                                     [function]
+;;
+;; XSTREAM-NAME xstream                                         [accessor]
+;; XSTREAM-POSITION xstream                                     [function]
+;; XSTREAM-LINE-NUMBER xstream                                  [function]
+;; XSTREAM-COLUMN-NUMBER xstream                                [function]
+;; XSTREAM-PLIST xstream                                        [accessor]
+;; XSTREAM-ENCODING xstream                                     [accessor]  <-- be careful here. [*]
+;; SET-TO-FULL-SPEED xstream                                    [function]
+
+;; [*] switching the encoding on the fly is only possible when the
+;; stream's buffer is empty; therefore to be able to switch the
+;; encoding, while some runes are already read, set the stream's speed
+;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM)
+;; and later set it to full speed. (The encoding of the runes
+;; sequence, you fetch off with READ-RUNE is always UTF-16 though).
+;; After switching the encoding, SET-TO-FULL-SPEED can be used to bump the
+;; speed up to a full buffer length.
+
+;; An encoding is simply something, which provides the DECODE-SEQUENCE
+;; method.
+
+;;; Controller protocol
+;;
+;; READ-OCTECTS sequence os-stream start end -> first-non-written
+;; XSTREAM/CLOSE os-stream
+;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *fast* '(optimize (speed 3) (safety 0))))
+
+;; Let us first define fast fixnum arithmetric get rid of type
+;; checks. (After all we know what we do here).
+
+(defmacro fx-op (op &rest xs) 
+  `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
+(defmacro fx-pred (op &rest xs) 
+  `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
+
+(defmacro %+   (&rest xs) `(fx-op + , at xs))
+(defmacro %=  (&rest xs)  `(fx-pred = , at xs))
+
+(deftype buffer-index ()
+  `(unsigned-byte ,(integer-length array-total-size-limit)))
+
+(deftype buffer-byte ()
+  `(unsigned-byte 16))
+
+(deftype octet ()
+  `(unsigned-byte 8))
+
+;; The usage of a special marker for EOF is experimental and
+;; considered unhygenic.
+
+(defconstant +end+ #xFFFF
+  "Special marker inserted into stream buffers to indicate end of buffered data.")
+
+(defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte))
+(defvar +null-octet-buffer+ (make-array 0 :element-type 'octet))
+
+(defstruct (xstream 
+            (:constructor make-xstream/low)
+            (:copier nil)
+            (:print-function print-xstream))
+  
+  ;;; Read buffer
+  
+  ;; the buffer itself
+  (buffer +null-buffer+ 
+          :type (simple-array buffer-byte (*)))
+  ;; points to the next element of `buffer' containing the next rune
+  ;; about to be read.
+  (read-ptr      0 :type buffer-index)
+  ;; points to the first element of `buffer' not containing a rune to
+  ;; be read.
+  (fill-ptr      0 :type buffer-index)
+
+  ;;; OS buffer
+  
+  ;; a scratch pad for READ-SEQUENCE
+  (os-buffer +null-octet-buffer+
+             :type (simple-array octet (*)))
+  
+  ;; `os-left-start', `os-left-end' designate a region of os-buffer,
+  ;; which still contains some undecoded data. This is needed because
+  ;; of the DECODE-SEQUENCE protocol
+  (os-left-start 0 :type buffer-index)
+  (os-left-end   0 :type buffer-index)
+  
+  ;; How much to read each time
+  (speed         0 :type buffer-index)
+  (full-speed    0 :type buffer-index)
+  
+  ;; Some stream object obeying to a certain protcol
+  os-stream
+
+  ;; The external format 
+  ;; (some object offering the ENCODING protocol)
+  (encoding :utf-8)
+
+  ;;A STREAM-NAME object
+  (name nil)
+  
+  ;; a plist a struct keeps the hack away
+  (plist nil)
+  
+  ;; Stream Position
+  (line-number 1 :type integer)         ;current line number
+  (line-start  0 :type integer)         ;stream position the current line starts at
+  (buffer-start 0 :type integer)        ;stream position the current buffer starts at
+  
+  ;; There is no need to maintain a column counter for each character
+  ;; read, since we can easily compute it from `line-start' and
+  ;; `buffer-start'.
+  )
+
+(defun print-xstream (self sink depth)
+  (declare (ignore depth))
+  (format sink "#<~S ~S>" (type-of self) (xstream-name self)))
+
+(defmacro read-rune (input)
+  "Read a single rune off the xstream `input'. In case of end of file :EOF 
+   is returned."
+  `((lambda (input)
+      (declare (type xstream input)
+               #.*fast*)
+      (let ((rp (xstream-read-ptr input)))
+        (declare (type buffer-index rp))
+        (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
+                        rp)))
+          (declare (type buffer-byte ch))
+          (setf (xstream-read-ptr input) (%+ rp 1))
+          (cond ((%= ch +end+)
+                 (the (or (member :eof) rune)
+                   (xstream-underflow input)))
+                ((%= ch #x000A)         ;line break
+                 (account-for-line-break input)
+                 (code-rune ch))
+                (t
+                 (code-rune ch))))))
+    ,input))
+
+(defmacro peek-rune (input)
+  "Peek a single rune off the xstream `input'. In case of end of file :EOF
+   is returned."
+  `((lambda (input)
+      (declare (type xstream input)
+               #.*fast*)
+      (let ((rp (xstream-read-ptr input)))
+        (declare (type buffer-index rp))
+        (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
+                        rp)))
+          (declare (type buffer-byte ch))
+          (cond ((%= ch +end+)
+                 (prog1
+                     (the (or (member :eof) rune) (xstream-underflow input))
+                   (setf (xstream-read-ptr input) 0)))
+                (t
+                 (code-rune ch))))))
+    ,input))
+
+(defmacro consume-rune (input)
+  "Like READ-RUNE, but does not actually return the read rune."
+  `((lambda (input)
+      (declare (type xstream input)
+               #.*fast*)
+      (let ((rp (xstream-read-ptr input)))
+        (declare (type buffer-index rp))
+        (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
+                        rp)))
+          (declare (type buffer-byte ch))
+          (setf (xstream-read-ptr input) (%+ rp 1))
+          (when (%= ch +end+)
+            (xstream-underflow input))
+          (when (%= ch #x000A)         ;line break
+            (account-for-line-break input) )))
+      nil)
+    ,input))
+
+(definline unread-rune (rune input)
+  "Unread the last recently read rune; if there wasn't such a rune, you
+   deserve to lose."
+  (declare (ignore rune))
+  (decf (xstream-read-ptr input))
+  (when (rune= (peek-rune input) #/u+000A)   ;was it a line break?
+    (unaccount-for-line-break input)))
+
+(defun fread-rune (input)
+  (read-rune input))
+
+(defun fpeek-rune (input)
+  (peek-rune input))
+
+;;; Line counting
+
+(defun account-for-line-break (input)
+  (declare (type xstream input))
+  (incf (xstream-line-number input))
+  (setf (xstream-line-start input)
+    (+ (xstream-buffer-start input) (xstream-read-ptr input))))
+
+(defun unaccount-for-line-break (input)
+  ;; incomplete! 
+  ;; We better use a traditional lookahead technique or forbid unread-rune.
+  (decf (xstream-line-number input)))
+
+;; User API:
+
+(defun xstream-position (input)
+  (+ (xstream-buffer-start input) (xstream-read-ptr input)))
+
+;; xstream-line-number is structure accessor
+
+(defun xstream-column-number (input)
+  (+ (- (xstream-position input)
+        (xstream-line-start input))
+     1))
+
+;;; Underflow
+
+(defconstant +default-buffer-size+ 100)
+
+(defmethod xstream-underflow ((input xstream))
+  (declare (type xstream input))
+  ;; we are about to fill new data into the buffer, so we need to
+  ;; adjust buffer-start.
+  (incf (xstream-buffer-start input)
+        (- (xstream-fill-ptr input) 0))
+  (let (n m)
+    ;; when there is something left in the os-buffer, we move it to
+    ;; the start of the buffer.
+    (setf m (- (xstream-os-left-end input) (xstream-os-left-start input)))
+    (unless (zerop m)
+      (replace (xstream-os-buffer input) (xstream-os-buffer input)
+               :start1 0 :end1 m
+               :start2 (xstream-os-left-start input)
+               :end2 (xstream-os-left-end input))
+      ;; then we take care that the buffer is large enough to carry at
+      ;; least 100 bytes (a random number)
+      ;;
+      ;; David: My understanding is that any number of octets large enough
+      ;; to record the longest UTF-8 sequence or UTF-16 sequence is okay,
+      ;; so 100 is plenty for this purpose.
+      (unless (>= (length (xstream-os-buffer input)) 
+		  +default-buffer-size+)
+        (error "You lost")))
+    (setf n
+      (read-octets (xstream-os-buffer input) (xstream-os-stream input)
+                   m (min (1- (length (xstream-os-buffer input)))
+                          (+ m (xstream-speed input)))))
+    (cond ((%= n 0)
+           (setf (xstream-read-ptr input) 0
+                 (xstream-fill-ptr input) n)
+           (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
+           :eof)
+          (t
+           (multiple-value-bind (fnw fnr) 
+               (runes-encoding:decode-sequence
+                (xstream-encoding input) 
+                (xstream-os-buffer input) 0 n
+                (xstream-buffer input) 0 (1- (length (xstream-buffer input)))
+                (= n m))
+             (setf (xstream-os-left-start input) fnr
+                   (xstream-os-left-end input) n
+                   (xstream-read-ptr input) 0
+                   (xstream-fill-ptr input) fnw)
+             (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
+             (read-rune input))))))
+
+;;; constructor
+
+(defun make-xstream (os-stream &key name
+                                    (speed 8192)
+                                    (initial-speed 1)
+                                    (initial-encoding :guess))
+  ;; XXX if initial-speed isn't 1, encoding will me munged up
+  (assert (eql initial-speed 1))
+  (multiple-value-bind (encoding preread)
+      (if (eq initial-encoding :guess)
+          (figure-encoding os-stream)
+          (values initial-encoding nil))
+    (let* ((bufsize (max speed +default-buffer-size+))
+	   (osbuf (make-array bufsize :element-type '(unsigned-byte 8))))
+      (replace osbuf preread)
+      (make-xstream/low
+       :buffer (let ((r (make-array bufsize :element-type 'buffer-byte)))
+                 (setf (elt r 0) #xFFFF)
+                 r)
+       :read-ptr 0
+       :fill-ptr 0
+       :os-buffer osbuf
+       :speed initial-speed
+       :full-speed speed
+       :os-stream os-stream
+       :os-left-start 0
+       :os-left-end (length preread)
+       :encoding encoding
+       :name name))))
+
+(defun make-rod-xstream (string &key name)
+  (unless (typep string 'simple-array)
+    (setf string (coerce string 'simple-string)))
+  ;; XXX encoding is mis-handled by this kind of stream
+  (let ((n (length string)))
+    (let ((buffer (make-array (1+ n) :element-type 'buffer-byte)))
+      (declare (type (simple-array buffer-byte (*)) buffer))
+      ;; copy the rod
+      (do ((i (1- n) (- i 1)))
+          ((< i 0))
+        (declare (type fixnum i))
+        (setf (aref buffer i) (rune-code (%rune string i))))
+      (setf (aref buffer n) +end+)
+      ;;
+      (make-xstream/low :buffer buffer
+                        :read-ptr 0
+                        :fill-ptr n
+                        ;; :os-buffer nil
+                        :speed 1
+                        :os-stream nil
+                        :name name))))
+
+(defmethod figure-encoding ((stream null))
+  (values :utf-8 nil))
+
+(defmethod figure-encoding ((stream stream))
+  (let ((c0 (read-byte stream nil :eof)))
+    (cond ((eq c0 :eof)
+           (values :utf-8 nil))
+          (t
+           (let ((c1 (read-byte stream nil :eof)))
+             (cond ((eq c1 :eof)
+                    (values :utf-8 (list c0)))
+                   (t
+                    (cond ((and (= c0 #xFE) (= c1 #xFF)) (values :utf-16-big-endian nil))
+                          ((and (= c0 #xFF) (= c1 #xFE)) (values :utf-16-little-endian nil))
+                          (t
+                           (values :utf-8 (list c0 c1)))))))))))
+
+;;; misc
+
+(defun close-xstream (input)
+  (xstream/close (xstream-os-stream input)))
+
+(defun set-to-full-speed (xstream)
+  (setf (xstream-speed xstream) (xstream-full-speed xstream)))
+
+;;; controller implementations
+
+(defmethod read-octets (sequence (stream stream) start end)
+  (#+CLISP ext:read-byte-sequence
+   #-CLISP read-sequence
+           sequence stream :start start :end end))
+
+#+cmu
+(defmethod read-octets :around (sequence (stream stream) start end)
+  ;; CMUCL <= 19a on non-SunOS accidentally triggers EFAULT in read(2)
+  ;; if SEQUENCE has been write protected by GC.  Workaround: Touch all pages
+  ;; in SEQUENCE and make sure no GC happens between that and the read(2).
+  (ext::without-gcing
+   (loop for i from start below end
+         do (setf (elt sequence i) (elt sequence i)))
+   (call-next-method)))
+
+(defmethod read-octets (sequence (stream null) start end)
+  (declare (ignore sequence start end))
+  0)
+
+(defmethod xstream/close ((stream stream))
+  (close stream))
+
+(defmethod xstream/close ((stream null))
+  nil)

Added: branches/trunk-reorg/thirdparty/closure-common-2007-10-21/ystream.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/closure-common-2007-10-21/ystream.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,297 @@
+;;; (c) 2005 David Lichteblau <david at lichteblau.com>
+;;; License: Lisp-LGPL (See file COPYING for details).
+;;;
+;;; ystream (for lack of a better name): a rune output "stream"
+
+(in-package :runes)
+
+(defconstant +ystream-bufsize+ 1024)
+
+(defun make-ub8-array (n)
+  (make-array n :element-type '(unsigned-byte 8)))
+
+(defun make-ub16-array (n)
+  (make-array n :element-type '(unsigned-byte 16)))
+
+(defun make-buffer (&key (element-type '(unsigned-byte 8)))
+  (make-array 1
+              :element-type element-type
+              :adjustable t
+              :fill-pointer 0))
+
+(defmacro while (test &body body)
+  `(until (not ,test) , at body))
+
+(defmacro until (test &body body)
+  `(do () (,test) , at body))
+
+;;; ystream
+;;;  +- utf8-ystream
+;;;  |    +- octet-vector-ystream
+;;;  |    \- %stream-ystream
+;;;  |        +- octet-stream-ystream
+;;;  |        \- character-stream-ystream/utf8
+;;;  |            \- string-ystream/utf8
+;;;  +- rod-ystream
+;;;  \-- character-stream-ystream
+
+(defstruct ystream
+  (column 0 :type integer)
+  (in-ptr 0 :type fixnum)
+  (in-buffer (make-rod +ystream-bufsize+) :type simple-rod))
+
+(defstruct (utf8-ystream
+	    (:include ystream)
+	    (:conc-name "YSTREAM-"))
+  (out-buffer (make-ub8-array (* 6 +ystream-bufsize+))
+	      :type (simple-array (unsigned-byte 8) (*))))
+
+(defstruct (%stream-ystream (:include utf8-ystream) (:conc-name "YSTREAM-"))
+  (os-stream nil))
+
+(definline write-rune (rune ystream)
+  (let ((in (ystream-in-buffer ystream)))
+    (when (eql (ystream-in-ptr ystream) (length in))
+      (flush-ystream ystream)
+      (setf in (ystream-in-buffer ystream)))
+    (setf (elt in (ystream-in-ptr ystream)) rune)
+    (incf (ystream-in-ptr ystream))
+    (setf (ystream-column ystream)
+	  (if (eql rune #/U+0010) 0 (1+ (ystream-column ystream))))
+    rune))
+
+(defmethod close-ystream :before ((ystream ystream))
+  (flush-ystream ystream))
+
+
+;;;; UTF8-YSTREAM (abstract)
+
+(defmethod close-ystream ((ystream %stream-ystream))
+  (ystream-os-stream ystream))
+
+(defgeneric ystream-device-write (ystream buf nbytes))
+
+(defmethod flush-ystream ((ystream utf8-ystream))
+  (let ((ptr (ystream-in-ptr ystream)))
+    (when (plusp ptr)
+      (let* ((in (ystream-in-buffer ystream))
+	     (out (ystream-out-buffer ystream))
+	     (surrogatep (<= #xD800 (rune-code (elt in (1- ptr))) #xDBFF))
+	     n)
+	(when surrogatep
+	  (decf ptr))
+	(when (plusp ptr)
+	  (setf n (runes-to-utf8 out in ptr))
+	  (ystream-device-write ystream out n)
+	  (cond
+	    (surrogatep
+	      (setf (elt in 0) (elt in (1- ptr)))
+	      (setf (ystream-in-ptr ystream) 1))
+	    (t
+	      (setf (ystream-in-ptr ystream) 0))))))))
+
+(defun write-rod (rod sink)
+  (loop for rune across rod do (write-rune rune sink)))
+
+(defun fast-push (new-element vector)
+  (vector-push-extend new-element vector (max 1 (array-dimension vector 0))))
+
+(macrolet ((define-utf8-writer (name (byte &rest aux) result &body body)
+	     `(defun ,name (out in n)
+		(let ((high-surrogate nil)
+		      , at aux)
+		  (labels
+		      ((write0 (,byte)
+			 , at body)
+		       (write1 (r)
+			 (cond
+			   ((<= #x00000000 r #x0000007F) 
+			     (write0 r))
+			   ((<= #x00000080 r #x000007FF)
+			     (write0 (logior #b11000000 (ldb (byte 5 6) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 0) r))))
+			   ((<= #x00000800 r #x0000FFFF)
+			     (write0 (logior #b11100000 (ldb (byte 4 12) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 6) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 0) r))))
+			   ((<= #x00010000 r #x001FFFFF)
+			     (write0 (logior #b11110000 (ldb (byte 3 18) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 12) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 6) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 0) r))))
+			   ((<= #x00200000 r #x03FFFFFF)
+			     (write0 (logior #b11111000 (ldb (byte 2 24) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 18) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 12) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 6) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 0) r))))
+			   ((<= #x04000000 r #x7FFFFFFF)
+			     (write0 (logior #b11111100 (ldb (byte 1 30) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 24) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 18) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 12) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 6) r)))
+			     (write0 (logior #b10000000 (ldb (byte 6 0) r))))))
+		       (write2 (r)
+			 (cond
+			   ((<= #xD800 r #xDBFF)
+			     (setf high-surrogate r))
+			   ((<= #xDC00 r #xDFFF)
+			     (let ((q (logior (ash (- high-surrogate #xD7C0) 10)
+					      (- r #xDC00))))
+			       (write1 q))
+			     (setf high-surrogate nil))
+			   (t
+			     (write1 r)))))
+		    (dotimes (j n)
+		      (write2 (rune-code (elt in j)))))
+		  ,result))))
+  (define-utf8-writer runes-to-utf8 (x (i 0))
+    i
+    (setf (elt out i) x)
+    (incf i))
+  (define-utf8-writer runes-to-utf8/adjustable-string (x)
+    nil
+    (fast-push (code-char x) out)))
+
+
+;;;; ROD-YSTREAM
+
+(defstruct (rod-ystream (:include ystream)))
+
+(defmethod flush-ystream ((ystream rod-ystream))
+  (let* ((old (ystream-in-buffer ystream))
+	 (new (make-rod (* 2 (length old)))))
+    (replace new old)
+    (setf (ystream-in-buffer ystream) new)))
+
+(defmethod close-ystream ((ystream rod-ystream))
+  (subseq (ystream-in-buffer ystream) 0 (ystream-in-ptr ystream)))
+
+
+;;;; CHARACTER-STREAM-YSTREAM
+
+#+rune-is-character
+(progn
+  (defstruct (character-stream-ystream
+	      (:constructor make-character-stream-ystream (target-stream))
+	      (:include ystream)
+	      (:conc-name "YSTREAM-"))
+    (target-stream nil))
+
+  (defmethod flush-ystream ((ystream character-stream-ystream))
+    (write-string (ystream-in-buffer ystream)
+		  (ystream-target-stream ystream)
+		  :end (ystream-in-ptr ystream))
+    (setf (ystream-in-ptr ystream) 0))
+
+  (defmethod close-ystream ((ystream character-stream-ystream))
+    (ystream-target-stream ystream)))
+
+
+;;;; OCTET-VECTOR-YSTREAM
+
+(defstruct (octet-vector-ystream
+	    (:include utf8-ystream)
+	    (:conc-name "YSTREAM-"))
+  (result (make-buffer)))
+
+(defmethod ystream-device-write ((ystream octet-vector-ystream) buf nbytes)
+  (let* ((result (ystream-result ystream))
+	 (start (length result))
+	 (size (array-dimension result 0)))
+    (while (> (+ start nbytes) size)
+      (setf size (* 2 size)))
+    (adjust-array result size :fill-pointer (+ start nbytes))
+    (replace result buf :start1 start :end2 nbytes)))
+
+(defmethod close-ystream ((ystream octet-vector-ystream))
+  (ystream-result ystream))
+
+
+;;;; OCTET-STREAM-YSTREAM
+
+(defstruct (octet-stream-ystream
+	    (:include %stream-ystream)
+	    (:constructor make-octet-stream-ystream (os-stream))
+	    (:conc-name "YSTREAM-")))
+
+(defmethod ystream-device-write ((ystream octet-stream-ystream) buf nbytes)
+  (write-sequence buf (ystream-os-stream ystream) :end nbytes))
+
+
+;;;; CHARACTER-STREAM-YSTREAM/UTF8
+
+;; #+rune-is-integer
+(progn
+  (defstruct (character-stream-ystream/utf8
+	      (:constructor make-character-stream-ystream/utf8 (os-stream))
+	      (:include %stream-ystream)
+	      (:conc-name "YSTREAM-")))
+
+  (defmethod ystream-device-write
+      ((ystream character-stream-ystream/utf8) buf nbytes)
+    (declare (type (simple-array (unsigned-byte 8) (*)) buf))
+    (let ((out (ystream-os-stream ystream)))
+      (dotimes (x nbytes)
+	(write-char (code-char (elt buf x)) out)))))
+
+
+;;;; STRING-YSTREAM/UTF8
+
+;; #+rune-is-integer
+(progn
+  (defstruct (string-ystream/utf8
+	      (:include character-stream-ystream/utf8
+			(os-stream (make-string-output-stream)))
+	      (:conc-name "YSTREAM-")))
+
+  (defmethod close-ystream ((ystream string-ystream/utf8))
+    (get-output-stream-string (ystream-os-stream ystream))))
+
+
+;;;; helper functions
+
+(defun rod-to-utf8-string (rod)
+  (let ((out (make-buffer :element-type 'character)))
+    (runes-to-utf8/adjustable-string out rod (length rod))
+    out))
+
+(defun utf8-string-to-rod (str)
+  (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
+         (buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
+         (n (runes-encoding:decode-sequence
+	     :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
+         (result (make-array n :element-type 'rune)))
+    (map-into result #'code-rune buffer)
+    result))
+
+(defclass octet-input-stream
+    (trivial-gray-stream-mixin fundamental-binary-input-stream)
+    ((octets :initarg :octets)
+     (pos :initform 0)))
+
+(defmethod close ((stream octet-input-stream) &key abort)
+  (declare (ignore abort))
+  (open-stream-p stream))
+
+(defmethod stream-read-byte ((stream octet-input-stream))
+  (with-slots (octets pos) stream
+    (if (>= pos (length octets))
+        :eof
+        (prog1
+            (elt octets pos)
+          (incf pos)))))
+
+(defmethod stream-read-sequence
+    ((stream octet-input-stream) sequence start end &key &allow-other-keys)
+  (with-slots (octets pos) stream
+    (let* ((length (min (- end start) (- (length octets) pos)))
+           (end1 (+ start length))
+           (end2 (+ pos length)))
+      (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2)
+      (setf pos end2)
+      end1)))
+
+(defun make-octet-input-stream (octets)
+  (make-instance 'octet-input-stream :octets octets))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/COPYING
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/COPYING	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,526 @@
+Closure XML -- a Common Lisp XML parser
+
+Copyright (c) 1999 by Gilbert Baumann
+Copyright (c) 2003 by Henrik Motakef
+Copyright (c) 2004 knowledgeTools Int. GmbH
+Copyright (c) 2004,2005 David Lichteblau
+
+Preamble to the Gnu Lesser General Public License
+
+The concept of the GNU Lesser General Public License version 2.1
+("LGPL") has been adopted to govern the use and distribution of
+above-mentioned application. However, the LGPL uses terminology that is
+more appropriate for a program written in C than one written in
+Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if
+certain clarifications are made. This document details those
+clarifications. Accordingly, the license for the open-source Lisp
+applications consists of this document plus the LGPL. Wherever there is
+a conflict between this document and the LGPL, this document takes
+precedence over the LGPL.
+
+A "Library" in Lisp is a collection of Lisp functions, data and foreign
+modules. The form of the Library can be Lisp source code (for processing
+by an interpreter) or object code (usually the result of compilation of
+source code or built with some other mechanisms). Foreign modules are
+object code in a form that can be linked into a Lisp executable. When we
+speak of functions we do so in the most general way to include, in
+addition, methods and unnamed functions. Lisp "data" is also a general
+term that includes the data structures resulting from defining Lisp
+classes. A Lisp application may include the same set of Lisp objects as
+does a Library, but this does not mean that the application is
+necessarily a "work based on the Library" it contains.
+
+The Library consists of everything in the distribution file set before
+any modifications are made to the files. If any of the functions or
+classes in the Library are redefined in other files, then those
+redefinitions ARE considered a work based on the Library. If additional
+methods are added to generic functions in the Library, those additional
+methods are NOT considered a work based on the Library. If Library
+classes are subclassed, these subclasses are NOT considered a work based
+on the Library. If the Library is modified to explicitly call other
+functions that are neither part of Lisp itself nor an available add-on
+module to Lisp, then the functions called by the modified Library ARE
+considered a work based on the Library. The goal is to ensure that the
+Library will compile and run without getting undefined function errors.
+
+It is permitted to add proprietary source code to the Library, but it
+must be done in a way such that the Library will still run without that
+proprietary code present. Section 5 of the LGPL distinguishes between
+the case of a library being dynamically linked at runtime and one being
+statically linked at build time. Section 5 of the LGPL states that the
+former results in an executable that is a "work that uses the Library."
+Section 5 of the LGPL states that the latter results in one that is a
+"derivative of the Library", which is therefore covered by the
+LGPL. Since Lisp only offers one choice, which is to link the Library
+into an executable at build time, we declare that, for the purpose
+applying the LGPL to the Library, an executable that results from
+linking a "work that uses the Library" with the Library is considered a
+"work that uses the Library" and is therefore NOT covered by the LGPL.
+
+Because of this declaration, section 6 of LGPL is not applicable to the
+Library. However, in connection with each distribution of this
+executable, you must also deliver, in accordance with the terms and
+conditions of the LGPL, the source code of Library (or your derivative
+thereof) that is incorporated into this executable.
+
+End of Document
+------------------------------------------------------------------------
+		  GNU LESSER GENERAL PUBLIC LICENSE
+		       Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+  This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it.  You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+  When we speak of free software, we are referring to freedom of use,
+not price.  Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+  To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights.  These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+  For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you.  You must make sure that they, too, receive or can get the source
+code.  If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it.  And you must show them these terms so they know their rights.
+
+  We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+  To protect each distributor, we want to make it very clear that
+there is no warranty for the free library.  Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+

+  Finally, software patents pose a constant threat to the existence of
+any free program.  We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder.  Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+  Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License.  This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License.  We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+  When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library.  The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom.  The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+  We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License.  It also provides other free software developers Less
+of an advantage over competing non-free programs.  These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries.  However, the Lesser license provides advantages in certain
+special circumstances.
+
+  For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard.  To achieve this, non-free programs must be
+allowed to use the library.  A more frequent case is that a free
+library does the same job as widely used non-free libraries.  In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+  In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software.  For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+  Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.  Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library".  The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+

+		  GNU LESSER GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+  A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+  The "Library", below, refers to any such software library or work
+which has been distributed under these terms.  A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language.  (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+  "Source code" for a work means the preferred form of the work for
+making modifications to it.  For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+  Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it).  Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+  
+  1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+  You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+

+  2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+
+    b) You must cause the files modified to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    c) You must cause the whole of the work to be licensed at no
+    charge to all third parties under the terms of this License.
+
+    d) If a facility in the modified Library refers to a function or a
+    table of data to be supplied by an application program that uses
+    the facility, other than as an argument passed when the facility
+    is invoked, then you must make a good faith effort to ensure that,
+    in the event an application does not supply such function or
+    table, the facility still operates, and performs whatever part of
+    its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has
+    a purpose that is entirely well-defined independent of the
+    application.  Therefore, Subsection 2d requires that any
+    application-supplied function or table used by this function must
+    be optional: if the application does not supply it, the square
+    root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library.  To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License.  (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.)  Do not make any other change in
+these notices.
+

+  Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+  This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+  4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+  If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library".  Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+  However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library".  The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+  When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library.  The
+threshold for this to be true is not precisely defined by law.
+
+  If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work.  (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+  Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+

+  6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+  You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License.  You must supply a copy of this License.  If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License.  Also, you must do one
+of these things:
+
+    a) Accompany the work with the complete corresponding
+    machine-readable source code for the Library including whatever
+    changes were used in the work (which must be distributed under
+    Sections 1 and 2 above); and, if the work is an executable linked
+    with the Library, with the complete machine-readable "work that
+    uses the Library", as object code and/or source code, so that the
+    user can modify the Library and then relink to produce a modified
+    executable containing the modified Library.  (It is understood
+    that the user who changes the contents of definitions files in the
+    Library will not necessarily be able to recompile the application
+    to use the modified definitions.)
+
+    b) Use a suitable shared library mechanism for linking with the
+    Library.  A suitable mechanism is one that (1) uses at run time a
+    copy of the library already present on the user's computer system,
+    rather than copying library functions into the executable, and (2)
+    will operate properly with a modified version of the library, if
+    the user installs one, as long as the modified version is
+    interface-compatible with the version that the work was made with.
+
+    c) Accompany the work with a written offer, valid for at
+    least three years, to give the same user the materials
+    specified in Subsection 6a, above, for a charge no more
+    than the cost of performing this distribution.
+
+    d) If distribution of the work is made by offering access to copy
+    from a designated place, offer equivalent access to copy the above
+    specified materials from the same place.
+
+    e) Verify that the user has already received a copy of these
+    materials or that you have already sent this user a copy.
+
+  For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it.  However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+  It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system.  Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+

+  7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work
+    based on the Library, uncombined with any other library
+    facilities.  This must be distributed under the terms of the
+    Sections above.
+
+    b) Give prominent notice with the combined library of the fact
+    that part of it is a work based on the Library, and explaining
+    where to find the accompanying uncombined form of the same work.
+
+  8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License.  Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License.  However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+  9. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Library or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+  10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+

+  11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded.  In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+  13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation.  If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+

+  14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission.  For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this.  Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+			    NO WARRANTY
+
+  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+


Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/DOMTEST
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/DOMTEST	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,840 @@
+
+#P"/home/david/2001/DOM-Test-Suite/tests/level1/core/" 
+0/806 attrcreatedocumentfragment.xml
+1/806 attrcreatetextnode.xml
+2/806 attrcreatetextnode2.xml
+3/806 attrdefaultvalue.xml
+4/806 attreffectivevalue.xml
+5/806 attrentityreplacement.xml
+6/806 attrname.xml
+7/806 attrnextsiblingnull.xml
+8/806 attrnotspecifiedvalue.xml
+9/806 attrparentnodenull.xml
+10/806 attrprevioussiblingnull.xml
+11/806 attrsetvaluenomodificationallowederr.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+12/806 attrsetvaluenomodificationallowederrEE.xml
+13/806 attrspecifiedvalue.xml
+14/806 attrspecifiedvaluechanged.xml
+15/806 attrspecifiedvalueremove.xml
+16/806 cdatasectiongetdata.xml
+implementationAttribute coalescing not supported, skipping test
+17/806 cdatasectionnormalize.xml
+18/806 characterdataappenddata.xml
+19/806 characterdataappenddatagetdata.xml
+20/806 characterdataappenddatanomodificationallowederr.xml
+21/806 characterdataappenddatanomodificationallowederrEE.xml
+22/806 characterdatadeletedatabegining.xml
+23/806 characterdatadeletedataend.xml
+24/806 characterdatadeletedataexceedslength.xml
+25/806 characterdatadeletedatagetlengthanddata.xml
+26/806 characterdatadeletedatamiddle.xml
+27/806 characterdatadeletedatanomodificationallowederrEE.xml
+28/806 characterdatagetdata.xml
+29/806 characterdatagetlength.xml
+30/806 characterdataindexsizeerrdeletedatacountnegative.xml
+implementationAttribute signed not supported, skipping test
+31/806 characterdataindexsizeerrdeletedataoffsetgreater.xml
+32/806 characterdataindexsizeerrdeletedataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+33/806 characterdataindexsizeerrinsertdataoffsetgreater.xml
+34/806 characterdataindexsizeerrinsertdataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+35/806 characterdataindexsizeerrreplacedatacountnegative.xml
+implementationAttribute signed not supported, skipping test
+36/806 characterdataindexsizeerrreplacedataoffsetgreater.xml
+37/806 characterdataindexsizeerrreplacedataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+38/806 characterdataindexsizeerrsubstringcountnegative.xml
+implementationAttribute signed not supported, skipping test
+39/806 characterdataindexsizeerrsubstringnegativeoffset.xml
+implementationAttribute signed not supported, skipping test
+40/806 characterdataindexsizeerrsubstringoffsetgreater.xml
+41/806 characterdatainsertdatabeginning.xml
+42/806 characterdatainsertdataend.xml
+43/806 characterdatainsertdatamiddle.xml
+44/806 characterdatainsertdatanomodificationallowederr.xml
+45/806 characterdatainsertdatanomodificationallowederrEE.xml
+46/806 characterdatareplacedatabegining.xml
+47/806 characterdatareplacedataend.xml
+48/806 characterdatareplacedataexceedslengthofarg.xml
+49/806 characterdatareplacedataexceedslengthofdata.xml
+50/806 characterdatareplacedatamiddle.xml
+51/806 characterdatareplacedatanomodificationallowederr.xml
+52/806 characterdatareplacedatanomodificationallowederrEE.xml
+53/806 characterdatasetdatanomodificationallowederr.xml
+54/806 characterdatasetdatanomodificationallowederrEE.xml
+55/806 characterdatasetnodevalue.xml
+56/806 characterdatasubstringexceedsvalue.xml
+57/806 characterdatasubstringvalue.xml
+58/806 commentgetcomment.xml
+59/806 documentcreateattribute.xml
+60/806 documentcreatecdatasection.xml
+61/806 documentcreatecomment.xml
+62/806 documentcreatedocumentfragment.xml
+63/806 documentcreateelement.xml
+64/806 documentcreateelementcasesensitive.xml
+65/806 documentcreateelementdefaultattr.xml
+66/806 documentcreateentityreference.xml
+67/806 documentcreateentityreferenceknown.xml
+68/806 documentcreateprocessinginstruction.xml
+69/806 documentcreatetextnode.xml
+70/806 documentgetdoctype.xml
+71/806 documentgetdoctypenodtd.xml
+72/806 documentgetelementsbytagnamelength.xml
+73/806 documentgetelementsbytagnametotallength.xml
+74/806 documentgetelementsbytagnamevalue.xml
+75/806 documentgetimplementation.xml
+76/806 documentgetrootnode.xml
+77/806 documentinvalidcharacterexceptioncreateattribute.xml
+78/806 documentinvalidcharacterexceptioncreateelement.xml
+79/806 documentinvalidcharacterexceptioncreateentref.xml
+80/806 documentinvalidcharacterexceptioncreateentref1.xml
+81/806 documentinvalidcharacterexceptioncreatepi.xml
+82/806 documentinvalidcharacterexceptioncreatepi1.xml
+83/806 documenttypegetdoctype.xml
+84/806 documenttypegetentities.xml
+85/806 documenttypegetentitieslength.xml
+86/806 documenttypegetentitiestype.xml
+87/806 documenttypegetnotations.xml
+88/806 documenttypegetnotationstype.xml
+89/806 domimplementationfeaturenoversion.xml
+90/806 domimplementationfeaturenull.xml
+implementationAttribute hasNullString not supported, skipping test
+91/806 domimplementationfeaturexml.xml
+92/806 elementaddnewattribute.xml
+93/806 elementassociatedattribute.xml
+94/806 elementchangeattributevalue.xml
+95/806 elementcreatenewattribute.xml
+96/806 elementgetattributenode.xml
+97/806 elementgetattributenodenull.xml
+98/806 elementgetelementempty.xml
+99/806 elementgetelementsbytagname.xml
+100/806 elementgetelementsbytagnameaccessnodelist.xml
+101/806 elementgetelementsbytagnamenomatch.xml
+102/806 elementgetelementsbytagnamespecialvalue.xml
+103/806 elementgettagname.xml
+104/806 elementinuseattributeerr.xml
+105/806 elementinvalidcharacterexception.xml
+106/806 elementnormalize.xml
+107/806 elementnotfounderr.xml
+108/806 elementremoveattribute.xml
+109/806 elementremoveattributeaftercreate.xml
+110/806 elementremoveattributenode.xml
+111/806 elementremoveattributenodenomodificationallowederr.xml
+112/806 elementremoveattributenodenomodificationallowederrEE.xml
+113/806 elementremoveattributenomodificationallowederr.xml
+114/806 elementremoveattributenomodificationallowederrEE.xml
+115/806 elementremoveattributerestoredefaultvalue.xml
+116/806 elementreplaceattributewithself.xml
+117/806 elementreplaceexistingattribute.xml
+118/806 elementreplaceexistingattributegevalue.xml
+119/806 elementretrieveallattributes.xml
+120/806 elementretrieveattrvalue.xml
+121/806 elementretrievetagname.xml
+122/806 elementsetattributenodenomodificationallowederr.xml
+123/806 elementsetattributenodenomodificationallowederrEE.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+124/806 elementsetattributenodenull.xml
+125/806 elementsetattributenomodificationallowederr.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+126/806 elementsetattributenomodificationallowederrEE.xml
+127/806 elementwrongdocumenterr.xml
+128/806 entitygetentityname.xml
+129/806 entitygetpublicid.xml
+130/806 entitygetpublicidnull.xml
+131/806 namednodemapchildnoderange.xml
+132/806 namednodemapgetnameditem.xml
+133/806 namednodemapinuseattributeerr.xml
+134/806 namednodemapnotfounderr.xml
+135/806 namednodemapnumberofnodes.xml
+136/806 namednodemapremovenameditem.xml
+137/806 namednodemapremovenameditemgetvalue.xml
+138/806 namednodemapremovenameditemreturnnodevalue.xml
+139/806 namednodemapreturnattrnode.xml
+140/806 namednodemapreturnfirstitem.xml
+141/806 namednodemapreturnlastitem.xml
+142/806 namednodemapreturnnull.xml
+143/806 namednodemapsetnameditem.xml
+144/806 namednodemapsetnameditemreturnvalue.xml
+145/806 namednodemapsetnameditemthatexists.xml
+146/806 namednodemapsetnameditemwithnewvalue.xml
+147/806 namednodemapwrongdocumenterr.xml
+148/806 nodeappendchild.xml
+149/806 nodeappendchildchildexists.xml
+150/806 nodeappendchilddocfragment.xml
+151/806 nodeappendchildgetnodename.xml
+152/806 nodeappendchildinvalidnodetype.xml
+153/806 nodeappendchildnewchilddiffdocument.xml
+154/806 nodeappendchildnodeancestor.xml
+155/806 nodeappendchildnomodificationallowederr.xml
+156/806 nodeappendchildnomodificationallowederrEE.xml
+157/806 nodeattributenodeattribute.xml
+158/806 nodeattributenodename.xml
+159/806 nodeattributenodetype.xml
+160/806 nodeattributenodevalue.xml
+161/806 nodecdatasectionnodeattribute.xml
+162/806 nodecdatasectionnodename.xml
+163/806 nodecdatasectionnodetype.xml
+implementationAttribute coalescing not supported, skipping test
+164/806 nodecdatasectionnodevalue.xml
+implementationAttribute coalescing not supported, skipping test
+165/806 nodechildnodes.xml
+166/806 nodechildnodesappendchild.xml
+167/806 nodechildnodesempty.xml
+168/806 nodecloneattributescopied.xml
+169/806 nodeclonefalsenocopytext.xml
+170/806 nodeclonegetparentnull.xml
+171/806 nodeclonenodefalse.xml
+172/806 nodeclonenodetrue.xml
+173/806 nodeclonetruecopytext.xml
+174/806 nodecommentnodeattributes.xml
+175/806 nodecommentnodename.xml
+176/806 nodecommentnodetype.xml
+177/806 nodecommentnodevalue.xml
+178/806 nodedocumentfragmentnodename.xml
+179/806 nodedocumentfragmentnodetype.xml
+180/806 nodedocumentfragmentnodevalue.xml
+181/806 nodedocumentnodeattribute.xml
+182/806 nodedocumentnodename.xml
+183/806 nodedocumentnodetype.xml
+184/806 nodedocumentnodevalue.xml
+185/806 nodedocumenttypenodename.xml
+186/806 nodedocumenttypenodetype.xml
+187/806 nodedocumenttypenodevalue.xml
+188/806 nodeelementnodeattributes.xml
+189/806 nodeelementnodename.xml
+190/806 nodeelementnodetype.xml
+191/806 nodeelementnodevalue.xml
+192/806 nodeentitynodeattributes.xml
+193/806 nodeentitynodename.xml
+194/806 nodeentitynodetype.xml
+195/806 nodeentitynodevalue.xml
+196/806 nodeentitysetnodevalue.xml
+197/806 nodeentityreferencenodeattributes.xml
+198/806 nodeentityreferencenodename.xml
+199/806 nodeentityreferencenodetype.xml
+200/806 nodeentityreferencenodevalue.xml
+201/806 nodegetfirstchild.xml
+202/806 nodegetfirstchildnull.xml
+203/806 nodegetlastchild.xml
+204/806 nodegetlastchildnull.xml
+205/806 nodegetnextsibling.xml
+206/806 nodegetnextsiblingnull.xml
+207/806 nodegetownerdocument.xml
+208/806 nodegetownerdocumentnull.xml
+209/806 nodegetprevioussibling.xml
+210/806 nodegetprevioussiblingnull.xml
+211/806 nodehaschildnodes.xml
+212/806 nodehaschildnodesfalse.xml
+213/806 nodeinsertbefore.xml
+214/806 nodeinsertbeforedocfragment.xml
+215/806 nodeinsertbeforeinvalidnodetype.xml
+216/806 nodeinsertbeforenewchilddiffdocument.xml
+217/806 nodeinsertbeforenewchildexists.xml
+218/806 nodeinsertbeforenodeancestor.xml
+219/806 nodeinsertbeforenodename.xml
+220/806 nodeinsertbeforenomodificationallowederr.xml
+221/806 nodeinsertbeforenomodificationallowederrEE.xml
+222/806 nodeinsertbeforerefchildnonexistent.xml
+223/806 nodeinsertbeforerefchildnull.xml
+224/806 nodelistindexequalzero.xml
+225/806 nodelistindexgetlength.xml
+226/806 nodelistindexgetlengthofemptylist.xml
+227/806 nodelistindexnotzero.xml
+228/806 nodelistreturnfirstitem.xml
+229/806 nodelistreturnlastitem.xml
+230/806 nodelisttraverselist.xml
+231/806 nodenotationnodeattributes.xml
+232/806 nodenotationnodename.xml
+233/806 nodenotationnodetype.xml
+234/806 nodenotationnodevalue.xml
+235/806 nodeparentnode.xml
+236/806 nodeparentnodenull.xml
+237/806 nodeprocessinginstructionnodeattributes.xml
+238/806 nodeprocessinginstructionnodename.xml
+239/806 nodeprocessinginstructionnodetype.xml
+240/806 nodeprocessinginstructionnodevalue.xml
+241/806 nodeprocessinginstructionsetnodevalue.xml
+242/806 noderemovechild.xml
+243/806 noderemovechildgetnodename.xml
+244/806 noderemovechildnode.xml
+245/806 noderemovechildnomodificationallowederr.xml
+246/806 noderemovechildnomodificationallowederrEE.xml
+247/806 noderemovechildoldchildnonexistent.xml
+248/806 nodereplacechild.xml
+249/806 nodereplacechildinvalidnodetype.xml
+250/806 nodereplacechildnewchilddiffdocument.xml
+251/806 nodereplacechildnewchildexists.xml
+252/806 nodereplacechildnodeancestor.xml
+253/806 nodereplacechildnodename.xml
+254/806 nodereplacechildnomodificationallowederr.xml
+255/806 nodereplacechildnomodificationallowederrEE.xml
+256/806 nodereplacechildoldchildnonexistent.xml
+257/806 nodesetnodevaluenomodificationallowederr.xml
+258/806 nodesetnodevaluenomodificationallowederrEE.xml
+259/806 nodetextnodeattribute.xml
+260/806 nodetextnodename.xml
+261/806 nodetextnodetype.xml
+262/806 nodetextnodevalue.xml
+263/806 notationgetnotationname.xml
+264/806 notationgetpublicid.xml
+265/806 notationgetpublicidnull.xml
+266/806 notationgetsystemid.xml
+267/806 notationgetsystemidnull.xml
+268/806 processinginstructiongetdata.xml
+269/806 processinginstructiongettarget.xml
+270/806 processinginstructionsetdatanomodificationallowederr.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+271/806 processinginstructionsetdatanomodificationallowederrEE.xml
+272/806 textindexsizeerrnegativeoffset.xml
+implementationAttribute signed not supported, skipping test
+273/806 textindexsizeerroffsetoutofbounds.xml
+274/806 textparseintolistofelements.xml
+275/806 textsplittextfour.xml
+276/806 textsplittextnomodificationallowederr.xml
+277/806 textsplittextnomodificationallowederrEE.xml
+278/806 textsplittextone.xml
+279/806 textsplittextthree.xml
+280/806 textsplittexttwo.xml
+281/806 textwithnomarkup.xml
+282/806 nodevalue01.xml
+283/806 nodevalue02.xml
+284/806 nodevalue03.xml
+285/806 nodevalue04.xml
+286/806 nodevalue05.xml
+287/806 nodevalue06.xml
+288/806 nodevalue07.xml
+289/806 nodevalue08.xml
+290/806 nodevalue09.xml
+291/806 hc_attrcreatedocumentfragment.xml
+292/806 hc_attrcreatetextnode.xml
+293/806 hc_attrcreatetextnode2.xml
+294/806 hc_attreffectivevalue.xml
+295/806 hc_attrname.xml
+296/806 hc_attrnextsiblingnull.xml
+297/806 hc_attrparentnodenull.xml
+298/806 hc_attrprevioussiblingnull.xml
+299/806 hc_attrspecifiedvalue.xml
+300/806 hc_attrspecifiedvaluechanged.xml
+301/806 hc_characterdataappenddata.xml
+302/806 hc_characterdataappenddatagetdata.xml
+303/806 hc_characterdatadeletedatabegining.xml
+304/806 hc_characterdatadeletedataend.xml
+305/806 hc_characterdatadeletedataexceedslength.xml
+306/806 hc_characterdatadeletedatagetlengthanddata.xml
+307/806 hc_characterdatadeletedatamiddle.xml
+308/806 hc_characterdatagetdata.xml
+309/806 hc_characterdatagetlength.xml
+310/806 hc_characterdataindexsizeerrdeletedatacountnegative.xml
+implementationAttribute signed not supported, skipping test
+311/806 hc_characterdataindexsizeerrdeletedataoffsetgreater.xml
+312/806 hc_characterdataindexsizeerrdeletedataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+313/806 hc_characterdataindexsizeerrinsertdataoffsetgreater.xml
+314/806 hc_characterdataindexsizeerrinsertdataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+315/806 hc_characterdataindexsizeerrreplacedatacountnegative.xml
+implementationAttribute signed not supported, skipping test
+316/806 hc_characterdataindexsizeerrreplacedataoffsetgreater.xml
+317/806 hc_characterdataindexsizeerrreplacedataoffsetnegative.xml
+implementationAttribute signed not supported, skipping test
+318/806 hc_characterdataindexsizeerrsubstringcountnegative.xml
+implementationAttribute signed not supported, skipping test
+319/806 hc_characterdataindexsizeerrsubstringnegativeoffset.xml
+implementationAttribute signed not supported, skipping test
+320/806 hc_characterdataindexsizeerrsubstringoffsetgreater.xml
+321/806 hc_characterdatainsertdatabeginning.xml
+322/806 hc_characterdatainsertdataend.xml
+323/806 hc_characterdatainsertdatamiddle.xml
+324/806 hc_characterdatareplacedatabegining.xml
+325/806 hc_characterdatareplacedataend.xml
+326/806 hc_characterdatareplacedataexceedslengthofarg.xml
+327/806 hc_characterdatareplacedataexceedslengthofdata.xml
+328/806 hc_characterdatareplacedatamiddle.xml
+329/806 hc_characterdatasetnodevalue.xml
+330/806 hc_characterdatasubstringexceedsvalue.xml
+331/806 hc_characterdatasubstringvalue.xml
+332/806 hc_commentgetcomment.xml
+333/806 hc_documentcreateattribute.xml
+334/806 hc_documentcreatecomment.xml
+335/806 hc_documentcreatedocumentfragment.xml
+336/806 hc_documentcreateelement.xml
+337/806 hc_documentcreateelementcasesensitive.xml
+338/806 hc_documentcreatetextnode.xml
+339/806 hc_documentgetdoctype.xml
+340/806 hc_documentgetelementsbytagnamelength.xml
+341/806 hc_documentgetelementsbytagnametotallength.xml
+342/806 hc_documentgetelementsbytagnamevalue.xml
+343/806 hc_documentgetimplementation.xml
+344/806 hc_documentgetrootnode.xml
+345/806 hc_documentinvalidcharacterexceptioncreateattribute.xml
+346/806 hc_documentinvalidcharacterexceptioncreateattribute1.xml
+347/806 hc_documentinvalidcharacterexceptioncreateelement.xml
+348/806 hc_documentinvalidcharacterexceptioncreateelement1.xml
+349/806 hc_domimplementationfeaturenoversion.xml
+350/806 hc_domimplementationfeaturenull.xml
+implementationAttribute hasNullString not supported, skipping test
+351/806 hc_domimplementationfeaturexml.xml
+352/806 hc_elementaddnewattribute.xml
+353/806 hc_elementassociatedattribute.xml
+354/806 hc_elementchangeattributevalue.xml
+355/806 hc_elementcreatenewattribute.xml
+356/806 hc_elementgetattributenode.xml
+357/806 hc_elementgetattributenodenull.xml
+358/806 hc_elementgetelementempty.xml
+359/806 hc_elementgetelementsbytagname.xml
+360/806 hc_elementgetelementsbytagnameaccessnodelist.xml
+361/806 hc_elementgetelementsbytagnamenomatch.xml
+362/806 hc_elementgetelementsbytagnamespecialvalue.xml
+363/806 hc_elementgettagname.xml
+364/806 hc_elementinuseattributeerr.xml
+365/806 hc_elementinvalidcharacterexception.xml
+366/806 hc_elementinvalidcharacterexception1.xml
+367/806 hc_elementnormalize.xml
+368/806 hc_elementnotfounderr.xml
+369/806 hc_elementremoveattribute.xml
+370/806 hc_elementremoveattributeaftercreate.xml
+371/806 hc_elementremoveattributenode.xml
+372/806 hc_elementreplaceattributewithself.xml
+373/806 hc_elementreplaceexistingattribute.xml
+374/806 hc_elementreplaceexistingattributegevalue.xml
+375/806 hc_elementretrieveallattributes.xml
+376/806 hc_elementretrieveattrvalue.xml
+377/806 hc_elementretrievetagname.xml
+378/806 hc_elementsetattributenodenull.xml
+379/806 hc_elementwrongdocumenterr.xml
+380/806 hc_entitiesremovenameditem1.xml
+381/806 hc_entitiessetnameditem1.xml
+382/806 hc_namednodemapchildnoderange.xml
+383/806 hc_namednodemapgetnameditem.xml
+384/806 hc_namednodemapinuseattributeerr.xml
+385/806 hc_namednodemapnotfounderr.xml
+386/806 hc_namednodemapnumberofnodes.xml
+387/806 hc_namednodemapremovenameditem.xml
+388/806 hc_namednodemapreturnattrnode.xml
+389/806 hc_namednodemapreturnfirstitem.xml
+390/806 hc_namednodemapreturnlastitem.xml
+391/806 hc_namednodemapreturnnull.xml
+392/806 hc_namednodemapsetnameditem.xml
+393/806 hc_namednodemapsetnameditemreturnvalue.xml
+394/806 hc_namednodemapsetnameditemthatexists.xml
+395/806 hc_namednodemapsetnameditemwithnewvalue.xml
+396/806 hc_namednodemapwrongdocumenterr.xml
+397/806 hc_nodeappendchild.xml
+398/806 hc_nodeappendchildchildexists.xml
+399/806 hc_nodeappendchilddocfragment.xml
+400/806 hc_nodeappendchildgetnodename.xml
+401/806 hc_nodeappendchildinvalidnodetype.xml
+402/806 hc_nodeappendchildnewchilddiffdocument.xml
+403/806 hc_nodeappendchildnodeancestor.xml
+404/806 hc_nodeattributenodeattribute.xml
+405/806 hc_nodeattributenodename.xml
+406/806 hc_nodeattributenodetype.xml
+407/806 hc_nodeattributenodevalue.xml
+408/806 hc_nodechildnodes.xml
+409/806 hc_nodechildnodesappendchild.xml
+410/806 hc_nodechildnodesempty.xml
+411/806 hc_nodecloneattributescopied.xml
+412/806 hc_nodeclonefalsenocopytext.xml
+413/806 hc_nodeclonegetparentnull.xml
+414/806 hc_nodeclonenodefalse.xml
+415/806 hc_nodeclonenodetrue.xml
+416/806 hc_nodeclonetruecopytext.xml
+417/806 hc_nodecommentnodeattributes.xml
+418/806 hc_nodecommentnodename.xml
+419/806 hc_nodecommentnodetype.xml
+420/806 hc_nodecommentnodevalue.xml
+421/806 hc_nodedocumentfragmentnodename.xml
+422/806 hc_nodedocumentfragmentnodetype.xml
+423/806 hc_nodedocumentfragmentnodevalue.xml
+424/806 hc_nodedocumentnodeattribute.xml
+425/806 hc_nodedocumentnodename.xml
+426/806 hc_nodedocumentnodetype.xml
+427/806 hc_nodedocumentnodevalue.xml
+428/806 hc_nodeelementnodeattributes.xml
+429/806 hc_nodeelementnodename.xml
+430/806 hc_nodeelementnodetype.xml
+431/806 hc_nodeelementnodevalue.xml
+432/806 hc_nodegetfirstchild.xml
+433/806 hc_nodegetfirstchildnull.xml
+434/806 hc_nodegetlastchild.xml
+435/806 hc_nodegetlastchildnull.xml
+436/806 hc_nodegetnextsibling.xml
+437/806 hc_nodegetnextsiblingnull.xml
+438/806 hc_nodegetownerdocument.xml
+439/806 hc_nodegetownerdocumentnull.xml
+440/806 hc_nodegetprevioussibling.xml
+441/806 hc_nodegetprevioussiblingnull.xml
+442/806 hc_nodehaschildnodes.xml
+443/806 hc_nodehaschildnodesfalse.xml
+444/806 hc_nodeinsertbefore.xml
+445/806 hc_nodeinsertbeforedocfragment.xml
+446/806 hc_nodeinsertbeforeinvalidnodetype.xml
+447/806 hc_nodeinsertbeforenewchilddiffdocument.xml
+448/806 hc_nodeinsertbeforenewchildexists.xml
+449/806 hc_nodeinsertbeforenodeancestor.xml
+450/806 hc_nodeinsertbeforenodename.xml
+451/806 hc_nodeinsertbeforerefchildnonexistent.xml
+452/806 hc_nodeinsertbeforerefchildnull.xml
+453/806 hc_nodelistindexequalzero.xml
+454/806 hc_nodelistindexgetlength.xml
+455/806 hc_nodelistindexgetlengthofemptylist.xml
+456/806 hc_nodelistindexnotzero.xml
+457/806 hc_nodelistreturnfirstitem.xml
+458/806 hc_nodelistreturnlastitem.xml
+459/806 hc_nodelisttraverselist.xml
+460/806 hc_nodeparentnode.xml
+461/806 hc_nodeparentnodenull.xml
+462/806 hc_noderemovechild.xml
+463/806 hc_noderemovechildgetnodename.xml
+464/806 hc_noderemovechildnode.xml
+465/806 hc_noderemovechildoldchildnonexistent.xml
+466/806 hc_nodereplacechild.xml
+467/806 hc_nodereplacechildinvalidnodetype.xml
+468/806 hc_nodereplacechildnewchilddiffdocument.xml
+469/806 hc_nodereplacechildnodeancestor.xml
+470/806 hc_nodereplacechildnodename.xml
+471/806 hc_nodereplacechildoldchildnonexistent.xml
+472/806 hc_nodetextnodeattribute.xml
+473/806 hc_nodetextnodename.xml
+474/806 hc_nodetextnodetype.xml
+475/806 hc_nodetextnodevalue.xml
+476/806 hc_nodevalue01.xml
+477/806 hc_nodevalue02.xml
+478/806 hc_nodevalue03.xml
+479/806 hc_nodevalue04.xml
+480/806 hc_nodevalue05.xml
+481/806 hc_nodevalue06.xml
+482/806 hc_nodevalue07.xml
+483/806 hc_nodevalue08.xml
+484/806 hc_notationsremovenameditem1.xml
+485/806 hc_notationssetnameditem1.xml
+486/806 hc_textindexsizeerrnegativeoffset.xml
+implementationAttribute signed not supported, skipping test
+487/806 hc_textindexsizeerroffsetoutofbounds.xml
+488/806 hc_textparseintolistofelements.xml
+489/806 hc_textsplittextfour.xml
+490/806 hc_textsplittextone.xml
+491/806 hc_textsplittextthree.xml
+492/806 hc_textsplittexttwo.xml
+493/806 hc_textwithnomarkup.xml
+494/806 hc_attrappendchild1.xml
+495/806 hc_attrappendchild2.xml
+496/806 hc_attrappendchild3.xml
+497/806 hc_attrappendchild4.xml
+498/806 hc_attrappendchild5.xml
+499/806 hc_attrappendchild6.xml
+500/806 hc_attrchildnodes1.xml
+501/806 hc_attrchildnodes2.xml
+502/806 hc_attrclonenode1.xml
+503/806 hc_attrfirstchild.xml
+504/806 hc_attrgetvalue1.xml
+505/806 hc_attrgetvalue2.xml
+506/806 hc_attrhaschildnodes.xml
+507/806 hc_attrinsertbefore1.xml
+508/806 hc_attrinsertbefore2.xml
+509/806 hc_attrinsertbefore3.xml
+510/806 hc_attrinsertbefore4.xml
+511/806 hc_attrinsertbefore5.xml
+512/806 hc_attrinsertbefore6.xml
+513/806 hc_attrinsertbefore7.xml
+514/806 hc_attrlastchild.xml
+515/806 hc_attrnormalize.xml
+516/806 hc_attrremovechild1.xml
+517/806 hc_attrremovechild2.xml
+518/806 hc_attrreplacechild1.xml
+519/806 hc_attrreplacechild2.xml
+520/806 hc_attrsetvalue1.xml
+521/806 hc_attrsetvalue2.xml
+522/806 attrremovechild1.xml
+523/806 attrreplacechild1.xml
+
+#P"/home/david/2001/DOM-Test-Suite/tests/level2/core/" 
+524/806 attrgetownerelement01.xml
+525/806 attrgetownerelement02.xml
+526/806 attrgetownerelement03.xml
+527/806 attrgetownerelement04.xml
+528/806 attrgetownerelement05.xml
+529/806 createAttributeNS01.xml
+530/806 createAttributeNS02.xml
+531/806 createAttributeNS03.xml
+532/806 createAttributeNS04.xml
+533/806 createAttributeNS05.xml
+534/806 createAttributeNS06.xml
+535/806 createDocument01.xml
+536/806 createDocument02.xml
+537/806 createDocument03.xml
+538/806 createDocument04.xml
+539/806 createDocument05.xml
+540/806 createDocument06.xml
+541/806 createDocument07.xml
+542/806 createDocument08.xml
+543/806 createDocumentType01.xml
+544/806 createDocumentType02.xml
+545/806 createDocumentType03.xml
+546/806 createDocumentType04.xml
+547/806 createElementNS01.xml
+548/806 createElementNS02.xml
+549/806 createElementNS03.xml
+550/806 createElementNS04.xml
+551/806 createElementNS05.xml
+552/806 documentcreateattributeNS01.xml
+553/806 documentcreateattributeNS02.xml
+554/806 documentcreateattributeNS03.xml
+555/806 documentcreateattributeNS04.xml
+556/806 documentcreateattributeNS05.xml
+557/806 documentcreateattributeNS06.xml
+558/806 documentcreateattributeNS07.xml
+559/806 documentcreateelementNS01.xml
+560/806 documentcreateelementNS02.xml
+561/806 documentcreateelementNS05.xml
+562/806 documentcreateelementNS06.xml
+563/806 documentgetelementbyid01.xml
+564/806 documentgetelementsbytagnameNS01.xml
+565/806 documentgetelementsbytagnameNS02.xml
+566/806 documentgetelementsbytagnameNS03.xml
+567/806 documentgetelementsbytagnameNS04.xml
+568/806 documentgetelementsbytagnameNS05.xml
+569/806 documentimportnode01.xml
+570/806 documentimportnode02.xml
+571/806 documentimportnode03.xml
+572/806 documentimportnode04.xml
+573/806 documentimportnode05.xml
+574/806 documentimportnode06.xml
+575/806 documentimportnode07.xml
+576/806 documentimportnode08.xml
+577/806 documentimportnode09.xml
+578/806 documentimportnode10.xml
+579/806 documentimportnode11.xml
+580/806 documentimportnode12.xml
+581/806 documentimportnode13.xml
+582/806 documentimportnode14.xml
+583/806 documentimportnode15.xml
+584/806 documentimportnode17.xml
+585/806 documentimportnode18.xml
+586/806 documentimportnode19.xml
+587/806 documentimportnode20.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+588/806 documentimportnode21.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+589/806 documentimportnode22.xml
+590/806 documenttypeinternalSubset01.xml
+591/806 documenttypepublicid01.xml
+592/806 documenttypesystemid01.xml
+593/806 domimplementationcreatedocument03.xml
+594/806 domimplementationcreatedocument04.xml
+595/806 domimplementationcreatedocument05.xml
+596/806 domimplementationcreatedocument07.xml
+597/806 domimplementationcreatedocumenttype01.xml
+598/806 domimplementationcreatedocumenttype02.xml
+599/806 domimplementationcreatedocumenttype04.xml
+600/806 domimplementationfeaturecore.xml
+601/806 domimplementationfeaturexmlversion2.xml
+602/806 domimplementationhasfeature01.xml
+603/806 domimplementationhasfeature02.xml
+604/806 elementgetattributenodens01.xml
+605/806 elementgetattributenodens02.xml
+606/806 elementgetattributenodens03.xml
+607/806 elementgetattributens02.xml
+608/806 elementgetelementsbytagnamens02.xml
+609/806 elementgetelementsbytagnamens04.xml
+610/806 elementgetelementsbytagnamens05.xml
+611/806 elementhasattribute01.xml
+612/806 elementhasattribute02.xml
+613/806 elementhasattribute03.xml
+614/806 elementhasattribute04.xml
+615/806 elementhasattributens01.xml
+616/806 elementhasattributens02.xml
+617/806 elementhasattributens03.xml
+618/806 elementremoveattributens01.xml
+619/806 elementsetattributenodens01.xml
+620/806 elementsetattributenodens02.xml
+621/806 elementsetattributenodens03.xml
+622/806 elementsetattributenodens04.xml
+623/806 elementsetattributenodens05.xml
+624/806 elementsetattributenodens06.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+625/806 elementsetattributens01.xml
+626/806 elementsetattributens02.xml
+627/806 elementsetattributens03.xml
+628/806 elementsetattributens04.xml
+629/806 elementsetattributens05.xml
+630/806 elementsetattributens08.xml
+631/806 elementsetattributensurinull.xml
+632/806 getAttributeNS01.xml
+633/806 getAttributeNS02.xml
+634/806 getAttributeNS03.xml
+635/806 getAttributeNS04.xml
+636/806 getAttributeNS05.xml
+637/806 getAttributeNodeNS01.xml
+638/806 getAttributeNodeNS02.xml
+639/806 getElementById01.xml
+640/806 getElementById02.xml
+641/806 getElementsByTagNameNS01.xml
+642/806 getElementsByTagNameNS02.xml
+643/806 getElementsByTagNameNS03.xml
+644/806 getElementsByTagNameNS04.xml
+645/806 getElementsByTagNameNS05.xml
+646/806 getElementsByTagNameNS06.xml
+647/806 getElementsByTagNameNS07.xml
+648/806 getElementsByTagNameNS08.xml
+649/806 getElementsByTagNameNS09.xml
+650/806 getElementsByTagNameNS10.xml
+651/806 getElementsByTagNameNS11.xml
+652/806 getElementsByTagNameNS12.xml
+653/806 getElementsByTagNameNS13.xml
+654/806 getElementsByTagNameNS14.xml
+655/806 getNamedItemNS01.xml
+656/806 getNamedItemNS02.xml
+657/806 getNamedItemNS03.xml
+658/806 getNamedItemNS04.xml
+659/806 hasAttribute01.xml
+660/806 hasAttribute02.xml
+661/806 hasAttribute03.xml
+662/806 hasAttribute04.xml
+663/806 hasAttributeNS01.xml
+664/806 hasAttributeNS02.xml
+665/806 hasAttributeNS03.xml
+666/806 hasAttributeNS04.xml
+667/806 hasAttributeNS05.xml
+668/806 hasAttributes01.xml
+669/806 hasAttributes02.xml
+670/806 hc_entitiesremovenameditemns1.xml
+671/806 hc_entitiessetnameditemns1.xml
+672/806 hc_namednodemapinvalidtype1.xml
+673/806 hc_nodedocumentfragmentnormalize1.xml
+674/806 hc_nodedocumentfragmentnormalize2.xml
+675/806 hc_notationsremovenameditemns1.xml
+676/806 hc_notationssetnameditemns1.xml
+677/806 importNode01.xml
+678/806 importNode02.xml
+679/806 importNode03.xml
+680/806 importNode04.xml
+681/806 importNode05.xml
+682/806 importNode06.xml
+683/806 importNode07.xml
+684/806 importNode08.xml
+685/806 importNode09.xml
+686/806 importNode10.xml
+687/806 importNode11.xml
+688/806 importNode12.xml
+689/806 importNode13.xml
+690/806 importNode14.xml
+691/806 importNode15.xml
+692/806 importNode16.xml
+693/806 importNode17.xml
+694/806 internalSubset01.xml
+695/806 isSupported01.xml
+696/806 isSupported02.xml
+697/806 isSupported04.xml
+698/806 isSupported05.xml
+699/806 isSupported06.xml
+700/806 isSupported07.xml
+701/806 isSupported09.xml
+702/806 isSupported10.xml
+703/806 isSupported11.xml
+704/806 isSupported12.xml
+705/806 isSupported13.xml
+706/806 isSupported14.xml
+707/806 localName01.xml
+708/806 localName02.xml
+709/806 localName03.xml
+710/806 localName04.xml
+711/806 namednodemapgetnameditemns01.xml
+712/806 namednodemapgetnameditemns02.xml
+713/806 namednodemapgetnameditemns03.xml
+714/806 namednodemapgetnameditemns04.xml
+715/806 namednodemapgetnameditemns05.xml
+716/806 namednodemapgetnameditemns06.xml
+717/806 namednodemapremovenameditemns01.xml
+718/806 namednodemapremovenameditemns02.xml
+719/806 namednodemapremovenameditemns03.xml
+720/806 namednodemapremovenameditemns04.xml
+721/806 namednodemapremovenameditemns05.xml
+722/806 namednodemapremovenameditemns06.xml
+723/806 namednodemapremovenameditemns07.xml
+724/806 namednodemapremovenameditemns08.xml
+725/806 namednodemapremovenameditemns09.xml
+726/806 namednodemapsetnameditemns01.xml
+727/806 namednodemapsetnameditemns02.xml
+728/806 namednodemapsetnameditemns03.xml
+729/806 namednodemapsetnameditemns04.xml
+730/806 namednodemapsetnameditemns05.xml
+731/806 namednodemapsetnameditemns06.xml
+732/806 namednodemapsetnameditemns07.xml
+733/806 namednodemapsetnameditemns08.xml
+734/806 namednodemapsetnameditemns09.xml
+735/806 namednodemapsetnameditemns10.xml
+736/806 namednodemapsetnameditemns11.xml
+737/806 namespaceURI01.xml
+738/806 namespaceURI02.xml
+739/806 namespaceURI03.xml
+740/806 namespaceURI04.xml
+741/806 nodegetlocalname03.xml
+742/806 nodegetnamespaceuri03.xml
+743/806 nodegetownerdocument01.xml
+744/806 nodegetownerdocument02.xml
+745/806 nodegetprefix03.xml
+746/806 nodehasattributes01.xml
+747/806 nodehasattributes02.xml
+748/806 nodehasattributes03.xml
+749/806 nodehasattributes04.xml
+750/806 nodeissupported01.xml
+751/806 nodeissupported02.xml
+752/806 nodeissupported03.xml
+753/806 nodeissupported04.xml
+754/806 nodeissupported05.xml
+755/806 nodenormalize01.xml
+756/806 nodesetprefix01.xml
+757/806 nodesetprefix02.xml
+758/806 nodesetprefix03.xml
+759/806 nodesetprefix04.xml
+760/806 nodesetprefix05.xml
+761/806 nodesetprefix06.xml
+762/806 nodesetprefix07.xml
+763/806 nodesetprefix08.xml
+764/806 nodesetprefix09.xml
+765/806 normalize01.xml
+766/806 ownerDocument01.xml
+767/806 ownerElement01.xml
+768/806 ownerElement02.xml
+769/806 prefix01.xml
+770/806 prefix02.xml
+771/806 prefix03.xml
+772/806 prefix04.xml
+773/806 prefix05.xml
+774/806 prefix06.xml
+775/806 prefix07.xml
+776/806 prefix08.xml
+777/806 prefix09.xml
+778/806 prefix10.xml
+779/806 prefix11.xml
+780/806 publicId01.xml
+781/806 removeAttributeNS01.xml
+782/806 removeAttributeNS02.xml
+783/806 removeNamedItemNS01.xml
+784/806 removeNamedItemNS02.xml
+785/806 removeNamedItemNS03.xml
+786/806 setAttributeNS01.xml
+787/806 setAttributeNS02.xml
+788/806 setAttributeNS03.xml
+789/806 setAttributeNS04.xml
+790/806 setAttributeNS05.xml
+791/806 setAttributeNS06.xml
+792/806 setAttributeNS07.xml
+793/806 setAttributeNS09.xml
+794/806 setAttributeNS10.xml
+795/806 setAttributeNodeNS01.xml
+796/806 setAttributeNodeNS02.xml
+implementationAttribute expandEntityReferences not supported, skipping test
+797/806 setAttributeNodeNS03.xml
+798/806 setAttributeNodeNS04.xml
+799/806 setAttributeNodeNS05.xml
+800/806 setNamedItemNS01.xml
+801/806 setNamedItemNS02.xml
+802/806 setNamedItemNS03.xml
+803/806 setNamedItemNS04.xml
+804/806 setNamedItemNS05.xml
+805/806 systemId01.xml
+0/763 tests failed; 43 tests were skipped
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/GNUmakefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/GNUmakefile	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,7 @@
+all:
+	@echo no such target
+	@exit 1
+
+.PHONY: clean
+clean:
+	find . \( -name \*.fasl -o -name \*.x86f -o -name \*.lx64fsl \) -print0 | xargs -0 rm -f

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/OLDNEWS
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/OLDNEWS	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,272 @@
+Changes to Gilbert Baumann's Code
+========================================
+(Stand dieser Liste: patch-190)
+
+base-0
+    Import of Closure's src/xml and src/glisp
+
+
+Build system
+----------------
+patch-14
+    dom-builder.lsp braucht package.lisp
+patch-17
+    xml-parse braucht dom-impl
+patch-18
+    xml-parse braucht encodings
+patch-19
+    xml-parse.lisp needs xml-stream.lisp
+patch-157
+    DOM in eigenes Verzeichnis und System verschoben
+patch-158
+    COPYING auch im DOM
+patch-160
+    tests in eigenes Verzeichnis verschoben
+patch-184
+    commented out most of dep-clisp for now
+patch-185
+    CLISP fixes
+
+
+glisp durch runes ersetzt
+---------------- 
+patch-139 patch-140 patch-141 patch-142 patch-143
+    unbenutzte Funktionen aus glisp entfernt
+    GLISP keine COMMON-LISP-Symbole mehr exportieren lassen
+    glisp defpackage weiter vereinfacht
+patch-148
+    runes.lisp aufgeteilt in runes.lisp und syntax.lisp
+patch-149
+    CHARACTER-basierte Runen-Implementation
+patch-150
+    removed support for oldish gcl
+patch-151
+    removed dep-gcl-2.lisp
+patch-152
+    clarified glisp license as LLGPL as per Gilbert Baumann
+patch-155
+    GLISP in RUNES umbenannt
+patch-156
+    xstream (und encoding) nach runes verschoben
+patch-178
+patch-180
+    really fixed rune-char
+
+
+DOM fixes
+----------------
+patch-3
+    add dom:remove-child, dom:import-node
+patch-6
+    fixed dom:remove-child
+patch-7
+    strings->rods in set-attribute, too
+patch-21
+    dom:item und dom:length fuer NodeList implementiert
+patch-22
+    s/remove-atttribute/remove-attribute
+patch-23
+    dom:remove-attribute-node korrigiert
+patch-24
+    neu: dom:remove-attribute
+patch-25
+    dom:normalize implementiert
+patch-26
+    get-elements-by-tag-name fuer Element implementiert
+patch-32
+    s/data/value/ fuer CHARACTER-DATA
+patch-33
+    Aufruf von Setter-Methoden
+patch-34
+    (setf value) nachgetragen
+patch-35
+    (DOM:NODE-VALUE ATTRIBUTE) korrigiert
+patch-36
+    writer fuer DOM:DATA
+patch-37
+    (setf dom:node-value) implementiert
+patch-43
+    hack: implemented CHILD-NODES for ENTITY-REFERENCE
+patch-44
+    ENTITY-REFERENCE-Kinder als read-only markieren
+patch-45
+    DOM-EXCEPTION implementiert
+patch-46
+    fixed special cases in delete-data and replace-data
+patch-47
+    delete-data: Arraytyp korrigiert
+patch-48
+    DOM:INSERT-DATA implementiert
+patch-49
+    bugfix: replace-data for count != (length arg)
+patch-50
+    patch-46 nachgebessert: offset == length ist OK
+patch-51
+    fixed special cases in dom:substring-data
+patch-52
+    fixed patch-36, my (setf dom:data) implementation was bogus
+patch-55
+    temporary fix: attributes are created with value ""
+patch-58
+    START-DTD, END-DTD, DOCUMENT-TYPE initialisation
+patch-60
+    neu: CLONE-NODE
+patch-65, patch-66
+    verify attribute name syntax in createAttribute
+patch-67
+    more NAME syntax checks: CREATE-ELEMENT, SET-ATTRIBUTE
+patch-68
+    CREATE-ATTRIBUTE: set SPECIFIED to true
+patch-69, patch-70
+    INUSE_ATTRIBUTE_ERR
+patch-71
+    hacked my resolve-entity function to return NIL for undefined entities
+patch-72
+    INVALID_CHARACTER_ERR in create-entity-reference, too
+patch-73
+    Implement no-op methods on (setf node-value) where required...
+patch-74
+    fixed get-elements-by-tag-name not to include the argument itself
+patch-76, patch-77
+    implemented DOM:SPLIT-TEXT
+patch-80
+    noch unfertig: initialisiere dom:enitities richtig, erzeuge Entity-Knoten
+patch-82
+    dom:notations fuellen
+patch-85
+    WRONG_DOCUMENT_ERR auch in set-attribute-node
+patch-86
+    WRONG_DOCUMENT_ERR nicht nur in set-attribute-node, sondern prinzipiell in set-named-item
+patch-91
+    :NOT_FOUND_ERR in remove-named-item
+patch-94
+    can-adopt-p implementiert
+patch-95
+    ENSURE-VALID-INSERTION-REQUEST korrigiert
+patch-96
+    normalize korrigiert: cdata-section nicht beruehren
+patch-98
+    DOCUMENTs have owner NIL
+patch-101
+    (setf dom:data) fuer PI korrigiert
+patch-102
+    NOT_FOUND_ERR in REMOVE-CHILD
+patch-104
+    oops, split-text korrigiert
+patch-106
+    NOT_FOUND_ERROR in removeAttributeNode sucht das Objekt, nicht seinen Namen
+patch-107, patch-113
+    Defaultwert fuer fehlende Attribute ist der leere Rod-String, nicht NIL
+patch-118
+    entity und notation maps sind read-only
+patch-119
+    dom:item liefert NIL bei ungueltigem index
+patch-120, patch-122, patch-124
+    NodeList reimplementiert
+patch-121
+    NAMED-NODE-MAP muss auch auf HIERARCHY_REQUEST_ERR pruefen...
+patch-128
+    ATTRIBUTE hat jetzt Kinder
+patch-129
+    auch Attribute normalisieren
+patch-130
+    (setf dom:value) auf einem Attribut darf ein etwaiges Kinderobjekt nicht wiederverwenden
+patch-131
+    replace-child fuer document-fragment implementiert
+patch-132
+    CAN-ADOPT-P fuer Parent ATTRIBUTE und Kind CDATA-SECTION korrigiert
+patch-133
+    DOCUMENT darf nur jeweils ein ELEMENT- und DOCTYPE-Kind haben
+patch-137
+    neu: map-node-list, do-node-list.  ensure-valid-insertion-request korrigiert
+patch-165
+    ANSI conformance fix in MOVE
+patch-181
+    ignore fill-pointers in MOVE
+
+xml-parse.lisp changes
+----------------
+patch-5
+    (assert (eql initial-speed 1)) in make-xstream
+patch-20
+    added a forward declaration for *namespace-bindings*
+patch-39
+    fix for thread safety in p/document
+patch-41
+    Warnung ueber (nicht) redefinierte Attribute abschalten koennen
+patch-54
+    call sax:comment; create comment nodes
+patch-89
+    public-id und system-id der Entities uebergeben
+patch-100
+    Die XML Deklaration ist keine Processing Instruction.
+patch-146
+    SAX-Aufrufe korrigiert fuer DTD ohne ID; Entitydeklaration mit SYSTEM ID
+patch-166
+    added missing format argument in internal-entity-expansion
+patch-172
+    fixed rod type in appenddata
+patch-174
+    reordered definitions to avoid forward references
+patch-177
+    more SBCL warnings removed
+patch-188
+    new function parse-octets
+(See also: patch-58, patch-80, patch-82)
+
+
+DOM-Builder und SAX-Interface
+----------------
+patch-57
+    Warnungen beseitigt ("undefined variable")
+patch-75
+    fixed PARENT slot initialization and added a rant about the current implementation
+patch-97
+    CDATA sections bauen
+patch-136
+    normalisierte Elemente bauen
+
+(See also: patch-58, patch-80, patch-82, patch-86, patch-118, patch-120)
+
+
+unparse
+----------------
+patch-2
+    export UNPARSE-DOCUMENT
+patch-144
+    Kommentare verstehen (und nicht ausgeben)
+patch-189
+    new function UNPARSE-DOCUMENT-TO-OCTETS
+
+
+Misc.
+----------------
+patch-9
+    print elements with their tag-name
+patch-11
+    print attributes with name and value
+
+patch-138
+    workaround, need to revert this later
+
+patch-10 reverted by patch-12
+patch-114 reverted by patch-115
+patch-63 reverted by patch-134
+patch-4 patch-38 patch-87 patch-90 patch-103 reverted by patch-154
+patch-154 STRING-DOM nicht mehr verwenden.  File ist aber noch da.
+
+
+domtest.cl
+----------------
+patch-27 patch-28 patch-29 patch-30 patch-31 patch-40 patch-42 patch-53
+patch-59 patch-61 patch-62 patch-64 patch-78 patch-79 patch-83 patch-84
+patch-88 patch-92 patch-93 patch-99 patch-105 patch-108 patch-111
+patch-116 patch-117 patch-123 patch-153 patch-182
+    DOM tests
+
+
+xmlconf.cl
+----------------
+patch-13 patch-15 patch-16 patch-147 patch-186
+    Testfunktion fuer XML Conformance Test Suite
+(need to merge this with Gilbert's work)

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/README
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/README	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,29 @@
+
+Closure XML Parser
+
+   An XML parser written in Common Lisp.
+
+   Closure XML was written by Gilbert Baumann (unk6 at
+   rz.uni-karlsruhe.de) as part of the Closure web browser.
+
+   Contributions to the parser by
+     * Henrik Motakef (hmot at henrik-motakef.de)
+     * David Lichteblau (david at lichteblau.com)
+
+   CXML implements a namespace-aware, validating XML 1.0 parser
+   as well as the DOM Level 2 Core interfaces. Two parser interfaces
+   are offered, one SAX-like, the other similar to StAX.
+
+   CXML is licensed under Lisp-LGPL.
+
+   Send bug reports to cxml-devel at common-lisp.net
+   (http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel)
+
+
+Documentation
+
+   Please refer to http://common-lisp.net/project/cxml/ for details.
+
+   The documentation is also available in the doc/ subdirectory of this
+   source distribution, run `make' in that directory to build HTML
+   for the XML sources (requires xsltproc).

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/TIMES
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/TIMES	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,41 @@
+Time required for parsing a simple document (wc: 99621 298859 3267087).
+
+;; CXML with NIL builder
+;; (cxml:parse-file "~/test.xml" nil)
+
+; cpu time (non-gc) 12,940 msec user, 20 msec system
+; cpu time (gc)     0 msec user, 0 msec system
+; cpu time (total)  12,940 msec user, 20 msec system
+; real time  12,991 msec
+; space allocation:
+;  4,184,599 cons cells, 47,682,392 other bytes, 0 static bytes
+
+;; CXML with xmls-compatible builder
+;; (cxml:parse-file "~/test.xml" (cxml-xmls:make-xmls-builder))
+
+; cpu time (non-gc) 14,370 msec user, 20 msec system
+; cpu time (gc)     0 msec user, 0 msec system
+; cpu time (total)  14,370 msec user, 20 msec system
+; real time  14,387 msec
+; space allocation:
+;  8,667,564 cons cells, 47,682,600 other bytes, 0 static bytes
+
+;; For comparison: xmls.lisp
+;; (with-open-file (s "~/test.xml") (xmls:parse s :compress-whitespace nil))
+
+; cpu time (non-gc) 27,440 msec user, 50 msec system
+; cpu time (gc)     860 msec user, 0 msec system
+; cpu time (total)  28,300 msec user, 50 msec system
+; real time  28,813 msec
+; space allocation:
+;  14,821,161 cons cells, 243,886,592 other bytes, 0 static bytes
+
+;; CXML with DOM builder
+;; (cxml:parse-file "~/test.xml" (dom:make-dom-builder))
+
+; cpu time (non-gc) 34,900 msec user, 40 msec system
+; cpu time (gc)     760 msec user, 0 msec system
+; cpu time (total)  35,660 msec user, 40 msec system
+; real time  35,822 msec
+; space allocation:
+;  14,645,503 cons cells, 300,235,640 other bytes, 0 static bytes

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLCONF
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLCONF	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,1834 @@
+xmltest/not-wf/sa/001.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/002.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/003.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/004.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/005.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/006.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/007.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/008.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/009.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/010.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/011.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/012.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/013.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/014.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/015.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/016.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/017.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/018.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/019.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/020.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/021.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/022.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/023.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/024.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/025.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/026.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/027.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/028.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/029.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/030.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/031.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/032.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/033.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/034.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/035.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/036.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/037.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/038.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/039.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/040.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/041.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/042.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/043.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/044.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/045.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/046.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/047.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/048.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/049.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/050.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/051.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/052.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/053.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/054.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/055.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/056.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/057.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/058.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/059.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/060.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/061.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/062.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/063.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/064.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/065.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/066.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/067.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/068.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/069.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/070.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/071.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/072.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/073.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/074.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/075.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/076.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/077.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/078.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/079.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/080.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/081.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/082.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/083.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/084.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/085.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/086.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/087.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/088.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/089.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/090.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/091.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/092.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/093.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/094.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/095.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/096.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/097.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/098.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/099.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/100.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/101.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/102.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/103.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/104.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/105.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/106.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/107.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/108.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/109.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/110.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/111.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/112.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/113.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/114.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/115.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/116.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/117.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/118.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/119.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/120.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/121.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/122.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/123.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/124.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/125.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/126.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/127.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/128.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/129.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/130.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/131.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/132.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/133.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/134.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/135.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/136.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/137.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/138.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/139.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/140.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/141.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/142.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/143.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/144.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/145.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/146.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/147.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/148.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/149.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/150.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/151.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/152.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/153.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/154.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/155.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/156.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/157.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/158.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/159.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/160.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/161.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/162.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/163.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/164.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/165.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/166.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/167.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/168.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/169.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/170.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/171.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/172.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/173.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/174.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/sa/175.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/176.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/177.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/178.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/179.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/180.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/181.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/182.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/183.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/184.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/185.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/sa/186.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/001.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/002.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/003.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/004.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/006.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/007.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/008.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/not-sa/009.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/ext-sa/001.xml [not validating:] not-wf [validating:] invalid
+xmltest/not-wf/ext-sa/002.xml [not validating:] not-wf [validating:] not-wf
+xmltest/not-wf/ext-sa/003.xml [not validating:] not-wf [validating:] not-wf
+xmltest/invalid/002.xml [not validating:] input [validating:] invalid
+xmltest/invalid/005.xml [not validating:] input [validating:] invalid
+xmltest/invalid/006.xml [not validating:] input [validating:] invalid
+xmltest/invalid/not-sa/022.xml [not validating:] input/output [validating:] invalid
+xmltest/valid/sa/001.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/002.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/003.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/004.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/005.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/006.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/007.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/008.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/009.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/010.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/011.xml [not validating:] input/output [validating:] input/output
+valid/sa/012.xml: test applies to parsers without namespace support, skipping
+xmltest/valid/sa/013.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/014.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/015.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/016.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/017.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/018.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/019.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/020.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/021.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/022.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/023.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/024.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/025.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/026.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/027.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/028.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/029.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/030.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/031.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/032.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/033.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/034.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/035.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/036.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/037.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/038.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/039.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/040.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/041.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/042.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/043.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/044.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/045.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/046.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/047.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/048.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/049.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/050.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/051.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/052.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/053.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/054.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/055.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/056.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/057.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/058.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/059.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/060.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/061.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/062.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/063.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/064.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/065.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/066.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/067.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/068.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/069.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/070.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/071.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/072.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/073.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/074.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/075.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/076.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/077.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/078.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/079.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/080.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/081.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/082.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/083.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/084.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/085.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/086.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/087.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/088.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/089.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/090.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/091.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/092.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/093.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/094.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/095.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/096.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/097.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/098.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/099.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/100.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/101.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/102.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/103.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/104.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/105.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/106.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/107.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/108.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/109.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/110.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/111.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/112.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/113.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/114.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/115.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/116.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/117.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/118.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/sa/119.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/001.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/002.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/003.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/004.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/005.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/006.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/007.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/008.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/009.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/010.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/011.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/012.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/013.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/014.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/015.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/016.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/017.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/018.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/019.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/020.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/021.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/023.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/024.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/025.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/026.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/027.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/028.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/029.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/030.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/not-sa/031.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/001.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/002.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/003.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/004.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/005.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/006.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/007.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/008.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/009.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/011.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/012.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/013.xml [not validating:] input/output [validating:] input/output
+xmltest/valid/ext-sa/014.xml [not validating:] input/output [validating:] input/output
+japanese/pr-xml-little-endian.xml [not validating:] input [validating:] input
+japanese/pr-xml-utf-16.xml [not validating:] input [validating:] input
+japanese/pr-xml-utf-8.xml [not validating:] input [validating:] input
+japanese/weekly-little-endian.xml [not validating:] input [validating:] input
+japanese/weekly-utf-16.xml [not validating:] input [validating:] input
+japanese/weekly-utf-8.xml [not validating:] input [validating:] input
+sun/valid/pe01.xml [not validating:] input [validating:] input
+sun/valid/dtd00.xml [not validating:] input/output [validating:] input/output
+sun/valid/dtd01.xml [not validating:] input/output [validating:] input/output
+sun/valid/element.xml [not validating:] input/output [validating:] input/output
+sun/valid/ext01.xml [not validating:] input/output [validating:] input/output
+sun/valid/ext02.xml [not validating:] input/output [validating:] input/output
+sun/valid/not-sa01.xml [not validating:] input/output [validating:] input/output
+sun/valid/not-sa02.xml [not validating:] input/output [validating:] input/output
+sun/valid/not-sa03.xml [not validating:] input/output [validating:] input/output
+sun/valid/not-sa04.xml [not validating:] input/output [validating:] input/output
+sun/valid/notation01.xml [not validating:] input/output [validating:] input/output
+sun/valid/optional.xml [not validating:] input/output [validating:] input/output
+sun/valid/required00.xml [not validating:] input/output [validating:] input/output
+sun/valid/sa01.xml [not validating:] input/output [validating:] input/output
+sun/valid/sa02.xml [not validating:] input/output [validating:] input/output
+sun/valid/sa03.xml [not validating:] input/output [validating:] input/output
+sun/valid/sa04.xml [not validating:] input/output [validating:] input/output
+sun/valid/sa05.xml [not validating:] input/output [validating:] input/output
+sun/valid/sgml01.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang01.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang02.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang03.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang04.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang05.xml [not validating:] input/output [validating:] input/output
+sun/valid/v-lang06.xml [not validating:] input/output [validating:] input/output
+sun/valid/pe00.xml [not validating:] input/output [validating:] input/output
+sun/valid/pe03.xml [not validating:] input/output [validating:] input/output
+sun/valid/pe02.xml [not validating:] input/output [validating:] input/output
+sun/invalid/dtd01.xml [not validating:] input [validating:] invalid
+sun/invalid/dtd02.xml [not validating:] input [validating:] invalid
+sun/invalid/dtd03.xml [not validating:] input [validating:] invalid
+sun/invalid/el01.xml [not validating:] input [validating:] invalid
+sun/invalid/el02.xml [not validating:] input [validating:] invalid
+sun/invalid/el03.xml [not validating:] input [validating:] invalid
+sun/invalid/el04.xml [not validating:] input [validating:] invalid
+sun/invalid/el05.xml [not validating:] input [validating:] invalid
+sun/invalid/el06.xml [not validating:] input [validating:] invalid
+sun/invalid/id01.xml [not validating:] input [validating:] invalid
+sun/invalid/id02.xml [not validating:] input [validating:] invalid
+sun/invalid/id03.xml [not validating:] input [validating:] invalid
+sun/invalid/id04.xml [not validating:] input [validating:] invalid
+sun/invalid/id05.xml [not validating:] input [validating:] invalid
+sun/invalid/id06.xml [not validating:] input [validating:] invalid
+sun/invalid/id07.xml [not validating:] input [validating:] invalid
+sun/invalid/id08.xml [not validating:] input [validating:] invalid
+sun/invalid/id09.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa01.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa02.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa04.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa05.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa06.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa07.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa08.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa09.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa10.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa11.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa12.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa13.xml [not validating:] input [validating:] invalid
+sun/invalid/not-sa14.xml [not validating:] input [validating:] invalid
+sun/invalid/optional01.xml [not validating:] input [validating:] invalid
+sun/invalid/optional02.xml [not validating:] input [validating:] invalid
+sun/invalid/optional03.xml [not validating:] input [validating:] invalid
+sun/invalid/optional04.xml [not validating:] input [validating:] invalid
+sun/invalid/optional05.xml [not validating:] input [validating:] invalid
+sun/invalid/optional06.xml [not validating:] input [validating:] invalid
+sun/invalid/optional07.xml [not validating:] input [validating:] invalid
+sun/invalid/optional08.xml [not validating:] input [validating:] invalid
+sun/invalid/optional09.xml [not validating:] input [validating:] invalid
+sun/invalid/optional10.xml [not validating:] input [validating:] invalid
+sun/invalid/optional11.xml [not validating:] input [validating:] invalid
+sun/invalid/optional12.xml [not validating:] input [validating:] invalid
+sun/invalid/optional13.xml [not validating:] input [validating:] invalid
+sun/invalid/optional14.xml [not validating:] input [validating:] invalid
+sun/invalid/optional20.xml [not validating:] input [validating:] invalid
+sun/invalid/optional21.xml [not validating:] input [validating:] invalid
+sun/invalid/optional22.xml [not validating:] input [validating:] invalid
+sun/invalid/optional23.xml [not validating:] input [validating:] invalid
+sun/invalid/optional24.xml [not validating:] input [validating:] invalid
+sun/invalid/optional25.xml [not validating:] input [validating:] invalid
+sun/invalid/required00.xml [not validating:] input [validating:] invalid
+sun/invalid/required01.xml [not validating:] input [validating:] invalid
+sun/invalid/required02.xml [not validating:] input [validating:] invalid
+sun/invalid/root.xml [not validating:] input [validating:] invalid
+sun/invalid/attr01.xml [not validating:] input [validating:] invalid
+sun/invalid/attr02.xml [not validating:] input [validating:] invalid
+sun/invalid/attr03.xml [not validating:] input [validating:] invalid
+sun/invalid/attr04.xml [not validating:] input [validating:] invalid
+sun/invalid/attr05.xml [not validating:] input [validating:] invalid
+sun/invalid/attr06.xml [not validating:] input [validating:] invalid
+sun/invalid/attr07.xml [not validating:] input [validating:] invalid
+sun/invalid/attr08.xml [not validating:] input [validating:] invalid
+sun/invalid/attr09.xml [not validating:] input [validating:] invalid
+sun/invalid/attr10.xml [not validating:] input [validating:] invalid
+sun/invalid/attr11.xml [not validating:] input [validating:] invalid
+sun/invalid/attr12.xml [not validating:] input [validating:] invalid
+sun/invalid/attr13.xml [not validating:] input [validating:] invalid
+sun/invalid/attr14.xml [not validating:] input [validating:] invalid
+sun/invalid/attr15.xml [not validating:] input [validating:] invalid
+sun/invalid/attr16.xml [not validating:] input [validating:] invalid
+sun/invalid/utf16b.xml [not validating:] input [validating:] invalid
+sun/invalid/utf16l.xml [not validating:] input [validating:] invalid
+sun/invalid/empty.xml [not validating:] input [validating:] invalid
+sun/not-wf/not-sa03.xml [not validating:] not-wf [validating:] invalid
+sun/not-wf/attlist01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist05.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist06.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist07.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist08.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist09.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist10.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/attlist11.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/cond01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/cond02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/content01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/content02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/content03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/decl01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd00.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd05.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/dtd07.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/element00.xml [not validating:] not-wf [validating:] invalid
+sun/not-wf/element01.xml [not validating:] not-wf [validating:] invalid
+sun/not-wf/element02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/element03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/element04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding05.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding06.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/encoding07.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pi.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pubid01.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pubid02.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pubid03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pubid04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/pubid05.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml01.xml [not validating:] not-wf [validating:] invalid
+sun/not-wf/sgml02.xml [not validating:] not-wf [validating:] invalid
+sun/not-wf/sgml03.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml04.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml05.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml06.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml07.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml08.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml09.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml10.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml11.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml12.xml [not validating:] not-wf [validating:] not-wf
+sun/not-wf/sgml13.xml [not validating:] not-wf [validating:] not-wf
+oasis/p01pass2.xml [not validating:] input [validating:] input
+oasis/p06pass1.xml [not validating:] input [validating:] input
+oasis/p07pass1.xml [not validating:] input [validating:] input
+p08pass1.xml: test applies to parsers without namespace support, skipping
+oasis/p09pass1.xml [not validating:] input [validating:] input
+oasis/p12pass1.xml [not validating:] input [validating:] input
+oasis/p22pass4.xml [not validating:] input [validating:] input
+oasis/p22pass5.xml [not validating:] input [validating:] input
+oasis/p22pass6.xml [not validating:] input [validating:] input
+oasis/p28pass1.xml [not validating:] input [validating:] input
+oasis/p28pass3.xml [not validating:] input [validating:] input
+oasis/p28pass4.xml [not validating:] input [validating:] input
+oasis/p28pass5.xml [not validating:] input [validating:] input
+oasis/p29pass1.xml [not validating:] input [validating:] input
+oasis/p30pass1.xml [not validating:] input [validating:] input
+oasis/p30pass2.xml [not validating:] input [validating:] input
+oasis/p31pass1.xml [not validating:] input [validating:] input
+oasis/p31pass2.xml [not validating:] input [validating:] input
+oasis/p43pass1.xml [not validating:] input [validating:] input
+oasis/p45pass1.xml [not validating:] input [validating:] input
+oasis/p46pass1.xml [not validating:] input [validating:] input
+oasis/p47pass1.xml [not validating:] input [validating:] input
+oasis/p48pass1.xml [not validating:] input [validating:] input
+oasis/p49pass1.xml [not validating:] input [validating:] input
+oasis/p50pass1.xml [not validating:] input [validating:] input
+oasis/p51pass1.xml [not validating:] input [validating:] input
+oasis/p52pass1.xml [not validating:] input [validating:] input
+oasis/p53pass1.xml [not validating:] input [validating:] input
+oasis/p54pass1.xml [not validating:] input [validating:] input
+oasis/p55pass1.xml [not validating:] input [validating:] input
+oasis/p56pass1.xml [not validating:] input [validating:] input
+oasis/p57pass1.xml [not validating:] input [validating:] input
+oasis/p58pass1.xml [not validating:] input [validating:] input
+oasis/p59pass1.xml [not validating:] input [validating:] input
+oasis/p60pass1.xml [not validating:] input [validating:] input
+oasis/p61pass1.xml [not validating:] input [validating:] input
+oasis/p62pass1.xml [not validating:] input [validating:] input
+oasis/p63pass1.xml [not validating:] input [validating:] input
+oasis/p64pass1.xml [not validating:] input [validating:] input
+oasis/p68pass1.xml [not validating:] input [validating:] input
+oasis/p69pass1.xml [not validating:] input [validating:] input
+oasis/p70pass1.xml [not validating:] input [validating:] input
+oasis/p71pass1.xml [not validating:] input [validating:] input
+oasis/p72pass1.xml [not validating:] input [validating:] input
+oasis/p73pass1.xml [not validating:] input [validating:] input
+oasis/p76pass1.xml [not validating:] input [validating:] input
+oasis/p01pass1.xml [not validating:] input [validating:] invalid
+oasis/p01pass3.xml [not validating:] input [validating:] invalid
+oasis/p03pass1.xml [not validating:] input [validating:] invalid
+p04pass1.xml: test applies to parsers without namespace support, skipping
+p05pass1.xml: test applies to parsers without namespace support, skipping
+oasis/p06fail1.xml [not validating:] input [validating:] invalid
+oasis/p08fail1.xml [not validating:] input [validating:] invalid
+oasis/p08fail2.xml [not validating:] input [validating:] invalid
+oasis/p10pass1.xml [not validating:] input [validating:] invalid
+oasis/p14pass1.xml [not validating:] input [validating:] invalid
+oasis/p15pass1.xml [not validating:] input [validating:] invalid
+oasis/p16pass1.xml [not validating:] input [validating:] invalid
+oasis/p16pass2.xml [not validating:] input [validating:] invalid
+oasis/p16pass3.xml [not validating:] input [validating:] invalid
+oasis/p18pass1.xml [not validating:] input [validating:] invalid
+oasis/p22pass1.xml [not validating:] input [validating:] invalid
+oasis/p22pass2.xml [not validating:] input [validating:] invalid
+oasis/p22pass3.xml [not validating:] input [validating:] invalid
+oasis/p23pass1.xml [not validating:] input [validating:] invalid
+oasis/p23pass2.xml [not validating:] input [validating:] invalid
+oasis/p23pass3.xml [not validating:] input [validating:] invalid
+oasis/p23pass4.xml [not validating:] input [validating:] invalid
+oasis/p24pass1.xml [not validating:] input [validating:] invalid
+oasis/p24pass2.xml [not validating:] input [validating:] invalid
+oasis/p24pass3.xml [not validating:] input [validating:] invalid
+oasis/p24pass4.xml [not validating:] input [validating:] invalid
+oasis/p25pass1.xml [not validating:] input [validating:] invalid
+oasis/p25pass2.xml [not validating:] input [validating:] invalid
+oasis/p26pass1.xml [not validating:] input [validating:] invalid
+oasis/p27pass1.xml [not validating:] input [validating:] invalid
+oasis/p27pass2.xml [not validating:] input [validating:] invalid
+oasis/p27pass3.xml [not validating:] input [validating:] invalid
+oasis/p27pass4.xml [not validating:] input [validating:] invalid
+oasis/p32pass1.xml [not validating:] input [validating:] invalid
+oasis/p32pass2.xml [not validating:] input [validating:] invalid
+oasis/p39pass1.xml [not validating:] input [validating:] invalid
+oasis/p39pass2.xml [not validating:] input [validating:] invalid
+oasis/p40pass1.xml [not validating:] input [validating:] invalid
+oasis/p40pass2.xml [not validating:] input [validating:] invalid
+oasis/p40pass3.xml [not validating:] input [validating:] invalid
+oasis/p40pass4.xml [not validating:] input [validating:] invalid
+oasis/p41pass1.xml [not validating:] input [validating:] invalid
+oasis/p41pass2.xml [not validating:] input [validating:] invalid
+oasis/p42pass1.xml [not validating:] input [validating:] invalid
+oasis/p42pass2.xml [not validating:] input [validating:] invalid
+oasis/p44pass1.xml [not validating:] input [validating:] invalid
+oasis/p44pass2.xml [not validating:] input [validating:] invalid
+oasis/p44pass3.xml [not validating:] input [validating:] invalid
+oasis/p44pass4.xml [not validating:] input [validating:] invalid
+oasis/p44pass5.xml [not validating:] input [validating:] invalid
+oasis/p66pass1.xml [not validating:] input [validating:] invalid
+oasis/p74pass1.xml [not validating:] input [validating:] invalid
+oasis/p75pass1.xml [not validating:] input [validating:] invalid
+oasis/e2.xml [not validating:] input [validating:] invalid
+oasis/p01fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p01fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p01fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p01fail4.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail10.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail11.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail12.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail13.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail14.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail15.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail16.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail17.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail18.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail19.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail20.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail21.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail22.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail23.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail24.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail25.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail26.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail27.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail28.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail29.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail30.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail31.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail4.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail5.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail6.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail7.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail8.xml [not validating:] not-wf [validating:] invalid
+oasis/p02fail9.xml [not validating:] not-wf [validating:] invalid
+oasis/p03fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail10.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail11.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail12.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail13.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail14.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail15.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail16.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail17.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail18.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail19.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail20.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail21.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail22.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail23.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail24.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail25.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail26.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail27.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail28.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail29.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail7.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail8.xml [not validating:] not-wf [validating:] not-wf
+oasis/p03fail9.xml [not validating:] not-wf [validating:] not-wf
+oasis/p04fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p04fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p04fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p05fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p05fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p05fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p05fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p05fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p09fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p09fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p09fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p09fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p09fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p10fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p10fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p10fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p11fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p11fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail6.xml [not validating:] not-wf [validating:] not-wf
+oasis/p12fail7.xml [not validating:] not-wf [validating:] not-wf
+oasis/p14fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p14fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p14fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p15fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p15fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p15fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p16fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p16fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p16fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p18fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p18fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p18fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p22fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p22fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p23fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p23fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p23fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p23fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p23fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p24fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p24fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p25fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p26fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p26fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p27fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p28fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p29fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p30fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p31fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p32fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p32fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p32fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p32fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p32fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p39fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p39fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p39fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p39fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p39fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p40fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p40fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p40fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p40fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p41fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p41fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p41fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p42fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p42fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p42fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p43fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p43fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p43fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p44fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p44fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p44fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p44fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p44fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p45fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p45fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p45fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p45fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p46fail6.xml [not validating:] not-wf [validating:] not-wf
+oasis/p47fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p47fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p47fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p47fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p48fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p48fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p49fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p50fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail6.xml [not validating:] not-wf [validating:] not-wf
+oasis/p51fail7.xml [not validating:] not-wf [validating:] not-wf
+oasis/p52fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p52fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p53fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p53fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p53fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p53fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p53fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p54fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p55fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p56fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p56fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p56fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p56fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p56fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p57fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p58fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail6.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail7.xml [not validating:] not-wf [validating:] not-wf
+oasis/p58fail8.xml [not validating:] not-wf [validating:] not-wf
+oasis/p59fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p59fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p59fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p60fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p60fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p60fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p60fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p60fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p61fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p62fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p62fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p63fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p63fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p64fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p64fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p66fail1.xml [not validating:] not-wf [validating:] invalid
+oasis/p66fail2.xml [not validating:] not-wf [validating:] invalid
+oasis/p66fail3.xml [not validating:] not-wf [validating:] invalid
+oasis/p66fail4.xml [not validating:] not-wf [validating:] invalid
+oasis/p66fail5.xml [not validating:] not-wf [validating:] invalid
+oasis/p66fail6.xml [not validating:] not-wf [validating:] invalid
+oasis/p68fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p68fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p68fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p69fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p69fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p69fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p70fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p71fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p71fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p71fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p71fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p72fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p72fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p72fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p72fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p73fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p73fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p73fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p73fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p73fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p74fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p74fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p74fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail4.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail5.xml [not validating:] not-wf [validating:] not-wf
+oasis/p75fail6.xml [not validating:] not-wf [validating:] not-wf
+oasis/p76fail1.xml [not validating:] not-wf [validating:] not-wf
+oasis/p76fail2.xml [not validating:] not-wf [validating:] not-wf
+oasis/p76fail3.xml [not validating:] not-wf [validating:] not-wf
+oasis/p76fail4.xml [not validating:] not-wf [validating:] not-wf
+ibm/invalid/P28/ibm28i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P32/ibm32i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P32/ibm32i03.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P32/ibm32i04.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P39/ibm39i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P39/ibm39i02.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P39/ibm39i03.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P39/ibm39i04.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P41/ibm41i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P41/ibm41i02.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P45/ibm45i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P49/ibm49i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P50/ibm50i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P51/ibm51i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P51/ibm51i03.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i02.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i03.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i05.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i06.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i07.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i08.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i09.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i10.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i11.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i12.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i13.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i14.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i15.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i16.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i17.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P56/ibm56i18.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P58/ibm58i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P58/ibm58i02.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P59/ibm59i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P60/ibm60i01.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P60/ibm60i02.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P60/ibm60i03.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P60/ibm60i04.xml [not validating:] input/output [validating:] invalid
+ibm/invalid/P76/ibm76i01.xml [not validating:] input/output [validating:] invalid
+ibm/not-wf/P01/ibm01n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P01/ibm01n02.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P01/ibm01n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n16.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n17.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n18.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n19.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n20.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n21.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n22.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n23.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n24.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n25.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n26.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n27.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n28.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n29.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n30.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n31.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n32.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P02/ibm02n33.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P03/ibm03n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n16.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n17.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P04/ibm04n18.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P05/ibm05n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P05/ibm05n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P05/ibm05n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P09/ibm09n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P09/ibm09n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P09/ibm09n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P09/ibm09n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P10/ibm10n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P11/ibm11n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P11/ibm11n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P11/ibm11n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P11/ibm11n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P12/ibm12n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P12/ibm12n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P12/ibm12n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P13/ibm13n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P13/ibm13n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P13/ibm13n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P14/ibm14n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P14/ibm14n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P14/ibm14n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P15/ibm15n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P15/ibm15n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P15/ibm15n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P15/ibm15n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P16/ibm16n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P16/ibm16n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P16/ibm16n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P16/ibm16n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P17/ibm17n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P17/ibm17n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P17/ibm17n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P17/ibm17n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P18/ibm18n01.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P18/ibm18n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P19/ibm19n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P19/ibm19n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P19/ibm19n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P20/ibm20n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P21/ibm21n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P21/ibm21n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P21/ibm21n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P22/ibm22n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P22/ibm22n02.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P22/ibm22n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P23/ibm23n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P24/ibm24n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P25/ibm25n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P25/ibm25n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P26/ibm26n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P27/ibm27n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P28/ibm28n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/p28a/ibm28an01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P29/ibm29n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P30/ibm30n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P31/ibm31n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P32/ibm32n09.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P39/ibm39n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P39/ibm39n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P39/ibm39n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P39/ibm39n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P39/ibm39n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P39/ibm39n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P40/ibm40n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P40/ibm40n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P40/ibm40n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P40/ibm40n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P40/ibm40n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P41/ibm41n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P42/ibm42n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P42/ibm42n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P42/ibm42n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P42/ibm42n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P42/ibm42n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P43/ibm43n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P43/ibm43n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P43/ibm43n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P43/ibm43n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P44/ibm44n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P44/ibm44n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P44/ibm44n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P44/ibm44n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P45/ibm45n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P46/ibm46n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P46/ibm46n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P46/ibm46n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P46/ibm46n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P46/ibm46n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P47/ibm47n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P48/ibm48n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P49/ibm49n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P50/ibm50n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P51/ibm51n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P52/ibm52n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P53/ibm53n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P54/ibm54n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P54/ibm54n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P55/ibm55n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P55/ibm55n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P55/ibm55n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P56/ibm56n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P57/ibm57n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P58/ibm58n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P59/ibm59n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P60/ibm60n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P61/ibm61n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P62/ibm62n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P63/ibm63n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P64/ibm64n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P64/ibm64n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P64/ibm64n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P65/ibm65n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P65/ibm65n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P66/ibm66n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n06.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P68/ibm68n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P68/ibm68n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P69/ibm69n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm70n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P71/ibm71n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P72/ibm72n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P73/ibm73n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P73/ibm73n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P74/ibm74n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P75/ibm75n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P76/ibm76n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P77/ibm77n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P77/ibm77n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P77/ibm77n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P77/ibm77n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P78/ibm78n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P78/ibm78n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P79/ibm79n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P79/ibm79n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P80/ibm80n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P81/ibm81n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P82/ibm82n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P83/ibm83n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P83/ibm83n02.xml [not validating:] not-wf [validating:] invalid
+ibm/not-wf/P83/ibm83n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P83/ibm83n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P83/ibm83n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P83/ibm83n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n100.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n101.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n102.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n103.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n104.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n105.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n106.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n107.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n108.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n109.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n110.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n111.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n112.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n113.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n114.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n115.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n116.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n117.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n118.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n119.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n120.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n121.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n122.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n123.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n124.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n125.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n126.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n127.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n128.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n129.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n130.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n131.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n132.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n133.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n134.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n135.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n136.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n137.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n138.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n139.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n140.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n141.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n142.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n143.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n144.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n145.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n146.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n147.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n148.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n149.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n150.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n151.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n152.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n153.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n154.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n155.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n156.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n157.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n158.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n159.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n16.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n160.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n161.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n162.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n163.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n164.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n165.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n166.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n167.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n168.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n169.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n17.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n170.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n171.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n172.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n173.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n174.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n175.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n176.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n177.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n178.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n179.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n18.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n180.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n181.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n182.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n183.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n184.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n185.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n186.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n187.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n188.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n189.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n19.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n190.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n191.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n192.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n193.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n194.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n195.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n196.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n197.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n198.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n20.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n21.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n22.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n23.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n24.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n25.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n26.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n27.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n28.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n29.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n30.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n31.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n32.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n33.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n34.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n35.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n36.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n37.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n38.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n39.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n40.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n41.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n42.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n43.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n44.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n45.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n46.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n47.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n48.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n49.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n50.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n51.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n52.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n53.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n54.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n55.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n56.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n57.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n58.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n59.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n60.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n61.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n62.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n63.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n64.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n65.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n66.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n67.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n68.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n69.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n70.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n71.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n72.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n73.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n74.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n75.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n76.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n77.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n78.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n79.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n80.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n81.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n82.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n83.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n84.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n85.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n86.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n87.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n88.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n89.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n90.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n91.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n92.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n93.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n94.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n95.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n96.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n97.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n98.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P85/ibm85n99.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P86/ibm86n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P86/ibm86n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P86/ibm86n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P86/ibm86n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n16.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n17.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n18.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n19.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n20.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n21.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n22.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n23.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n24.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n25.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n26.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n27.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n28.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n29.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n30.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n31.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n32.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n33.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n34.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n35.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n36.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n37.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n38.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n39.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n40.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n41.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n42.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n43.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n44.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n45.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n46.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n47.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n48.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n49.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n50.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n51.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n52.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n53.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n54.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n55.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n56.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n57.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n58.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n59.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n60.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n61.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n62.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n63.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n64.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n66.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n67.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n68.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n69.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n70.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n71.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n72.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n73.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n74.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n75.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n76.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n77.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n78.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n79.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n80.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n81.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n82.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n83.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n84.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P87/ibm87n85.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n13.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n14.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n15.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P88/ibm88n16.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n01.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n02.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n03.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n04.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n05.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n06.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n07.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n08.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n09.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n10.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n11.xml [not validating:] not-wf [validating:] not-wf
+ibm/not-wf/P89/ibm89n12.xml [not validating:] not-wf [validating:] not-wf
+ibm/valid/P01/ibm01v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P02/ibm02v01.xml [not validating:] input [validating:] input
+ibm/valid/P03/ibm03v01.xml [not validating:] input [validating:] input
+ibm/valid/P09/ibm09v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P09/ibm09v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P09/ibm09v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P09/ibm09v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P09/ibm09v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v06.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v07.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P10/ibm10v08.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P11/ibm11v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P11/ibm11v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P11/ibm11v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P11/ibm11v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P12/ibm12v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P12/ibm12v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P12/ibm12v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P12/ibm12v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P13/ibm13v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P14/ibm14v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P14/ibm14v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P14/ibm14v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P15/ibm15v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P15/ibm15v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P15/ibm15v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P15/ibm15v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P16/ibm16v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P16/ibm16v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P16/ibm16v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P17/ibm17v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P18/ibm18v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P19/ibm19v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P20/ibm20v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P20/ibm20v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P21/ibm21v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v06.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P22/ibm22v07.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P23/ibm23v06.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P24/ibm24v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P24/ibm24v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P25/ibm25v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P25/ibm25v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P25/ibm25v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P25/ibm25v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P26/ibm26v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P27/ibm27v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P27/ibm27v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P27/ibm27v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P28/ibm28v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P30/ibm30v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P30/ibm30v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P31/ibm31v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P32/ibm32v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P32/ibm32v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P32/ibm32v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P32/ibm32v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P33/ibm33v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P34/ibm34v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P35/ibm35v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P36/ibm36v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P37/ibm37v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P38/ibm38v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P39/ibm39v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P40/ibm40v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P41/ibm41v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P42/ibm42v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P43/ibm43v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P44/ibm44v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P45/ibm45v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P47/ibm47v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P49/ibm49v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P50/ibm50v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P51/ibm51v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P51/ibm51v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P52/ibm52v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P54/ibm54v01.xml [not validating:] input [validating:] input
+ibm/valid/P54/ibm54v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P54/ibm54v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P55/ibm55v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v06.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v07.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v08.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v09.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P56/ibm56v10.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P57/ibm57v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P58/ibm58v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P58/ibm58v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P59/ibm59v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P59/ibm59v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P60/ibm60v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P60/ibm60v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P60/ibm60v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P60/ibm60v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P61/ibm61v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P61/ibm61v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P62/ibm62v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P62/ibm62v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P62/ibm62v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P62/ibm62v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P62/ibm62v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P63/ibm63v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P63/ibm63v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P63/ibm63v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P63/ibm63v04.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P63/ibm63v05.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P64/ibm64v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P64/ibm64v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P64/ibm64v03.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P65/ibm65v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P65/ibm65v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P66/ibm66v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P67/ibm67v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P68/ibm68v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P68/ibm68v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P69/ibm69v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P69/ibm69v02.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P70/ibm70v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P78/ibm78v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P79/ibm79v01.xml [not validating:] input [validating:] input
+ibm/valid/P82/ibm82v01.xml [not validating:] input/output [validating:] input/output
+ibm/valid/P85/ibm85v01.xml [not validating:] input [validating:] input
+ibm/valid/P86/ibm86v01.xml [not validating:] input [validating:] input
+ibm/valid/P87/ibm87v01.xml [not validating:] input [validating:] input
+ibm/valid/P88/ibm88v01.xml [not validating:] input [validating:] input
+ibm/valid/P89/ibm89v01.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/001.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/002.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/003.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/007.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/008.xml [not validating:] input [validating:] input
+eduni/namespaces/1.0/009.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/010.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/011.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/012.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/013.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/014.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/015.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/016.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/017.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/018.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/019.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/020.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/021.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/022.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/023.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/024.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/025.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/026.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/027.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/028.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/029.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/030.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/031.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/032.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/033.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/034.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/035.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/036.xml [not validating:] not-wf [validating:] invalid
+eduni/namespaces/1.0/037.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/038.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/039.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/040.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/041.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/042.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/043.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/044.xml [not validating:] not-wf [validating:] not-wf
+eduni/namespaces/1.0/045.xml [not validating:] input [validating:] invalid
+eduni/namespaces/1.0/046.xml [not validating:] input [validating:] invalid
+0/1829 tests failed; 333 tests were skipped
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLS-SYMBOLS.diff
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/XMLS-SYMBOLS.diff	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,98 @@
+* looking for david at knowledgetools.de--cxml/cxml--devel--1.0--patch-309 to compare with
+* comparing to david at knowledgetools.de--cxml/cxml--devel--1.0--patch-309
+M  xml/xmls-compat.lisp
+
+* modified files
+
+--- orig/xml/xmls-compat.lisp
++++ mod/xml/xmls-compat.lisp
+@@ -12,7 +12,8 @@
+ (defpackage cxml-xmls
+   (:use :cl :runes)
+   (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
+-           #:make-xmls-builder #:map-node))
++           #:make-xmls-builder #:map-node
++           #:*identifier-case*))
+ 
+ (in-package :cxml-xmls)
+ 
+@@ -64,6 +65,10 @@
+ 
+ ;;;; SAX-Handler (Parser)
+ 
++(defvar *identifier-case* nil
++  "One of NIL (don't intern names), :PRESERVE, :UPCASE, :DOWNCASE, or :INVERT
++   (intern name into the keyword package after adjusting case).")
++
+ (defclass xmls-builder ()
+     ((element-stack :initform nil :accessor element-stack)
+      (root :initform nil :accessor root)))
+@@ -74,16 +79,46 @@
+ (defmethod sax:end-document ((handler xmls-builder))
+   (root handler))
+ 
++(defun string-invert-case (str)
++  (map 'string
++    (lambda (c)
++      (cond
++        ((upper-case-p c) (char-downcase c))
++        ((lower-case-p c) (char-upcase c))
++        (t c)))
++    str))
++
++(defun maybe-intern (name)
++  (if *identifier-case*
++      (let ((str (if (stringp name) name (rod-string name))))
++        (intern (ecase *identifier-case*
++                  (:preserve str)
++                  (:upcase (string-upcase str))
++                  (:downcase (string-downcase str))
++                  (:invert (string-invert-case str)))
++                :keyword))
++      name))
++
++(defun maybe-stringify (name)
++  (if (symbolp name)
++      (let ((str (symbol-name name)))
++        (ecase *identifier-case*
++          (:preserve str)
++          (:upcase (string-downcase str))
++          (:downcase (string-upcase str))
++          (:invert (string-invert-case str))))
++      name))
++
+ (defmethod sax:start-element
+     ((handler xmls-builder) namespace-uri local-name qname attributes)
+   (declare (ignore namespace-uri))
+   (setf local-name (or local-name qname))
+   (let* ((attributes
+           (mapcar (lambda (attr)
+-                    (list (sax:attribute-qname attr)
++                    (list (maybe-intern (sax:attribute-qname attr))
+                           (sax:attribute-value attr)))
+                   attributes))
+-         (node (make-node :name local-name
++         (node (make-node :name (maybe-intern local-name)
+                           :ns (let ((lq (length qname))
+                                     (ll (length local-name)))
+                                 (if (eql lq ll)
+@@ -124,7 +159,7 @@
+   (labels ((walk (node)
+              (let* ((attlist
+                      (compute-attributes node include-xmlns-attributes))
+-                    (lname (rod (node-name node)))
++                    (lname (rod (maybe-stringify (node-name node))))
+                     (ns (rod (node-ns node)))
+                     (qname (concatenate 'rod ns (rod ":") lname)))
+                ;; fixme: namespaces
+@@ -141,6 +176,7 @@
+   (remove nil
+           (mapcar (lambda (a)
+                     (destructuring-bind (name value) a
++                      (setf name (maybe-stringify name))
+                       (if (or xmlnsp (not (cxml::xmlns-attr-p (rod name))))
+                           (sax:make-attribute :qname (rod name)
+                                               :value (rod value)
+
+
+

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/catalog.dtd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/catalog.dtd	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,149 @@
+<!-- $Id: catalog.dtd,v 1.1.1.1 2005/03/13 18:02:52 david Exp $ -->
+
+<!ENTITY % pubIdChars "CDATA">
+<!ENTITY % publicIdentifier "%pubIdChars;">
+<!ENTITY % partialPublicIdentifier "%pubIdChars;">
+<!ENTITY % uriReference "CDATA">
+<!ENTITY % string "CDATA">
+<!ENTITY % systemOrPublic "(system|public)">
+
+<!ENTITY % p "">
+<!ENTITY % s "">
+<!ENTITY % nsdecl "xmlns%s;">
+
+<!ENTITY % catalog "%p;catalog">
+<!ENTITY % public "%p;public">
+<!ENTITY % system "%p;system">
+<!ENTITY % uri "%p;uri">
+<!ENTITY % rewriteSystem "%p;rewriteSystem">
+<!ENTITY % rewriteURI "%p;rewriteURI">
+<!ENTITY % delegatePublic "%p;delegatePublic">
+<!ENTITY % delegateSystem "%p;delegateSystem">
+<!ENTITY % delegateURI "%p;delegateURI">
+<!ENTITY % nextCatalog "%p;nextCatalog">
+<!ENTITY % group "%p;group">
+
+<!ENTITY % local.catalog.mix "">
+<!ENTITY % local.catalog.attribs "">
+
+<!ELEMENT %catalog; (%public;|%system;|%uri;
+                     |%rewriteSystem;|%rewriteURI;
+                     |%delegatePublic;|%delegateSystem;|%delegateURI;
+                     |%nextCatalog;|%group; %local.catalog.mix;)+>
+<!ATTLIST %catalog;
+	%nsdecl;	%uriReference;		#FIXED
+		'urn:oasis:names:tc:entity:xmlns:xml:catalog'
+	prefer		%systemOrPublic;	#IMPLIED
+	xml:base	%uriReference;		#IMPLIED
+	%local.catalog.attribs;
+>
+
+<!ENTITY % local.public.attribs "">
+
+<!ELEMENT %public; EMPTY>
+<!ATTLIST %public;
+	id		ID			#IMPLIED
+	publicId	%publicIdentifier;	#REQUIRED
+	uri		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.public.attribs;
+>
+
+<!ENTITY % local.system.attribs "">
+
+<!ELEMENT %system; EMPTY>
+<!ATTLIST %system;
+	id		ID			#IMPLIED
+	systemId	%string;		#REQUIRED
+	uri		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.system.attribs;
+>
+
+<!ENTITY % local.uri.attribs "">
+
+<!ELEMENT %uri; EMPTY>
+<!ATTLIST %uri;
+	id		ID			#IMPLIED
+	name		%string;		#REQUIRED
+	uri		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.uri.attribs;
+>
+
+<!ENTITY % local.rewriteSystem.attribs "">
+
+<!ELEMENT %rewriteSystem; EMPTY>
+<!ATTLIST %rewriteSystem;
+	id		ID			#IMPLIED
+	systemIdStartString	%string;	#REQUIRED
+	rewritePrefix		%string;		#REQUIRED
+        %local.rewriteSystem.attribs;
+>
+
+<!ENTITY % local.rewriteURI.attribs "">
+
+<!ELEMENT %rewriteURI; EMPTY>
+<!ATTLIST %rewriteURI;
+	id		ID			#IMPLIED
+	uriStartString	%string;		#REQUIRED
+	rewritePrefix	%string;		#REQUIRED
+        %local.rewriteURI.attribs;
+>
+
+<!ENTITY % local.delegatePublic.attribs "">
+
+<!ELEMENT %delegatePublic; EMPTY>
+<!ATTLIST %delegatePublic;
+	id		ID			#IMPLIED
+	publicIdStartString	%partialPublicIdentifier;	#REQUIRED
+	catalog		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.delegatePublic.attribs;
+>
+
+<!ENTITY % local.delegateSystem.attribs "">
+
+<!ELEMENT %delegateSystem; EMPTY>
+<!ATTLIST %delegateSystem;
+	id		ID			#IMPLIED
+	systemIdStartString	%string;	#REQUIRED
+	catalog		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.delegateSystem.attribs;
+>
+
+<!ENTITY % local.delegateURI.attribs "">
+
+<!ELEMENT %delegateURI; EMPTY>
+<!ATTLIST %delegateURI;
+	id		ID			#IMPLIED
+	uriStartString	%string;		#REQUIRED
+	catalog		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.delegateURI.attribs;
+>
+
+<!ENTITY % local.nextCatalog.attribs "">
+
+<!ELEMENT %nextCatalog; EMPTY>
+<!ATTLIST %nextCatalog;
+	id		ID			#IMPLIED
+	catalog		%uriReference;		#REQUIRED
+	xml:base	%uriReference;		#IMPLIED
+        %local.nextCatalog.attribs;
+>
+
+<!ENTITY % local.group.mix "">
+<!ENTITY % local.group.attribs "">
+
+<!ELEMENT %group; (%public;|%system;|%uri;
+                   |%rewriteSystem;|%rewriteURI;
+                   |%delegatePublic;|%delegateSystem;|%delegateURI;
+                   |%nextCatalog; %local.group.mix;)+>
+<!ATTLIST %group;
+	id		ID			#IMPLIED
+	prefer		%systemOrPublic;	#IMPLIED
+	xml:base	%uriReference;		#IMPLIED
+        %local.group.attribs;
+>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/contrib/xhtmlgen.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/contrib/xhtmlgen.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,352 @@
+;; xhtmlgen.lisp
+;; This version by david at lichteblau.com for headcraft (http://headcraft.de/)
+;;
+;; Derived from htmlgen.cl:
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA 
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by 
+;; the Free Software Foundation, as clarified by the AllegroServe
+;; prequel found in license-allegroserve.txt.
+;;
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License is in the file 
+;; license-lgpl.txt that was distributed with this file.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple Place, 
+;; Suite 330, Boston, MA  02111-1307  USA
+
+(defpackage :xhtml-generator
+  (:use :common-lisp)
+  (:export #:with-html #:write-doctype))
+
+(in-package :xhtml-generator)
+
+;; html generation
+
+(defstruct (html-process (:type list) (:constructor
+				       make-html-process (key macro special
+							      name-attr
+							      )))
+  key		; keyword naming this tag
+  macro  	; the macro to define this
+  special       ; if true then call this to process the keyword and return
+                ; the macroexpansion
+  name-attr     ; attribute symbols which can name this object for subst purposes
+  )
+
+
+(defparameter *html-process-table* 
+    (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
+  )
+
+(defvar *html-sink*)
+
+(defun write-doctype (sink)
+  (sax:start-dtd sink
+                 "html"
+                 "-//W3C//DTD XHTML 1.0 Transitional//EN"
+                 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
+  (sax:end-dtd sink))
+
+(defmacro with-html (sink &rest forms &environment env)
+  `(let ((*html-sink* ,sink))
+     ,(process-html-forms forms env)))
+
+(defun get-process (form)
+  (let ((ent (gethash form *html-process-table*)))
+    (unless ent
+      (error "unknown html keyword ~s" form))
+    ent))
+
+(defun process-html-forms (forms env)
+  (let (res)
+    (flet ((do-ent (ent args argsp body)
+             ;; ent is an html-process object associated with the 
+             ;;	    html tag we're processing
+             ;; args is the list of values after the tag in the form
+             ;;     ((:tag &rest args) ....)
+             ;; argsp is true if this isn't a singleton tag  (i.e. it has
+             ;;     a body) .. (:tag ...) or ((:tag ...) ...)
+             ;; body is the body if any of the form
+             ;; 
+	     (let ((special (html-process-special ent)))
+	       (push (if special
+                         (funcall special ent args argsp body)
+                         `(,(html-process-macro ent)
+                           ,args
+                           ,(process-html-forms body env)))
+                     res))))
+      (do* ((xforms forms (cdr xforms))
+	    (form (car xforms) (car xforms)))
+	  ((null xforms))
+
+	(setq form (macroexpand form env))
+	
+	(if (atom form)
+            (typecase form
+              (keyword (do-ent (get-process form) nil nil nil)) 
+              (string (push `(sax:characters *html-sink* ,form) res))
+              (t (push form res)))
+            (let ((first (car form)))
+              (cond
+                ((keywordp first)
+                  ;; (:xxx . body) form
+                  (do-ent (get-process (car form)) nil t (cdr form)))
+                 ((and (consp first) (keywordp (car first)))
+                   ;; ((:xxx args ) . body)
+                   (do-ent (get-process (caar form)) (cdr first) t (cdr form)))
+                (t
+                  (push form res)))))))
+    `(progn ,@(nreverse res))))
+
+(defun html-body-key-form (string-code args body)
+  (unless (evenp (length args))
+    (error "attribute list ~S isn't even" args))
+  `(let ((.tagname. ,string-code))
+     (sax:start-element *html-sink* nil nil .tagname.
+                        (list
+                         ,@(loop
+                               for (name value) on args by #'cddr
+                               collect
+                                 `(sax:make-attribute
+                                   :qname ,(etypecase name
+                                             (symbol (symbol-name name))
+                                             (string name))
+                                   :value ,value
+                                   :specified-p t))))
+     , at body
+     (sax:end-element *html-sink* nil nil .tagname.)))
+
+(defun emit-without-quoting (str)
+  (let ((s (cxml::chained-handler *html-sink*)))
+    (cxml::maybe-close-tag s)
+    (map nil (lambda (c) (cxml::write-rune (char-code c) s)) str)))
+
+(defun princ-http (val)
+  (warn "use of deprecated :PRINC (use :PRINC-SAFE instead?)")
+  (emit-without-quoting (princ-to-string val)))
+
+(defun prin1-http (val)
+  (warn "use of deprecated :PRIN1 (use :PRIN1-SAFE instead?)")
+  (emit-without-quoting (prin1-to-string val)))
+
+(defun princ-safe-http (val)
+  (sax:characters *html-sink* (princ-to-string val)))
+
+(defun prin1-safe-http (val)
+  (sax:characters *html-sink* (prin1-to-string val)))
+
+
+;; --  defining how html tags are handled. --
+;;
+;; most tags are handled in a standard way and the def-std-html
+;; macro is used to define such tags
+;;
+;; Some tags need special treatment and def-special-html defines
+;; how these are handled.  The tags requiring special treatment
+;; are the pseudo tags we added to control operations
+;; in the html generator.
+;; 
+;;
+;; tags can be found in three ways:
+;;  :br	    		- singleton, no attributes, no body
+;;  (:b "foo")          - no attributes but with a body
+;;  ((:a href="foo") "balh")  - attributes and body
+;;
+  
+(defmacro def-special-html (kwd fcn)
+  ;; kwd - the tag we're defining behavior for.
+  ;; fcn - function to compute the macroexpansion of a use of this
+  ;;       tag. args to fcn are: 
+  ;;		ent - html-process object holding info on this tag
+  ;;		args - list of attribute-values following tag
+  ;;		argsp - true if there is a body in this use of the tag
+  ;;		body - list of body forms.
+  `(setf (gethash ,kwd *html-process-table*) 
+     (make-html-process ,kwd nil ,fcn nil)))
+
+(def-special-html :newline 
+    #'(lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	(when body
+          (error "can't have a body with :newline -- body is ~s" body))
+	(emit-without-quoting (string #\newline))))
+			       
+(def-special-html :princ 
+    #'(lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	`(progn ,@(mapcar #'(lambda (bod)
+			      `(princ-http ,bod))
+			  body))))
+
+(def-special-html :princ-safe 
+    #'(lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	`(progn ,@(mapcar #'(lambda (bod)
+			      `(princ-safe-http ,bod))
+			  body))))
+
+(def-special-html :prin1 
+    #'(lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	`(progn ,@(mapcar #'(lambda (bod)
+			      `(prin1-http ,bod))
+			  body))))
+
+(def-special-html :prin1-safe 
+    #'(lambda (ent args argsp body)
+	(declare (ignore ent args argsp))
+	`(progn ,@(mapcar #'(lambda (bod)
+			      `(prin1-safe-http ,bod))
+			  body))))
+
+(def-special-html :comment
+  #'(lambda (ent args argsp body)
+      (declare (ignore ent args argsp body))
+      `(warn ":COMMENT in html macro not supported yet")))
+
+(defmacro def-std-html (kwd name-attrs)
+  (let ((mac-name (intern (format nil "~a-~a" :with-html kwd)))
+	(string-code (string-downcase (string kwd))))
+    `(progn (setf (gethash ,kwd *html-process-table*)
+	      (make-html-process ,kwd
+				     ',mac-name
+				     nil
+				     ',name-attrs))
+	    (defmacro ,mac-name (args &rest body)
+	      (html-body-key-form ,string-code args body)))))
+
+(def-std-html :a         nil)
+(def-std-html :abbr      nil)
+(def-std-html :acronym   nil)
+(def-std-html :address   nil)
+(def-std-html :applet    nil)
+(def-std-html :area      nil)
+
+(def-std-html :b         nil)
+(def-std-html :base      nil)
+(def-std-html :basefont  nil)
+(def-std-html :bdo       nil)
+(def-std-html :bgsound   nil)
+(def-std-html :big       nil)
+(def-std-html :blink     nil)
+(def-std-html :blockquote nil)
+(def-std-html :body      nil)
+(def-std-html :br        nil)
+(def-std-html :button    nil)
+
+(def-std-html :caption   nil)
+(def-std-html :center    nil)
+(def-std-html :cite      nil)
+(def-std-html :code      nil)
+(def-std-html :col       nil)
+(def-std-html :colgroup  nil)
+
+(def-std-html :dd         nil)
+(def-std-html :del        nil)
+(def-std-html :dfn        nil)
+(def-std-html :dir        nil)
+(def-std-html :div        nil)
+(def-std-html :dl         nil)
+(def-std-html :dt         nil)
+
+(def-std-html :em         nil)
+(def-std-html :embed      nil)
+
+(def-std-html :fieldset     nil)
+(def-std-html :font         nil)
+(def-std-html :form         :name)
+(def-std-html :frame        nil)
+(def-std-html :frameset     nil)
+
+(def-std-html :h1         nil)
+(def-std-html :h2         nil)
+(def-std-html :h3         nil)
+(def-std-html :h4         nil)
+(def-std-html :h5         nil)
+(def-std-html :h6         nil)
+(def-std-html :head       nil)
+(def-std-html :hr         nil)
+(def-std-html :html       nil)
+
+(def-std-html :i        nil)
+(def-std-html :iframe   nil)
+(def-std-html :ilayer   nil)
+(def-std-html :img      :id)
+(def-std-html :input    nil)
+(def-std-html :ins      nil)
+(def-std-html :isindex  nil)
+
+(def-std-html :kbd  	 nil)
+(def-std-html :keygen  	 nil)
+
+(def-std-html :label  	 nil)
+(def-std-html :layer  	 nil)
+(def-std-html :legend  	 nil)
+(def-std-html :li  	 nil)
+(def-std-html :link  	 nil)
+(def-std-html :listing   nil)
+
+(def-std-html :map  	 nil)
+(def-std-html :marquee   nil)
+(def-std-html :menu  	 nil)
+(def-std-html :meta  	 nil)
+(def-std-html :multicol  nil)
+
+(def-std-html :nobr  	 nil)
+(def-std-html :noembed   nil)
+(def-std-html :noframes  nil)
+(def-std-html :noscript  nil)
+
+(def-std-html :object  	 nil)
+(def-std-html :ol  	 nil)
+(def-std-html :optgroup  nil)
+(def-std-html :option  	 nil)
+
+(def-std-html :p  	 nil)
+(def-std-html :param  	 nil)
+(def-std-html :plaintext nil)
+(def-std-html :pre  	 nil)
+
+(def-std-html :q  	 nil)
+
+(def-std-html :s  	 nil)
+(def-std-html :samp  	 nil)
+(def-std-html :script  	 nil)
+(def-std-html :select  	 nil)
+(def-std-html :server  	 nil)
+(def-std-html :small  	 nil)
+(def-std-html :spacer  	 nil)
+(def-std-html :span  	 :id)
+(def-std-html :strike  	 nil)
+(def-std-html :strong  	 nil)
+(def-std-html :style     nil)  
+(def-std-html :sub  	 nil)
+(def-std-html :sup  	 nil)
+
+(def-std-html :table  	 :name)
+(def-std-html :tbody  	 nil)
+(def-std-html :td  	 nil)
+(def-std-html :textarea  nil)
+(def-std-html :tfoot  	 nil)
+(def-std-html :th  	 nil)
+(def-std-html :thead  	 nil)
+(def-std-html :title  	 nil)
+(def-std-html :tr  	 nil)
+(def-std-html :tt  	 nil)
+
+(def-std-html :u 	 nil)
+(def-std-html :ul 	 nil)
+
+(def-std-html :var 	 nil)
+
+(def-std-html :wbr  	 nil)
+
+(def-std-html :xmp 	 nil)

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/cxml.asd
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/cxml.asd	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,113 @@
+(defpackage :cxml-system
+  (:use :asdf :cl))
+(in-package :cxml-system)
+
+(defclass dummy-cxml-component () ())
+
+(defmethod asdf:component-name ((c dummy-cxml-component))
+  :cxml)
+
+;; force loading of closure-common.asd, which installs *FEATURES* this
+;; file depends on.  Use MISSING-DEPENDENCY for asdf-install.
+(unless (find-system :closure-common nil)
+  (error 'missing-dependency
+	 :required-by (make-instance 'dummy-cxml-component)
+	 :version nil
+	 :requires :closure-common))
+
+(defclass closure-source-file (cl-source-file) ())
+
+#+scl
+(pushnew 'uri-is-namestring *features*)
+
+#+sbcl
+(defmethod perform :around ((o compile-op) (s closure-source-file))
+  ;; shut up already.  Correctness first.
+  (handler-bind ((sb-ext:compiler-note #'muffle-warning))
+    (let (#+sbcl (*compile-print* nil))
+      (call-next-method))))
+
+(asdf:defsystem :cxml-xml
+    :default-component-class closure-source-file
+    :pathname (merge-pathnames
+               "xml/"
+               (make-pathname :name nil :type nil :defaults *load-truename*))
+    :components
+    ((:file "package")
+     (:file "util"            :depends-on ("package"))
+     (:file "sax-handler")
+     (:file "xml-name-rune-p" :depends-on ("package" "util"))
+     (:file "split-sequence"  :depends-on ("package"))
+     (:file "xml-parse"       :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p"))
+     (:file "unparse"         :depends-on ("xml-parse"))
+     (:file "xmls-compat"     :depends-on ("xml-parse"))
+     (:file "recoder"         :depends-on ("xml-parse"))
+     (:file "xmlns-normalizer" :depends-on ("xml-parse"))
+     (:file "space-normalizer" :depends-on ("xml-parse"))
+     (:file "catalog"         :depends-on ("xml-parse"))
+     (:file "sax-proxy"       :depends-on ("xml-parse")))
+    :depends-on (:closure-common :puri #-scl :trivial-gray-streams))
+
+(defclass utf8dom-file (closure-source-file) ((of)))
+
+(defmethod output-files ((operation compile-op) (c utf8dom-file))
+  (let* ((normal (car (call-next-method)))
+	 (name (concatenate 'string (pathname-name normal) "-utf8")))
+    (list (make-pathname :name name :defaults normal))))
+
+;; must be an extra method because of common-lisp-controller's :around method 
+(defmethod output-files :around ((operation compile-op) (c utf8dom-file))
+  (let ((x (call-next-method)))
+    (setf (slot-value c 'of) (car x))
+    x))
+
+(defmethod perform ((o load-op) (c utf8dom-file))
+  (load (slot-value c 'of)))
+
+(defmethod perform ((operation compile-op) (c utf8dom-file))
+  (let ((*features* (cons 'utf8dom-file *features*))
+	(*readtable*
+	 (symbol-value (find-symbol "*UTF8-RUNES-READTABLE*"
+				    :closure-common-system))))
+    (call-next-method)))
+
+(asdf:defsystem :cxml-dom
+    :default-component-class closure-source-file
+    :pathname (merge-pathnames
+               "dom/"
+               (make-pathname :name nil :type nil :defaults *load-truename*))
+    :components
+    ((:file "package")
+     (:file rune-impl :pathname "dom-impl" :depends-on ("package"))
+     (:file rune-builder :pathname "dom-builder" :depends-on (rune-impl))
+     #+rune-is-integer
+     (utf8dom-file utf8-impl :pathname "dom-impl" :depends-on ("package"))
+     #+rune-is-integer
+     (utf8dom-file utf8-builder :pathname "dom-builder" :depends-on (utf8-impl))
+     (:file "dom-sax"         :depends-on ("package")))
+    :depends-on (:cxml-xml))
+
+(asdf:defsystem :cxml-klacks
+    :default-component-class closure-source-file
+    :pathname (merge-pathnames
+               "klacks/"
+               (make-pathname :name nil :type nil :defaults *load-truename*))
+    :serial t
+    :components
+    ((:file "package")
+     (:file "klacks")
+     (:file "klacks-impl")
+     (:file "tap-source"))
+    :depends-on (:cxml-xml))
+
+(asdf:defsystem :cxml-test
+    :default-component-class closure-source-file
+    :pathname (merge-pathnames
+               "test/"
+               (make-pathname :name nil :type nil :defaults *load-truename*))
+    :components ((:file "domtest") (:file "xmlconf"))
+    :depends-on (:cxml-xml :cxml-klacks :cxml-dom))
+
+(asdf:defsystem :cxml
+    :components ()
+    :depends-on (:cxml-dom :cxml-klacks :cxml-test))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/GNUmakefile
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/GNUmakefile	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,6 @@
+all: dom.html index.html installation.html klacks.html quickstart.html sax.html xmls-compat.html
+
+%.html: %.xml html.xsl
+	xsltproc html.xsl $< >$@.tmp
+	mv $@.tmp $@
+	chmod -w $@

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/bg.png
==============================================================================
Binary file. No diff available.

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/cxml.css
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/cxml.css	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,90 @@
+div.sidebar {
+  float: right;
+  min-width: 15%;
+  padding: 0pt 5pt 5pt 5pt;
+  font-family: verdana, arial;
+}
+
+div.sidebar-title {
+  font-weight: bold;
+  background-color: #9c0000;
+  border: solid #9c0000;
+  border-top-width: 1px;
+  border-bottom-width: 2px;
+  border-left-width: 4px;
+  border-right-width: 0px;
+  padding-left: 1px;
+  margin: 0em 2pt 0px 2em;
+}
+
+div.sidebar-title a {
+  color: #ffffff;
+}
+
+div.sidebar-main {
+  background-color: #f7f7f7;
+  border: solid #9c0000;
+  border-top-width: 0px;
+  border-bottom-width: 0px;
+  border-left-width: 4px;
+  border-right-width: 0px;
+  margin: 0em 2pt 1em 2em;
+  padding: 1em;
+}
+
+div.sidebar ul.main {
+  padding: 0pt 0pt 0pt 1em;
+  margin: 0 0 1em;
+}
+
+div.sidebar ul.sub {
+  list-style-type: square;
+  padding: 0pt 0pt 0pt 1em;
+  margin: 0 0 1em;
+}
+
+div.sidebar ul.hack {
+  padding: 0 0 0 0;
+  margin: 0 0 1em;
+  list-style-type: none;
+}
+
+body {
+  color: #000000;
+  background-color: #ffffff;
+  margin-right: 0pt;
+  margin-bottom: 10%;
+  margin-left: 40px;
+  padding-left: 30px;
+  font-family: verdana, arial;
+  background-image: url(bg.png);
+  background-position: top left;
+  background-attachment: fixed;
+  background-repeat: no-repeat;
+}
+
+h1 {
+  margin-left: -30px;
+}
+
+h2,h3 {
+  margin-left: -30px;
+  margin-top: 2em;
+}
+
+pre {
+  background-color: #eeeeee;
+  border: solid 1px #d0d0d0;
+  padding: 1em;
+  margin-right: 10%;
+}
+
+.def {
+  background-color: #ddddff;
+  font-weight: bold;
+}
+
+.nomargin {
+  margin-bottom: 0;
+  margin-top: 0;
+}

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,198 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML W3C DOM</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+  <h1>W3C DOM</h1>
+  <p>
+    CXML implements the DOM Level 2 Core interfaces.? For details
+    on DOM, please refer to the <a href="http://www.w3.org/TR/DOM-Level-2-Core/core.html">specification</a>.
+  </p>
+
+  <a name="parser"></a>
+  <h3>Parsing into DOM</h3>
+  <p>
+    To parse an XML document into a DOM tree, use the SAX parser with a
+    DOM builder as the SAX handler.  Example:
+  </p>
+  <pre>(cxml:parse-file "test.xml" (cxml-dom:make-dom-builder))</pre>
+  <p>
+    <div class="def">Function CXML-DOM:MAKE-DOM-BUILDER ()</div>
+    Create a SAX handler which builds a DOM document.
+    <p>
+    </p>
+    This functions returns a DOM builder that will work with the default
+    configuration of the SAX parser and is guaranteed to use
+    characters/strings instead of runes/rods, if that makes a
+    difference on the Lisp in question.
+    <p>
+    </p>
+    This is the same as <tt>rune-dom:make-dom-builder</tt> on Lisps
+    with Unicode support, and the same as
+    <tt>utf8-dom:make-dom-builder</tt> otherwise.
+  </p>
+
+  <p>
+    <div class="def">Function RUNE-DOM:MAKE-DOM-BUILDER ()</div>
+    Create a SAX handler which builds a DOM document using runes and rods.
+  </p>
+
+  <p>
+    <div class="def">Function UTF8-DOM:MAKE-DOM-BUILDER ()</div>
+    (Only on Lisps without Unicode support:)
+    Create a SAX handler which builds a DOM document using
+    UTF-8-encoded strings.
+  </p>
+
+  <a name="serialization"></a>
+  <h3>Serializing DOM</h3>
+  <p>
+    To serialize a DOM document, use a SAX serialization sink as the
+    argument to <tt>dom:map-document</tt>, which generates SAX events
+    for the DOM tree.
+  </p>
+  <p>
+    Applications dealing with namespaces might want to inject a
+    <a href="sax.html#misc">namespace normalizer</a> into the
+    sink chain.
+  </p>
+  <p>
+    <div class="def">Function DOM:MAP-DOCUMENT (handler document &amp;key include-xmlns-attributes include-default-values include-doctype)</div>
+    Traverse a DOM document and call SAX functions as if an XML
+    representation of the document was processed by a SAX parser.
+  </p>
+  <p>Keyword arguments:</p>
+  <ul>
+    <li>
+      <tt>include-xmlns-attributes</tt> -- defaults to
+      <tt>sax:*include-xmlns-attributes*</tt>
+    </li>
+    <li>
+      <tt>include-doctype</tt> -- One of <tt>nil</tt> (no doctype
+      declaration), <tt>:full-internal-subset</tt> (include a doctype
+      declaration and the full internal subset), or
+      <tt>:canonical-notations</tt> (write a doctype declaration
+      with an internal subset including only notations, as required
+      for canonical serialization).
+    </li>
+    <li>
+      <tt>include-default-values</tt> -- include attribute nodes with nil
+      <tt>dom:specified</tt>.
+    </li>
+    <li>
+      <tt>recode</tt> -- (ignored on Lisps with Unicode support.) If
+      true, recode UTF-8 strings to rods.   Defaults to true if used
+      with a UTF-8 DOM document.  It can be set to false manually to
+      suppress recoding in this case.
+    </li>
+  </ul>
+
+  <a name="mapping"></a>
+  <h3>DOM/Lisp mapping</h3>
+  <p>
+    Note that there is no "standard" DOM mapping for Lisp.
+  </p>
+  <p>
+    DOM is <a href="http://www.w3.org/TR/DOM-Level-2-Core/idl-definitions.html">specified
+      in CORBA IDL</a>, but it refrains from using object-oriented IDL
+    features, allowing for a much more natural Lisp implemenation than
+    the the ordinary IDL/Lisp mapping would.?
+    Differences between CXML's DOM and the direct IDL/Lisp mapping:
+  </p>
+  <ul>
+    <li>
+      DOM function names are symbols in the <tt>DOM</tt> package (not
+      the <tt>OP</tt> package).
+    </li>
+    <li>
+      DOM functions have proper required arguments, not a huge
+      <tt>&amp;rest</tt> lambda list.
+    </li>
+    <li>
+      Although most IDL interfaces are implemented as CLOS classes by
+      CXML, the Lisp types of DOM objects is not documented and cannot
+      be relied upon.? A node's type can be determined using
+      <tt>dom:node-type</tt> instead.
+    </li>
+    <li>
+      <tt>DOMString</tt> is mapped to <tt>rod</tt>, which is either
+      an <tt>(unsigned-byte 16)</tt> array type or a string type.
+    </li>
+    <li>
+      The IDL/Lisp mapping maps CORBA enums to Lisp keywords.?
+      Unfortunately, the DOM IDL does not use enums.? Instead,
+      both exception types and node types are defined integer
+      constants.? CXML chooses to ignore this definition and uses
+      keywords instead.
+    </li>
+    <li>
+      DOM uses StudlyCaps.? Lisp programmers don't.? We
+      insert <tt>#\-</tt> before every upper case letter preceded by a
+      lower case letter and before every upper case letter which is
+      followed by a lower case letter, but preceded by a capital
+      letter.? This algorithms leads to the natural Lisp spelling
+      of DOM function names.
+    </li>
+    <li>
+      Implementation note: DOM's <tt>NodeList</tt> does not
+      necessarily map to a native "sequence" type.? (For example,
+      node lists are objects in Java, not arrays.)?
+      <tt>NodeList</tt> is specified to reflect changes done after a
+      node list was created, so node lists cannot be Lisp lists.?
+      (A node list could be implemented as a CLOS object pointing to
+      said list though.)? Instead, CXML currently implements node
+      lists as adjustable vectors.? Note that code which relies on
+      this implementation and uses Lisp sequence functions
+      instead of sticking to <tt>dom:item</tt> and <tt>dom:length</tt>
+      is not portable.? As a compromise, you can use our
+      extensions <tt>dom:map-node-list</tt> or
+      <tt>dom:do-node-list</tt>, which can be implemented portably.
+    </li>
+  </ul>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/dom.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,150 @@
+<documentation title="CXML W3C DOM">
+  <h1>W3C DOM</h1>
+  <p>
+    CXML implements the DOM Level 2 Core interfaces.&#160; For details
+    on DOM, please refer to the <a
+				   href="http://www.w3.org/TR/DOM-Level-2-Core/core.html">specification</a>.
+  </p>
+
+  <a name="parser"/>
+  <h3>Parsing into DOM</h3>
+  <p>
+    To parse an XML document into a DOM tree, use the SAX parser with a
+    DOM builder as the SAX handler.  Example:
+  </p>
+  <pre>(cxml:parse-file "test.xml" (cxml-dom:make-dom-builder))</pre>
+  <p>
+    <div class="def">Function CXML-DOM:MAKE-DOM-BUILDER ()</div>
+    Create a SAX handler which builds a DOM document.
+    <p>
+    </p>
+    This functions returns a DOM builder that will work with the default
+    configuration of the SAX parser and is guaranteed to use
+    characters/strings instead of runes/rods, if that makes a
+    difference on the Lisp in question.
+    <p>
+    </p>
+    This is the same as <tt>rune-dom:make-dom-builder</tt> on Lisps
+    with Unicode support, and the same as
+    <tt>utf8-dom:make-dom-builder</tt> otherwise.
+  </p>
+
+  <p>
+    <div class="def">Function RUNE-DOM:MAKE-DOM-BUILDER ()</div>
+    Create a SAX handler which builds a DOM document using runes and rods.
+  </p>
+
+  <p>
+    <div class="def">Function UTF8-DOM:MAKE-DOM-BUILDER ()</div>
+    (Only on Lisps without Unicode support:)
+    Create a SAX handler which builds a DOM document using
+    UTF-8-encoded strings.
+  </p>
+
+  <a name="serialization"/>
+  <h3>Serializing DOM</h3>
+  <p>
+    To serialize a DOM document, use a SAX serialization sink as the
+    argument to <tt>dom:map-document</tt>, which generates SAX events
+    for the DOM tree.
+  </p>
+  <p>
+    Applications dealing with namespaces might want to inject a
+    <a href="sax.html#misc">namespace normalizer</a> into the
+    sink chain.
+  </p>
+  <p>
+    <div class="def">Function DOM:MAP-DOCUMENT (handler document &amp;key include-xmlns-attributes include-default-values include-doctype)</div>
+    Traverse a DOM document and call SAX functions as if an XML
+    representation of the document was processed by a SAX parser.
+  </p>
+  <p>Keyword arguments:</p>
+  <ul>
+    <li>
+      <tt>include-xmlns-attributes</tt> -- defaults to
+      <tt>sax:*include-xmlns-attributes*</tt>
+    </li>
+    <li>
+      <tt>include-doctype</tt> -- One of <tt>nil</tt> (no doctype
+      declaration), <tt>:full-internal-subset</tt> (include a doctype
+      declaration and the full internal subset), or
+      <tt>:canonical-notations</tt> (write a doctype declaration
+      with an internal subset including only notations, as required
+      for canonical serialization).
+    </li>
+    <li>
+      <tt>include-default-values</tt> -- include attribute nodes with nil
+      <tt>dom:specified</tt>.
+    </li>
+    <li>
+      <tt>recode</tt> -- (ignored on Lisps with Unicode support.) If
+      true, recode UTF-8 strings to rods.   Defaults to true if used
+      with a UTF-8 DOM document.  It can be set to false manually to
+      suppress recoding in this case.
+    </li>
+  </ul>
+
+  <a name="mapping"/>
+  <h3>DOM/Lisp mapping</h3>
+  <p>
+    Note that there is no "standard" DOM mapping for Lisp.
+  </p>
+  <p>
+    DOM is <a
+	      href="http://www.w3.org/TR/DOM-Level-2-Core/idl-definitions.html">specified
+      in CORBA IDL</a>, but it refrains from using object-oriented IDL
+    features, allowing for a much more natural Lisp implemenation than
+    the the ordinary IDL/Lisp mapping would.&#160;
+    Differences between CXML's DOM and the direct IDL/Lisp mapping:
+  </p>
+  <ul>
+    <li>
+      DOM function names are symbols in the <tt>DOM</tt> package (not
+      the <tt>OP</tt> package).
+    </li>
+    <li>
+      DOM functions have proper required arguments, not a huge
+      <tt>&amp;rest</tt> lambda list.
+    </li>
+    <li>
+      Although most IDL interfaces are implemented as CLOS classes by
+      CXML, the Lisp types of DOM objects is not documented and cannot
+      be relied upon.&#160; A node's type can be determined using
+      <tt>dom:node-type</tt> instead.
+    </li>
+    <li>
+      <tt>DOMString</tt> is mapped to <tt>rod</tt>, which is either
+      an <tt>(unsigned-byte 16)</tt> array type or a string type.
+    </li>
+    <li>
+      The IDL/Lisp mapping maps CORBA enums to Lisp keywords.&#160;
+      Unfortunately, the DOM IDL does not use enums.&#160; Instead,
+      both exception types and node types are defined integer
+      constants.&#160; CXML chooses to ignore this definition and uses
+      keywords instead.
+    </li>
+    <li>
+      DOM uses StudlyCaps.&#160; Lisp programmers don't.&#160; We
+      insert <tt>#\-</tt> before every upper case letter preceded by a
+      lower case letter and before every upper case letter which is
+      followed by a lower case letter, but preceded by a capital
+      letter.&#160; This algorithms leads to the natural Lisp spelling
+      of DOM function names.
+    </li>
+    <li>
+      Implementation note: DOM's <tt>NodeList</tt> does not
+      necessarily map to a native "sequence" type.&#160; (For example,
+      node lists are objects in Java, not arrays.)&#160;
+      <tt>NodeList</tt> is specified to reflect changes done after a
+      node list was created, so node lists cannot be Lisp lists.&#160;
+      (A node list could be implemented as a CLOS object pointing to
+      said list though.)&#160; Instead, CXML currently implements node
+      lists as adjustable vectors.&#160; Note that code which relies on
+      this implementation and uses Lisp sequence functions
+      instead of sticking to <tt>dom:item</tt> and <tt>dom:length</tt>
+      is not portable.&#160; As a compromise, you can use our
+      extensions <tt>dom:map-node-list</tt> or
+      <tt>dom:do-node-list</tt>, which can be implemented portably.
+    </li>
+  </ul>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/html.xsl
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/html.xsl	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,110 @@
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0">
+  <xsl:output method="html"
+	      indent="yes"
+	      doctype-public="-//W3C//DTD HTML 4.01 Transitional//EN"
+	      doctype-system="http://www.w3.org/TR/html4/loose.dtd"/>
+
+  <xsl:template match="@*|node()">
+    <xsl:copy>
+      <xsl:apply-templates select="@*|node()"/>
+    </xsl:copy>	
+  </xsl:template>
+
+  <xsl:template match="documentation">
+    <html>
+      <head>
+	<title>
+	  <xsl:value-of select="@title"/>
+	</title>
+	<link rel="stylesheet" type="text/css" href="cxml.css"/>
+	<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
+      </head>
+      <body>
+    <div class="sidebar">
+      <div class="sidebar-title">
+	<a href="index.html">Closure XML</a>
+      </div>
+      <div class="sidebar-main">
+      <ul class="main">
+	<li>
+          <a href="installation.html">Installing Closure XML</a>
+          <ul class="sub">
+	    <li><a href="installation.html#download"><b>Download</b></a></li>
+	    <li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+	    <li><a href="installation.html#compilation">Compilation</a></li>
+	    <li><a href="installation.html#tests">Tests</a></li>
+          </ul>
+	</li>
+        <li>
+          <ul class="hack">
+            <li>
+              <a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a>
+            </li>
+          </ul>
+        </li>
+	<li>
+          <a href="sax.html">SAX parsing and serialization</a>
+          <ul class="sub">
+            <li><a href="sax.html#parser">Parsing and Validating</a></li>
+            <li><a href="sax.html#serialization">Serialization</a></li>
+            <li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+            <li><a href="sax.html#rods">Recoders</a></li>
+            <li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+            <li><a href="sax.html#catalogs">XML Catalogs</a></li>
+	    <li><a href="sax.html#sax">SAX Interface</a></li>
+          </ul>
+	</li>
+	<li>
+          <a href="klacks.html">Klacks parser</a>
+          <ul class="sub">
+            <li><a href="klacks.html#sources">Parsing incrementally</a></li>
+            <li><a href="klacks.html#convenience">Convenience functions</a></li>
+            <li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+            <li><a href="klacks.html#locator">Location information</a></li>
+            <li><a href="klacks.html#klacksax">Examples</a></li>
+          </ul>
+        </li>
+	<li>
+          <a href="dom.html">DOM implementation</a>
+          <ul class="sub">
+            <li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+            <li><a href="dom.html#serialization">Serialization</a></li>
+	    <li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+          </ul>
+	</li>
+	<li>
+          <ul class="hack">
+            <li><a href="xmls-compat.html">XMLS Builder</a></li>
+          </ul>
+        </li>
+      </ul>
+      </div>
+    </div>
+	  <xsl:apply-templates/>
+      </body>
+    </html>
+  </xsl:template>
+
+  <xsl:template match="page-index">
+    <ul>
+      <xsl:for-each select="//heading">
+	<li>
+	  <a href="#{generate-id()}">
+	    <xsl:copy>
+	      <xsl:apply-templates select="node()"/>
+	    </xsl:copy>
+	  </a>
+	</li>
+      </xsl:for-each>
+    </ul>
+  </xsl:template>
+
+  <xsl:template match="heading">
+    <a name="{generate-id()}"/>
+    <h3>
+      <xsl:copy>
+	<xsl:apply-templates select="node()"/>
+      </xsl:copy>	
+    </h3>
+  </xsl:template>
+</xsl:stylesheet>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,256 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>Closure XML</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>Closure XML Parser</h1>
+
+    <p>An XML parser written in Common Lisp.</p>
+
+    <p>
+      Closure XML was written
+      by <a href="http://www.stud.uni-karlsruhe.de/~unk6/">Gilbert
+      Baumann</a> as part of the Closure web browser and is now
+      maintained by
+      <a href="mailto:david at lichteblau.com">David Lichteblau</a>.
+      It is licensed under Lisp-LGPL.
+    </p>      
+
+    <p>
+      CXML implements a <a href="http://www.w3.org/TR/REC-xml-names/">namespace-aware</a>,
+      validating <a href="http://www.w3.org/TR/2000/REC-xml-20001006">XML?1.0</a>
+      parser as well as the <a href="http://www.w3.org/TR/DOM-Level-2-Core/">DOM?Level?2?Core</a>
+      interfaces.  Two parser interfaces are offered, one SAX-like, the
+      other similar to StAX.
+    </p>
+
+    <p>
+      Send bug reports to <a href="mailto:cxml-devel at common-lisp.net">cxml-devel at common-lisp.net</a>
+      (<a href="http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel">list
+      information</a>).
+    </p>
+
+    <h3>Add-on features</h3>
+    <p>
+      The following libraries are available as separate downloads:
+    </p>
+    <p>
+      ??
+      <a href="http://www.lichteblau.com/cxml-rng/">cxml-rng</a>
+      ??
+      Relax NG validation
+    </p>
+    <p>
+      ??
+      <a href="http://www.lichteblau.com/cxml-stp/">cxml-stp</a>
+      ??
+      STP, an alternative to DOM
+    </p>
+    <p>
+      ??
+      <a href="http://common-lisp.net/project/closure/closure-html/">Closure
+      HTML</a>: cxml can be used together with its sister project
+      Closure HTML to convert between HTML and XHTML.
+    </p>
+
+
+    <a name="changes"></a>
+    <h3>Recent Changes</h3>
+    <div style="background-color: #f7f7f7;   width: 60%;   border: solid #9c0000;   margin: 0em 2pt 1em 2em;   padding: 1em">
+      Runes have now been moved into
+      a <b>separate CVS module</b> unter the
+      name <b>closure-common</b>.  Releases will be available
+      as <b>separate tarballs</b> in the download directory.  Please
+      refer to the <a href="installation.html#download">
+	installation instructions</a> for details.
+    </div>
+    <p class="nomargin"><tt>rel-2007-xx-yy</tt></p>
+    <ul class="nomargin">
+      <li>
+	Moved runes into a separate project.
+      </li>
+      <li>
+	Incompatible SAX changes: Added new classes
+	sax:abstract-handler, sax:content-handler, sax:default-handler.
+	Implementations of SAX handlers should now subclass one of
+	these classes.
+      </li>
+      <li>
+	fixed make-source :buffering nil, thanks to Magnus Henoch for
+	the report
+      </li>
+      <li>
+	fixed time and space usage in cases where entity references
+	follow each other (thanks to Ivan Shvedunov for the report)
+      </li>
+      <li>
+	In the DOM builder, grow a buffer for string normalization
+	exponentially, fixing a long-standing speed issue.
+      </li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-08-05</tt></p>
+    <ul class="nomargin">
+      <li>Various DTD serialization fixes</li>
+      <li>UTF-8 fix, thanks to Francis Leboutte</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-07-07</tt></p>
+    <ul class="nomargin">
+      <li>
+	Fixed build on non-Unicode lisps.  Fixed parsing on
+	non-Unicode lisps.  Fixed Unicode detection on OpenMCL.
+      </li>
+      <li>New function <tt>cxml:parse</tt>.</li>
+      <li>Serialization no longer defaults to canonical form.</li>
+      <li>Fixed octet array argument to make-source.</li>
+      <li>
+	XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+	XMLS any more.  There is now a mode using pairs of local name
+	and namespace URI, and a second mode using qualified names
+	only.  The old behaviour using pairs of prefix and local names
+	was removed.  (Thanks to Douglas Crosher.)
+      </li>
+      <li>
+	SCL support (thanks to Douglas Crosher).  Includes support for
+	implementations where URIs are valid namestrings, and a mode
+	where normal streams are used instead of xstreams and ystreams
+	(albeit both SCL-specific at this point).
+      </li>
+      <li>new convenience serialization function cxml:doctype.  Various
+	DTD serialization fixes.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-05-26</tt></p>
+    <ul class="nomargin">
+      <li>cxml.asd has been split up into <tt>cxml.asd</tt> for the
+      XML parser and <tt>runes.asd</tt> for the runes package, in
+      preparation of a complete split of the two systems.  Future CXML
+      releases will use separate tarballs for <tt>runes</tt>
+      and <tt>cxml</tt>.</li>
+      <li>xml:base support (SAX and Klacks only, not yet used in DOM).
+      See documentation <a href="sax.html#saxparser">here</a> and <a href="klacks.html#locator">here</a>.</li>
+      <li>New class <tt>broadcast-handler</tt> as a generalization
+      of the older <tt>sax-proxy</tt>.</li>
+      <li>New class <tt>tapping-source</tt>, a klacks source that
+      relays events from an upstream klacks source unchanged, while also
+      emitting them as SAX events to a user-specified handler at the
+      same time.</li>
+      <li>Changed attributes to carry an lname even when occurring
+      without a namespace.  Added new functions attribute*,
+      unparse-attribute, and macro with-element*, with-namespace* to
+      the SAX generation wrapper API.</li>
+      <li>Klacks improvements: Incompatibly changed
+      klacks:find-element and find-event to consider the current event
+      as a result.  Added klacks-error, klacks:expect, klacks:skip,
+      klacks:expecting-element.  Fixed serialize-event to generate
+      start-prefix-mapping and end-prefix-mapping events.  New function
+      map-current-namespace-declarations.</li>
+      <li>fixed build with common-lisp-controller</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-02-18</tt></p>
+    <ul class="nomargin">
+      <li>New StAX-like parser interface.</li>
+      <li>Serialization fixes (thanks to Nathan Bird, Donavon Keithley).</li>
+      <li>characters.lisp cleanup (thanks to Nathan Bird).</li>
+      <li>Namespace normalizer bugfixes.</li>
+      <li>Minor changes: clone-node on document as an extension.  DOM
+      class hierarchy reworked.  New function parse-empty-document.
+      Fixed the DOM serializer to not throw away local names.
+      Fixed a long-standing bug in the parser for documents without a
+      doctype. ANSI conformance fixes.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2006-01-05</tt></p>
+    <ul class="nomargin">
+      <li>Implemented DOM 2 Core.</li>
+      <li>Error handling overhaul.</li>
+      <li>UTF-8 string support in DOM on Lisps without Unicode characters.</li>
+      <li>Sink API has been changed.</li>
+      <li>Support internal subset serialization.</li>
+      <li>Whitespace normalizer.</li>
+      <li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li>
+      <li>Use trivial-gray-streams.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2005-06-25</tt></p>
+    <ul class="nomargin">
+      <li>Port to OpenMCL (thanks to Rudi Schlatte).</li>
+      <li>Port to LispWorks (thanks to Edi Weitz).</li>
+      <li>Minor new features: <tt>include-default-values</tt> argument to
+      <tt>make-xmls-builder</tt>; <tt>handler</tt> argument
+      to <tt>parse-dtd-stream</tt>; SAX proxy class</li>
+      <li>Various bugfixes.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-357</tt> (2004-10-10)</p>
+    <ul class="nomargin">
+      <li>Auto-detect unicode support for better asdf-installability.</li>
+      <li>Use the puri library for Sys-ID handling.</li>
+      <li>Semi-automatic caching of DTD instances.</li>
+      <li>Support user-defined entity resolvers.</li>
+      <li>Support for Oasis XML Catalogs.</li>
+      <li>xhtmlgen version of Franz htmlgen.</li>
+      <li>Fixes for SBCL's unicode support.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-306</tt> (2004-09-03)</p>
+    <ul class="nomargin">
+      <li>Event-based serialization which does not require DOM documents</li>
+      <li>XMLS compatiblity</li>
+      <li>minor bugfixes (thread safety; should work on clisp again)</li>
+    </ul>
+    <p class="nomargin"><tt>patch-279</tt> (2004-05-11)</p>
+    <ul class="nomargin">
+      <li>Validation</li>
+      <li>bugfixes; XHTML DTD parses again; corrected SAX entity handling</li>
+    </ul>
+    <p class="nomargin"><tt>patch-204</tt></p>
+    <ul class="nomargin">
+      <li>Renamed package <tt>XML</tt> to <tt>CXML</tt>.</li>
+      <li>The unparse functions support non-canonical output now.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-191</tt> (2004-03-18)</p>
+    <ul class="nomargin">
+      <li>Initial release.</li>
+    </ul>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/index.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,216 @@
+<documentation title="Closure XML">
+    <h1>Closure XML Parser</h1>
+
+    <p>An XML parser written in Common Lisp.</p>
+
+    <p>
+      Closure XML was written
+      by <a href="http://www.stud.uni-karlsruhe.de/~unk6/">Gilbert
+      Baumann</a> as part of the Closure web browser and is now
+      maintained by
+      <a href="mailto:david at lichteblau.com">David Lichteblau</a>.
+      It is licensed under Lisp-LGPL.
+    </p>      
+
+    <p>
+      CXML implements a <a
+      href="http://www.w3.org/TR/REC-xml-names/">namespace-aware</a>,
+      validating <a
+      href="http://www.w3.org/TR/2000/REC-xml-20001006">XML&#160;1.0</a>
+      parser as well as the <a
+      href="http://www.w3.org/TR/DOM-Level-2-Core/">DOM&#160;Level&#160;2&#160;Core</a>
+      interfaces.  Two parser interfaces are offered, one SAX-like, the
+      other similar to StAX.
+    </p>
+
+    <p>
+      Send bug reports to <a
+      href="mailto:cxml-devel at common-lisp.net">cxml-devel at common-lisp.net</a>
+      (<a
+      href="http://common-lisp.net/cgi-bin/mailman/listinfo/cxml-devel">list
+      information</a>).
+    </p>
+
+    <h3>Add-on features</h3>
+    <p>
+      The following libraries are available as separate downloads:
+    </p>
+    <p>
+      &#x2b17;&#160;
+      <a href="http://www.lichteblau.com/cxml-rng/">cxml-rng</a>
+      &#160;&#160;
+      Relax NG validation
+    </p>
+    <p>
+      &#x2b17;&#160;
+      <a href="http://www.lichteblau.com/cxml-stp/">cxml-stp</a>
+      &#160;&#160;
+      STP, an alternative to DOM
+    </p>
+    <p>
+      &#x2b17;&#160;
+      <a href="http://common-lisp.net/project/closure/closure-html/">Closure
+      HTML</a>: cxml can be used together with its sister project
+      Closure HTML to convert between HTML and XHTML.
+    </p>
+
+
+    <a name="changes"/>
+    <h3>Recent Changes</h3>
+    <div style="background-color: #f7f7f7;
+		width: 60%;
+		border: solid #9c0000;
+		margin: 0em 2pt 1em 2em;
+		padding: 1em">
+      Runes have now been moved into
+      a <b>separate CVS module</b> unter the
+      name <b>closure-common</b>.  Releases will be available
+      as <b>separate tarballs</b> in the download directory.  Please
+      refer to the <a href="installation.html#download">
+	installation instructions</a> for details.
+    </div>
+    <p class="nomargin"><tt>rel-2007-xx-yy</tt></p>
+    <ul class="nomargin">
+      <li>
+	Moved runes into a separate project.
+      </li>
+      <li>
+	Incompatible SAX changes: Added new classes
+	sax:abstract-handler, sax:content-handler, sax:default-handler.
+	Implementations of SAX handlers should now subclass one of
+	these classes.
+      </li>
+      <li>
+	fixed make-source :buffering nil, thanks to Magnus Henoch for
+	the report
+      </li>
+      <li>
+	fixed time and space usage in cases where entity references
+	follow each other (thanks to Ivan Shvedunov for the report)
+      </li>
+      <li>
+	In the DOM builder, grow a buffer for string normalization
+	exponentially, fixing a long-standing speed issue.
+      </li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-08-05</tt></p>
+    <ul class="nomargin">
+      <li>Various DTD serialization fixes</li>
+      <li>UTF-8 fix, thanks to Francis Leboutte</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-07-07</tt></p>
+    <ul class="nomargin">
+      <li>
+	Fixed build on non-Unicode lisps.  Fixed parsing on
+	non-Unicode lisps.  Fixed Unicode detection on OpenMCL.
+      </li>
+      <li>New function <tt>cxml:parse</tt>.</li>
+      <li>Serialization no longer defaults to canonical form.</li>
+      <li>Fixed octet array argument to make-source.</li>
+      <li>
+	XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+	XMLS any more.  There is now a mode using pairs of local name
+	and namespace URI, and a second mode using qualified names
+	only.  The old behaviour using pairs of prefix and local names
+	was removed.  (Thanks to Douglas Crosher.)
+      </li>
+      <li>
+	SCL support (thanks to Douglas Crosher).  Includes support for
+	implementations where URIs are valid namestrings, and a mode
+	where normal streams are used instead of xstreams and ystreams
+	(albeit both SCL-specific at this point).
+      </li>
+      <li>new convenience serialization function cxml:doctype.  Various
+	DTD serialization fixes.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-05-26</tt></p>
+    <ul class="nomargin">
+      <li>cxml.asd has been split up into <tt>cxml.asd</tt> for the
+      XML parser and <tt>runes.asd</tt> for the runes package, in
+      preparation of a complete split of the two systems.  Future CXML
+      releases will use separate tarballs for <tt>runes</tt>
+      and <tt>cxml</tt>.</li>
+      <li>xml:base support (SAX and Klacks only, not yet used in DOM).
+      See documentation <a href="sax.html#saxparser">here</a> and <a
+      href="klacks.html#locator">here</a>.</li>
+      <li>New class <tt>broadcast-handler</tt> as a generalization
+      of the older <tt>sax-proxy</tt>.</li>
+      <li>New class <tt>tapping-source</tt>, a klacks source that
+      relays events from an upstream klacks source unchanged, while also
+      emitting them as SAX events to a user-specified handler at the
+      same time.</li>
+      <li>Changed attributes to carry an lname even when occurring
+      without a namespace.  Added new functions attribute*,
+      unparse-attribute, and macro with-element*, with-namespace* to
+      the SAX generation wrapper API.</li>
+      <li>Klacks improvements: Incompatibly changed
+      klacks:find-element and find-event to consider the current event
+      as a result.  Added klacks-error, klacks:expect, klacks:skip,
+      klacks:expecting-element.  Fixed serialize-event to generate
+      start-prefix-mapping and end-prefix-mapping events.  New function
+      map-current-namespace-declarations.</li>
+      <li>fixed build with common-lisp-controller</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2007-02-18</tt></p>
+    <ul class="nomargin">
+      <li>New StAX-like parser interface.</li>
+      <li>Serialization fixes (thanks to Nathan Bird, Donavon Keithley).</li>
+      <li>characters.lisp cleanup (thanks to Nathan Bird).</li>
+      <li>Namespace normalizer bugfixes.</li>
+      <li>Minor changes: clone-node on document as an extension.  DOM
+      class hierarchy reworked.  New function parse-empty-document.
+      Fixed the DOM serializer to not throw away local names.
+      Fixed a long-standing bug in the parser for documents without a
+      doctype. ANSI conformance fixes.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2006-01-05</tt></p>
+    <ul class="nomargin">
+      <li>Implemented DOM 2 Core.</li>
+      <li>Error handling overhaul.</li>
+      <li>UTF-8 string support in DOM on Lisps without Unicode characters.</li>
+      <li>Sink API has been changed.</li>
+      <li>Support internal subset serialization.</li>
+      <li>Whitespace normalizer.</li>
+      <li>Gilbert Baumann has clarified the license as Lisp-LGPL.</li>
+      <li>Use trivial-gray-streams.</li>
+    </ul>
+    <p class="nomargin"><tt>rel-2005-06-25</tt></p>
+    <ul class="nomargin">
+      <li>Port to OpenMCL (thanks to Rudi Schlatte).</li>
+      <li>Port to LispWorks (thanks to Edi Weitz).</li>
+      <li>Minor new features: <tt>include-default-values</tt> argument to
+      <tt>make-xmls-builder</tt>; <tt>handler</tt> argument
+      to <tt>parse-dtd-stream</tt>; SAX proxy class</li>
+      <li>Various bugfixes.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-357</tt> (2004-10-10)</p>
+    <ul class="nomargin">
+      <li>Auto-detect unicode support for better asdf-installability.</li>
+      <li>Use the puri library for Sys-ID handling.</li>
+      <li>Semi-automatic caching of DTD instances.</li>
+      <li>Support user-defined entity resolvers.</li>
+      <li>Support for Oasis XML Catalogs.</li>
+      <li>xhtmlgen version of Franz htmlgen.</li>
+      <li>Fixes for SBCL's unicode support.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-306</tt> (2004-09-03)</p>
+    <ul class="nomargin">
+      <li>Event-based serialization which does not require DOM documents</li>
+      <li>XMLS compatiblity</li>
+      <li>minor bugfixes (thread safety; should work on clisp again)</li>
+    </ul>
+    <p class="nomargin"><tt>patch-279</tt> (2004-05-11)</p>
+    <ul class="nomargin">
+      <li>Validation</li>
+      <li>bugfixes; XHTML DTD parses again; corrected SAX entity handling</li>
+    </ul>
+    <p class="nomargin"><tt>patch-204</tt></p>
+    <ul class="nomargin">
+      <li>Renamed package <tt>XML</tt> to <tt>CXML</tt>.</li>
+      <li>The unparse functions support non-canonical output now.</li>
+    </ul>
+    <p class="nomargin"><tt>patch-191</tt> (2004-03-18)</p>
+    <ul class="nomargin">
+      <li>Initial release.</li>
+    </ul>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,156 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML Installation</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>Installation of Closure XML</h1>
+
+    <a name="download"></a>
+    <h2>Download</h2>
+    <ul>
+      <li>
+        <div>Download <a href="http://common-lisp.net/project/cxml/download/">tarballs</a> for both cxml itself and closure-common.</div>
+      </li>
+      <li>
+        <div>
+      Or use anonymous CVS (<a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cxml/?cvsroot=cxml">browse</a>):
+      <pre>export CVSROOT=:pserver:anonymous:anonymous at common-lisp.net:/project/cxml/cvsroot
+cvs co cxml
+cvs co closure-common</pre>
+        </div>
+      </li>
+    </ul>
+
+    <a name="implementations"></a>
+    <h2>Implementation-specific notes</h2>
+    <p>
+      CXML should be portable to all Common Lisp implementations
+      supported by <a href="http://common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
+    </p>
+    <ul>
+      <li>
+	The SBCL port uses 16 bit surrogate characters instead of taking
+	advantage of SBCL's full 21 bit character support.
+      </li>
+    </ul>
+
+    <a name="compilation"></a>
+    <h2>Compilation</h2>
+    <p>
+      <a href="http://www.cliki.net/asdf">ASDF</a> is used for
+      compilation.  The following instructions assume that ASDF has
+      already been loaded.
+    </p>
+
+    <p>
+      <b>Prerequisites.</b>
+      CXML needs <a href="http://www.cliki.net/Puri">puri</a> and
+      <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
+      In addition,
+      <a href="http://www.cliki.net/closure-common">closure-common</a>
+      is required, which is a separate module in cxml CVS (see above for
+      check-out instructions).
+    </p>
+
+    <p>
+      <b>Compiling and loading CXML.</b>
+      Register the .asd file, e.g. by symlinking it:
+    </p>
+    <pre>$ ln -sf `pwd`/cxml/cxml.asd /path/to/your/registry/
+$ ln -sf `pwd`/closure-common/closure-common.asd /path/to/your/registry/</pre>
+    <p>Then compile CXML using:</p>
+    <pre>* (asdf:operate 'asdf:load-op :cxml)</pre>
+
+    <p>
+      You can then try the <a href="quickstart.html">quick-start example</a>.
+    </p>
+
+    <a name="tests"></a>
+    <h2>Tests</h2>
+    <p>Check out the XML and DOM testsuites:</p>
+    <pre>$ export CVSROOT=:pserver:anonymous at dev.w3.org:/sources/public
+$ cvs login    # password is "anonymous"
+$ cvs co 2001/XML-Test-Suite/xmlconf
+$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite
+$ cd 2001/DOM-Test-Suite &amp;&amp; ant dom1-dtd dom2-dtd</pre>
+    <p>
+      Omit <tt>-D</tt> to get the latest version, which may not work
+      with cxml yet.  The <tt>ant</tt> step is necessary to run the DOM
+      tests.
+    </p>
+    <p>Usage:</p>
+    <pre>* (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/")
+* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/")
+</pre>
+    <p>
+      To compare your results with known output, refer to the files
+      <tt>XMLCONF</tt> and <tt>DOMTEST</tt> in the cxml distribution.
+    </p>
+
+    <p>
+      <i>fixme</i>: Add an explanation of xml/sax-tests here.
+    </p>
+
+    <p>
+      <b>fixme</b> domtest.lisp does not understand the current
+      testsuite driver anymore.? To fix this problem, revert the
+      affected files manually after check-out:
+    </p>
+
+    <pre>$ cd 2001/XML-Test-Suite/xmlconf/
+xmltest$ patch -p0 -R &lt;/path/to/cxml/test/xmlconf-base.diff</pre>
+
+    <p>
+      The log message for the changes reads "<i>Removed unnecessary
+      xml:base attribute</i>".? If I understand correctly, only
+      DOM?3 parsers provide the baseURI attribute necessary for
+      understanding <tt>xmlconf.xml</tt> now.? We don't have that
+      yet.
+    </p>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/installation.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,107 @@
+<documentation title="CXML Installation">
+    <h1>Installation of Closure XML</h1>
+
+    <a name="download"/>
+    <h2>Download</h2>
+    <ul>
+      <li>
+        <div>Download <a href="http://common-lisp.net/project/cxml/download/">tarballs</a> for both cxml itself and closure-common.</div>
+      </li>
+      <li>
+        <div>
+      Or use anonymous CVS (<a href="http://common-lisp.net/cgi-bin/viewcvs.cgi/cxml/?cvsroot=cxml">browse</a>):
+      <pre>export CVSROOT=:pserver:anonymous:anonymous at common-lisp.net:/project/cxml/cvsroot
+cvs co cxml
+cvs co closure-common</pre>
+        </div>
+      </li>
+    </ul>
+
+    <a name="implementations"/>
+    <h2>Implementation-specific notes</h2>
+    <p>
+      CXML should be portable to all Common Lisp implementations
+      supported by <a
+      href="http://common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
+    </p>
+    <ul>
+      <li>
+	The SBCL port uses 16 bit surrogate characters instead of taking
+	advantage of SBCL's full 21 bit character support.
+      </li>
+    </ul>
+
+    <a name="compilation"/>
+    <h2>Compilation</h2>
+    <p>
+      <a href="http://www.cliki.net/asdf">ASDF</a> is used for
+      compilation.  The following instructions assume that ASDF has
+      already been loaded.
+    </p>
+
+    <p>
+      <b>Prerequisites.</b>
+      CXML needs <a href="http://www.cliki.net/Puri">puri</a> and
+      <a href="http://www.common-lisp.net/project/cl-plus-ssl/#trivial-gray-streams">trivial-gray-streams</a>.
+      In addition,
+      <a href="http://www.cliki.net/closure-common">closure-common</a>
+      is required, which is a separate module in cxml CVS (see above for
+      check-out instructions).
+    </p>
+
+    <p>
+      <b>Compiling and loading CXML.</b>
+      Register the .asd file, e.g. by symlinking it:
+    </p>
+    <pre>$ ln -sf `pwd`/cxml/cxml.asd /path/to/your/registry/
+$ ln -sf `pwd`/closure-common/closure-common.asd /path/to/your/registry/</pre>
+    <p>Then compile CXML using:</p>
+    <pre>* (asdf:operate 'asdf:load-op :cxml)</pre>
+
+    <p>
+      You can then try the <a href="quickstart.html">quick-start example</a>.
+    </p>
+
+    <a name="tests"/>
+    <h2>Tests</h2>
+    <p>Check out the XML and DOM testsuites:</p>
+    <pre>$ export CVSROOT=:pserver:anonymous at dev.w3.org:/sources/public
+$ cvs login    # password is "anonymous"
+$ cvs co 2001/XML-Test-Suite/xmlconf
+$ cvs co -D '2005-05-06 23:00' 2001/DOM-Test-Suite
+$ cd 2001/DOM-Test-Suite &amp;&amp; ant dom1-dtd dom2-dtd</pre>
+    <p>
+      Omit <tt>-D</tt> to get the latest version, which may not work
+      with cxml yet.  The <tt>ant</tt> step is necessary to run the DOM
+      tests.
+    </p>
+    <p>Usage:</p>
+    <pre>* (xmlconf:run-all-tests "/path/to/2001/XML-Test-Suite/xmlconf/")
+* (domtest:run-all-tests "/path/to/2001/DOM-Test-Suite/")
+</pre>
+    <p>
+      To compare your results with known output, refer to the files
+      <tt>XMLCONF</tt> and <tt>DOMTEST</tt> in the cxml distribution.
+    </p>
+
+    <p>
+      <i>fixme</i>: Add an explanation of xml/sax-tests here.
+    </p>
+
+    <p>
+      <b>fixme</b> domtest.lisp does not understand the current
+      testsuite driver anymore.&#160; To fix this problem, revert the
+      affected files manually after check-out:
+    </p>
+
+    <pre>$ cd 2001/XML-Test-Suite/xmlconf/
+xmltest$ patch -p0 -R &lt;/path/to/cxml/test/xmlconf-base.diff</pre>
+
+    <p>
+      The log message for the changes reads "<i>Removed unnecessary
+      xml:base attribute</i>".&#160; If I understand correctly, only
+      DOM&#160;3 parsers provide the baseURI attribute necessary for
+      understanding <tt>xmlconf.xml</tt> now.&#160; We don't have that
+      yet.
+    </p>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,460 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML Klacks parser</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>Klacks parser</h1>
+    <p>
+      The Klacks parser provides an alternative parsing interface,
+      similar in concept to Java's <a href="http://jcp.org/en/jsr/detail?id=173">Streaming API for
+      XML</a> (StAX).
+    </p>
+    <p>
+      It implements a streaming, "pull-based" API.  This is different
+      from SAX, which is a "push-based" model.
+    </p>
+    <p>
+      Klacks is implemented using the same code base as the SAX parser
+      and has the same parsing characteristics (validation, namespace
+      support, entity resolution) while offering a more flexible interface
+      than SAX.
+    </p>
+    <p>
+      See below for <a href="#examples">examples</a>.
+    </p>
+
+    <a name="sources"></a>
+    <h3>Parsing incrementally using sources</h3>
+    <p>
+      To parse using Klacks, create an XML <tt>source</tt> first.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-SOURCE (input &amp;key validate
+      dtd root entity-resolver disallow-external-subset pathname)</div>
+      Create and return a source for <tt>input</tt>.
+    </p>
+    <p>
+      Exact behaviour depends on <tt>input</tt>, which can
+      be one of the following types:
+    </p>
+    <ul>
+      <li>
+	<tt>pathname</tt> -- a Common Lisp pathname.  
+	Open the file specified by the pathname and create a source for
+	the resulting stream.  See below for information on how to
+        close the stream.
+      </li>
+      <li>
+<tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt>.  See below for information on how to
+        close the stream.
+      </li>
+      <li>
+	<tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array.
+	The array is parsed directly, and interpreted according to the
+	encoding it specifies.
+      </li>
+      <li>
+	<tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on
+	unicode-capable implementations).
+	Parses an XML document from the input string that has already
+	undergone external-format decoding.
+      </li>
+    </ul>
+    <p>
+      <b>Closing streams:</b> Sources can refer to Lisp streams that
+      need to be closed after parsing.  This includes a stream passed
+      explicitly as <tt>input</tt>, a stream created implicitly for the
+      <tt>pathname</tt> case, as well as any streams created
+      automatically for external parsed entities referred to by the
+      document.
+    </p>
+    <p>
+      All these stream get closed automatically if end of file is
+      reached normally.  Use <tt>klacks:close-source</tt> or
+      <tt>klacks:with-open-source</tt> to ensure that the streams get
+      closed otherwise.
+    </p>
+    <p>
+      <b>Buffering:</b> By default, the Klacks parser performs buffering
+      of octets being read from the stream as an optimization.  This can
+      result in unwanted blocking if the stream is a socket and the
+      parser tries to read more data than required to parse the current
+      event.  Use <tt>:buffering nil</tt> to disable this optimization.
+    </p>
+    <ul>
+      <li>
+        <tt>buffering</tt> -- Boolean, defaults to <tt>t</tt>.  If
+        enabled, read data several kilobytes at time.  If disabled,
+        read only single bytes at a time.
+      </li>
+    </ul>
+    <p>
+      The following <b>keyword arguments</b> have the same meaning as
+      with the SAX parser, please refer to the documentation of <a href="sax.html#parser">parse-file</a> for more information:
+    </p>
+    <ul>
+      <li>
+        <tt>validate</tt>
+      </li>
+      <li>
+        <tt>dtd</tt>
+      </li>
+      <li>
+<tt>root</tt>
+      </li>
+      <li>
+        <tt>entity-resolver</tt>
+      </li>
+      <li>
+        <tt>disallow-internal-subset</tt>
+      </li>
+    </ul>
+    <p>
+      In addition, the following argument is for types of <tt>input</tt>
+      other than <tt>pathname</tt>:
+    </p>
+    <ul>
+      <li>
+        <tt>pathname</tt> -- If specified, defines the base URI of the
+        document based on this pathname instance.
+      </li>
+    </ul>
+
+    <p>
+      Events are read from the stream using the following functions:
+    </p>
+      <div class="def">Function KLACKS:PEEK (source)</div>
+     <p> =&gt; :start-document<br>
+          or =&gt; :start-document, version, encoding, standalonep<br>
+          or =&gt; :dtd, name, public-id, system-id<br>
+          or =&gt; :start-element, uri, lname, qname<br>
+          or =&gt; :end-element, uri, lname, qname<br>
+          or =&gt; :characters, data<br>
+          or =&gt; :processing-instruction, target, data<br>
+          or =&gt; :comment, data<br>
+          or =&gt; :end-document, data<br>
+          or =&gt; nil
+    </p>
+    <p>
+      <tt>peek</tt> returns the current event's key and main values.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:PEEK-NEXT (source) =&gt; key, value*</div>
+    </p>
+    <p>
+      Advance the source forward to the next event and returns it
+      like <tt>peek</tt> would.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:PEEK-VALUE (source) =&gt; value*</div>
+    </p>
+    <p>
+      Like <tt>peek</tt>, but return only the values, not the key.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CONSUME (source) =&gt; key, value*</div>
+    </p>
+    <p>
+      Return the same values <tt>peek</tt> would, and in addition
+      advance the source forward to the next event.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-URI (source) =&gt; uri</div>
+      <div class="def">Function KLACKS:CURRENT-LNAME (source) =&gt; string</div>
+      <div class="def">Function KLACKS:CURRENT-QNAME (source) =&gt; string</div>
+    </p>
+    <p>
+     If the current event is :start-element or :end-element, return the
+     corresponding value.  Else, signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-CHARACTERS (source) =&gt; string</div>
+    </p>
+    <p>
+     If the current event is :characters, return the character data
+     value.  Else, signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-CDATA-SECTION-P (source) =&gt; boolean</div>
+    </p>
+    <p>
+     If the current event is :characters, determine whether the data was
+     specified using a CDATA section in the source document.  Else,
+     signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:MAP-CURRENT-NAMESPACE-DECLARATIONS (fn source) =&gt; nil</div>
+    </p>
+    <p>
+     For use only on :start-element and :end-element events, this
+     function report every namespace declaration on the current element.
+     On :start-element, these correspond to the xmlns attributes of the
+     start tag.  On :end-element, the declarations of the corresponding
+     start tag are reported.  No inherited namespaces are
+     included.  <tt>fn</tt> is called only for each declaration with two
+     arguments, the prefix and uri.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:MAP-ATTRIBUTES (fn source)</div>
+    </p>
+    <p>
+     Call <tt>fn</tt> for each attribute of the current start tag in
+     turn, and pass the following values as arguments to the function:
+	<ul>
+	  <li>namespace uri</li>
+	  <li>local name</li>
+	  <li>qualified name</li>
+	  <li>attribute value</li>
+	  <li>a boolean indicating whether the attribute was specified
+	  explicitly in the source document, rather than defaulted from
+	  a DTD</li>
+	</ul>
+     Only valid for :start-element.
+    </p>
+    <p>
+     Return a list of SAX attribute structures for the current start tag.
+     Only valid for :start-element.
+    </p>
+
+    <p>
+      <div class="def">Function KLACKS:CLOSE-SOURCE (source)</div>
+      Close all streams referred to by <tt>source</tt>.
+    </p>
+    <p>
+      <div class="def">Macro KLACKS:WITH-OPEN-SOURCE ((var source) &amp;body body)</div>
+      Evaluate <tt>source</tt> to create a source object, bind it to
+      symbol <tt>var</tt> and evaluate <tt>body</tt> as an implicit progn.
+      Call <tt>klacks:close-source</tt> to close the source after
+      exiting <tt>body</tt>, whether normally or abnormally.
+    </p>
+
+    <a name="convenience"></a>
+    <h3>Convenience functions</h3>
+    <p>
+      <div class="def">Function KLACKS:FIND-EVENT (source key)</div>
+      Read events from <tt>source</tt> and discard them until an event
+      of type <i>key</i> is found.  Return values like <tt>peek</tt>, or
+      NIL if no such event was found.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:FIND-ELEMENT (source &amp;optional
+      lname uri)</div>
+      Read events from <tt>source</tt> and discard them until an event
+      of type :start-element is found with matching local name and
+      namespace uri is found.   If <tt>lname</tt> is <tt>nil</tt>, any
+      tag name matches.  If <tt>uri</tt> is <tt>nil</tt>, any
+      namespace matches. Return values like <tt>peek</tt> or NIL if no
+      such event was found.
+    </p>
+    <p>
+      <div class="def">Condition KLACKS:KLACKS-ERROR (xml-parse-error)</div>
+      The condition class signalled by <tt>expect</tt>.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:EXPECT (source key &amp;optional
+      value1 value2 value3)</div>
+      Assert that the current event is equal to (key value1 value2
+      value3).  (Ignore <i>value</i> arguments that are NIL.)  If so,
+      return it as multiple values.  Otherwise signal a
+      <tt>klacks-error</tt>.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SKIP (source key &amp;optional
+      value1 value2 value3)</div>
+      <tt>expect</tt> the specific event, then <tt>consume</tt> it.
+    </p>
+    <p>
+      <div class="def">Macro KLACKS:EXPECTING-ELEMENT ((fn source
+      &amp;optional lname uri) &amp;body body</div>
+      Assert that the current event matches (:start-element uri lname).
+      (Ignore <i>value</i> arguments that are NIL)  Otherwise signal a
+      <tt>klacks-error</tt>.
+      Evaluate <tt>body</tt> as an implicit progn.  Finally assert that
+      the remaining event matches (:end-element uri lname).
+    </p>
+
+    <a name="klacksax"></a>
+    <h3>Bridging Klacks and SAX</h3>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-EVENT (source handler)</div>
+      Send the current klacks event from <tt>source</tt> as a SAX
+      event to the SAX <tt>handler</tt> and consume it.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-ELEMENT (source handler
+      &amp;key document-events)</div>
+      Read all klacks events from the following <tt>:start-element</tt> to
+      its <tt>:end-element</tt> and send them as SAX events
+      to <tt>handler</tt>.  When this function is called, the current
+      event must be <tt>:start-element</tt>, else an error is
+      signalled.  With <tt>document-events</tt> (the default),
+      <tt>sax:start-document</tt> and <tt>sax:end-document</tt> events
+      are sent around the element.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-SOURCE (source handler)</div>
+      Read all klacks events from <tt>source</tt> and send them as SAX
+      events to the SAX <tt>handler</tt>.
+    </p>
+    <p>
+      <div class="def">Class KLACKS:TAPPING-SOURCE (source)</div>
+      A klacks source that relays events from an upstream klacks source
+      unchanged, while also emitting them as SAX events to a
+      user-specified handler at the same time.
+    </p>
+    <p>
+      <div class="def">Functon KLACKS:MAKE-TAPPING-SOURCE
+      (upstream-source &amp;optional sax-handler)</div>
+      Create a tapping source relaying events
+      for <tt>upstream-source</tt>, and sending SAX events
+      to <tt>sax-handler</tt>.
+    </p>
+
+    <a name="locator"></a>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-LINE-NUMBER (source)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-COLUMN-NUMBER (source)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-SYSTEM-ID (source)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-XML-BASE (source)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>current-system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
+    <a name="examples"></a>
+    <h3>Examples</h3>
+    <p>
+      The following example illustrates creation of a klacks <tt>source</tt>,
+      use of the <tt>peek-next</tt> function to read individual events,
+      and shows some of the most common event types.
+    </p>
+    <pre>* <b>(defparameter *source* (cxml:make-source "&lt;example&gt;text&lt;/example&gt;"))</b>
+*SOURCE*
+
+* <b>(klacks:peek-next *source*)</b>
+:START-DOCUMENT
+
+* <b>(klacks:peek-next *source*)</b>
+:START-ELEMENT
+NIL                      ;namespace URI
+"example"                ;local name
+"example"                ;qualified name
+
+* <b>(klacks:peek-next *source*)</b>
+:CHARACTERS
+"text"
+
+* <b>(klacks:peek-next *source*)</b>
+:END-ELEMENT
+NIL
+"example"
+"example"
+
+* <b>(klacks:peek-next *source*)</b>
+:END-DOCUMENT
+
+* <b>(klacks:peek-next *source*)</b>
+NIL</pre>
+
+    <p>
+      In this example, <tt>find-element</tt> is used to skip over the
+      uninteresting events until the opening <tt>child1</tt> tag is
+      found.  Then <tt>serialize-element</tt> is used to generate SAX
+      events for the following element, including its children, and an
+      xmls-compatible list structure is built from those
+      events.  <tt>find-element</tt> skips over whitespace,
+      and <tt>find-event</tt> is used to parse up
+      to <tt>:end-document</tt>, ensuring that the source has been
+      closed.
+    </p>
+    <pre>* <b>(defparameter *source*
+      (cxml:make-source "&lt;example&gt;
+                           &lt;child1&gt;&lt;p&gt;foo&lt;/p&gt;&lt;/child1&gt;
+                           &lt;child2 bar='baz'/&gt;
+                         &lt;/example&gt;"))</b>
+*SOURCE*
+
+* <b>(klacks:find-element *source* "child1")</b>
+:START-ELEMENT
+NIL
+"child1"
+"child1"
+
+* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b>
+("child1" NIL ("p" NIL "foo"))
+
+* <b>(klacks:find-element *source*)</b>
+:START-ELEMENT
+NIL
+"child2"
+"child2"
+
+*  <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b>
+("child2" (("bar" "baz")))
+
+* <b>(klacks:find-event *source* :end-document)</b>
+:END-DOCUMENT
+NIL
+NIL
+NIL
+</pre>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/klacks.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,410 @@
+<documentation title="CXML Klacks parser">
+    <h1>Klacks parser</h1>
+    <p>
+      The Klacks parser provides an alternative parsing interface,
+      similar in concept to Java's <a
+      href="http://jcp.org/en/jsr/detail?id=173">Streaming API for
+      XML</a> (StAX).
+    </p>
+    <p>
+      It implements a streaming, "pull-based" API.  This is different
+      from SAX, which is a "push-based" model.
+    </p>
+    <p>
+      Klacks is implemented using the same code base as the SAX parser
+      and has the same parsing characteristics (validation, namespace
+      support, entity resolution) while offering a more flexible interface
+      than SAX.
+    </p>
+    <p>
+      See below for <a href="#examples">examples</a>.
+    </p>
+
+    <a name="sources"/>
+    <h3>Parsing incrementally using sources</h3>
+    <p>
+      To parse using Klacks, create an XML <tt>source</tt> first.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-SOURCE (input &amp;key validate
+      dtd root entity-resolver disallow-external-subset pathname)</div>
+      Create and return a source for <tt>input</tt>.
+    </p>
+    <p>
+      Exact behaviour depends on <tt>input</tt>, which can
+      be one of the following types:
+    </p>
+    <ul>
+      <li>
+	<tt>pathname</tt> -- a Common Lisp pathname.  
+	Open the file specified by the pathname and create a source for
+	the resulting stream.  See below for information on how to
+        close the stream.
+      </li>
+      <li><tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt>.  See below for information on how to
+        close the stream.
+      </li>
+      <li>
+	<tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array.
+	The array is parsed directly, and interpreted according to the
+	encoding it specifies.
+      </li>
+      <li>
+	<tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on
+	unicode-capable implementations).
+	Parses an XML document from the input string that has already
+	undergone external-format decoding.
+      </li>
+    </ul>
+    <p>
+      <b>Closing streams:</b> Sources can refer to Lisp streams that
+      need to be closed after parsing.  This includes a stream passed
+      explicitly as <tt>input</tt>, a stream created implicitly for the
+      <tt>pathname</tt> case, as well as any streams created
+      automatically for external parsed entities referred to by the
+      document.
+    </p>
+    <p>
+      All these stream get closed automatically if end of file is
+      reached normally.  Use <tt>klacks:close-source</tt> or
+      <tt>klacks:with-open-source</tt> to ensure that the streams get
+      closed otherwise.
+    </p>
+    <p>
+      <b>Buffering:</b> By default, the Klacks parser performs buffering
+      of octets being read from the stream as an optimization.  This can
+      result in unwanted blocking if the stream is a socket and the
+      parser tries to read more data than required to parse the current
+      event.  Use <tt>:buffering nil</tt> to disable this optimization.
+    </p>
+    <ul>
+      <li>
+        <tt>buffering</tt> -- Boolean, defaults to <tt>t</tt>.  If
+        enabled, read data several kilobytes at time.  If disabled,
+        read only single bytes at a time.
+      </li>
+    </ul>
+    <p>
+      The following <b>keyword arguments</b> have the same meaning as
+      with the SAX parser, please refer to the documentation of <a
+      href="sax.html#parser">parse-file</a> for more information:
+    </p>
+    <ul>
+      <li>
+        <tt>validate</tt>
+      </li>
+      <li>
+        <tt>dtd</tt>
+      </li>
+      <li><tt>root</tt>
+      </li>
+      <li>
+        <tt>entity-resolver</tt>
+      </li>
+      <li>
+        <tt>disallow-internal-subset</tt>
+      </li>
+    </ul>
+    <p>
+      In addition, the following argument is for types of <tt>input</tt>
+      other than <tt>pathname</tt>:
+    </p>
+    <ul>
+      <li>
+        <tt>pathname</tt> -- If specified, defines the base URI of the
+        document based on this pathname instance.
+      </li>
+    </ul>
+
+    <p>
+      Events are read from the stream using the following functions:
+    </p>
+      <div class="def">Function KLACKS:PEEK (source)</div>
+     <p> => :start-document<br/>
+          or => :start-document, version, encoding, standalonep<br/>
+          or => :dtd, name, public-id, system-id<br/>
+          or => :start-element, uri, lname, qname<br/>
+          or => :end-element, uri, lname, qname<br/>
+          or => :characters, data<br/>
+          or => :processing-instruction, target, data<br/>
+          or => :comment, data<br/>
+          or => :end-document, data<br/>
+          or => nil
+    </p>
+    <p>
+      <tt>peek</tt> returns the current event's key and main values.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:PEEK-NEXT (source) => key, value*</div>
+    </p>
+    <p>
+      Advance the source forward to the next event and returns it
+      like <tt>peek</tt> would.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:PEEK-VALUE (source) => value*</div>
+    </p>
+    <p>
+      Like <tt>peek</tt>, but return only the values, not the key.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CONSUME (source) => key, value*</div>
+    </p>
+    <p>
+      Return the same values <tt>peek</tt> would, and in addition
+      advance the source forward to the next event.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-URI (source) => uri</div>
+      <div class="def">Function KLACKS:CURRENT-LNAME (source) => string</div>
+      <div class="def">Function KLACKS:CURRENT-QNAME (source) => string</div>
+    </p>
+    <p>
+     If the current event is :start-element or :end-element, return the
+     corresponding value.  Else, signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-CHARACTERS (source) => string</div>
+    </p>
+    <p>
+     If the current event is :characters, return the character data
+     value.  Else, signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-CDATA-SECTION-P (source) => boolean</div>
+    </p>
+    <p>
+     If the current event is :characters, determine whether the data was
+     specified using a CDATA section in the source document.  Else,
+     signal an error.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:MAP-CURRENT-NAMESPACE-DECLARATIONS (fn source) => nil</div>
+    </p>
+    <p>
+     For use only on :start-element and :end-element events, this
+     function report every namespace declaration on the current element.
+     On :start-element, these correspond to the xmlns attributes of the
+     start tag.  On :end-element, the declarations of the corresponding
+     start tag are reported.  No inherited namespaces are
+     included.  <tt>fn</tt> is called only for each declaration with two
+     arguments, the prefix and uri.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:MAP-ATTRIBUTES (fn source)</div>
+    </p>
+    <p>
+     Call <tt>fn</tt> for each attribute of the current start tag in
+     turn, and pass the following values as arguments to the function:
+	<ul>
+	  <li>namespace uri</li>
+	  <li>local name</li>
+	  <li>qualified name</li>
+	  <li>attribute value</li>
+	  <li>a boolean indicating whether the attribute was specified
+	  explicitly in the source document, rather than defaulted from
+	  a DTD</li>
+	</ul>
+     Only valid for :start-element.
+    </p>
+    <p>
+     Return a list of SAX attribute structures for the current start tag.
+     Only valid for :start-element.
+    </p>
+
+    <p>
+      <div class="def">Function KLACKS:CLOSE-SOURCE (source)</div>
+      Close all streams referred to by <tt>source</tt>.
+    </p>
+    <p>
+      <div class="def">Macro KLACKS:WITH-OPEN-SOURCE ((var source) &amp;body body)</div>
+      Evaluate <tt>source</tt> to create a source object, bind it to
+      symbol <tt>var</tt> and evaluate <tt>body</tt> as an implicit progn.
+      Call <tt>klacks:close-source</tt> to close the source after
+      exiting <tt>body</tt>, whether normally or abnormally.
+    </p>
+
+    <a name="convenience"/>
+    <h3>Convenience functions</h3>
+    <p>
+      <div class="def">Function KLACKS:FIND-EVENT (source key)</div>
+      Read events from <tt>source</tt> and discard them until an event
+      of type <i>key</i> is found.  Return values like <tt>peek</tt>, or
+      NIL if no such event was found.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:FIND-ELEMENT (source &amp;optional
+      lname uri)</div>
+      Read events from <tt>source</tt> and discard them until an event
+      of type :start-element is found with matching local name and
+      namespace uri is found.   If <tt>lname</tt> is <tt>nil</tt>, any
+      tag name matches.  If <tt>uri</tt> is <tt>nil</tt>, any
+      namespace matches. Return values like <tt>peek</tt> or NIL if no
+      such event was found.
+    </p>
+    <p>
+      <div class="def">Condition KLACKS:KLACKS-ERROR (xml-parse-error)</div>
+      The condition class signalled by <tt>expect</tt>.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:EXPECT (source key &amp;optional
+      value1 value2 value3)</div>
+      Assert that the current event is equal to (key value1 value2
+      value3).  (Ignore <i>value</i> arguments that are NIL.)  If so,
+      return it as multiple values.  Otherwise signal a
+      <tt>klacks-error</tt>.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SKIP (source key &amp;optional
+      value1 value2 value3)</div>
+      <tt>expect</tt> the specific event, then <tt>consume</tt> it.
+    </p>
+    <p>
+      <div class="def">Macro KLACKS:EXPECTING-ELEMENT ((fn source
+      &amp;optional lname uri) &amp;body body</div>
+      Assert that the current event matches (:start-element uri lname).
+      (Ignore <i>value</i> arguments that are NIL)  Otherwise signal a
+      <tt>klacks-error</tt>.
+      Evaluate <tt>body</tt> as an implicit progn.  Finally assert that
+      the remaining event matches (:end-element uri lname).
+    </p>
+
+    <a name="klacksax"/>
+    <h3>Bridging Klacks and SAX</h3>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-EVENT (source handler)</div>
+      Send the current klacks event from <tt>source</tt> as a SAX
+      event to the SAX <tt>handler</tt> and consume it.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-ELEMENT (source handler
+      &amp;key document-events)</div>
+      Read all klacks events from the following <tt>:start-element</tt> to
+      its <tt>:end-element</tt> and send them as SAX events
+      to <tt>handler</tt>.  When this function is called, the current
+      event must be <tt>:start-element</tt>, else an error is
+      signalled.  With <tt>document-events</tt> (the default),
+      <tt>sax:start-document</tt> and <tt>sax:end-document</tt> events
+      are sent around the element.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:SERIALIZE-SOURCE (source handler)</div>
+      Read all klacks events from <tt>source</tt> and send them as SAX
+      events to the SAX <tt>handler</tt>.
+    </p>
+    <p>
+      <div class="def">Class KLACKS:TAPPING-SOURCE (source)</div>
+      A klacks source that relays events from an upstream klacks source
+      unchanged, while also emitting them as SAX events to a
+      user-specified handler at the same time.
+    </p>
+    <p>
+      <div class="def">Functon KLACKS:MAKE-TAPPING-SOURCE
+      (upstream-source &amp;optional sax-handler)</div>
+      Create a tapping source relaying events
+      for <tt>upstream-source</tt>, and sending SAX events
+      to <tt>sax-handler</tt>.
+    </p>
+
+    <a name="locator"/>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-LINE-NUMBER (source)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-COLUMN-NUMBER (source)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-SYSTEM-ID (source)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function KLACKS:CURRENT-XML-BASE (source)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>current-system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
+    <a name="examples"/>
+    <h3>Examples</h3>
+    <p>
+      The following example illustrates creation of a klacks <tt>source</tt>,
+      use of the <tt>peek-next</tt> function to read individual events,
+      and shows some of the most common event types.
+    </p>
+    <pre>* <b>(defparameter *source* (cxml:make-source "&lt;example>text&lt;/example>"))</b>
+*SOURCE*
+
+* <b>(klacks:peek-next *source*)</b>
+:START-DOCUMENT
+
+* <b>(klacks:peek-next *source*)</b>
+:START-ELEMENT
+NIL                      ;namespace URI
+"example"                ;local name
+"example"                ;qualified name
+
+* <b>(klacks:peek-next *source*)</b>
+:CHARACTERS
+"text"
+
+* <b>(klacks:peek-next *source*)</b>
+:END-ELEMENT
+NIL
+"example"
+"example"
+
+* <b>(klacks:peek-next *source*)</b>
+:END-DOCUMENT
+
+* <b>(klacks:peek-next *source*)</b>
+NIL</pre>
+
+    <p>
+      In this example, <tt>find-element</tt> is used to skip over the
+      uninteresting events until the opening <tt>child1</tt> tag is
+      found.  Then <tt>serialize-element</tt> is used to generate SAX
+      events for the following element, including its children, and an
+      xmls-compatible list structure is built from those
+      events.  <tt>find-element</tt> skips over whitespace,
+      and <tt>find-event</tt> is used to parse up
+      to <tt>:end-document</tt>, ensuring that the source has been
+      closed.
+    </p>
+    <pre>* <b>(defparameter *source*
+      (cxml:make-source "&lt;example>
+                           &lt;child1>&lt;p>foo&lt;/p>&lt;/child1>
+                           &lt;child2 bar='baz'/>
+                         &lt;/example>"))</b>
+*SOURCE*
+
+* <b>(klacks:find-element *source* "child1")</b>
+:START-ELEMENT
+NIL
+"child1"
+"child1"
+
+* <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b>
+("child1" NIL ("p" NIL "foo"))
+
+* <b>(klacks:find-element *source*)</b>
+:START-ELEMENT
+NIL
+"child2"
+"child2"
+
+*  <b>(klacks:serialize-element *source* (cxml-xmls:make-xmls-builder))</b>
+("child2" (("bar" "baz")))
+
+* <b>(klacks:find-event *source* :end-document)</b>
+:END-DOCUMENT
+NIL
+NIL
+NIL
+</pre>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,312 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML Quick-Start Example</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>Quick-Start Example / FAQ</h1>
+
+    <p>
+      Make sure to <a href="installation.html#installation">install and load</a> cxml first.
+    </p>
+
+    <h3>
+      On this page
+    </h3>      
+    <ul>
+<li><a href="#id53435"><heading>Parsing a file</heading></a></li>
+<li><a href="#id54079"><heading>Using DOM</heading></a></li>
+<li><a href="#id54112"><heading>Serializing DOM</heading></a></li>
+<li><a href="#id54132"><heading>Parsing into XMLS-like lists</heading></a></li>
+<li><a href="#id54176"><heading>Parsing incrementally using Klacks</heading></a></li>
+<li><a href="#id54210"><heading>Writing XML</heading></a></li>
+<li><a href="#id54235"><heading>Help! CXML says 'URI scheme :HTTP not supported'</heading></a></li>
+<li><a href="#id54302"><heading>Loading DTDs from local files</heading></a></li>
+<li><a href="#id54328"><heading>Can I skip loading of DTDs entirely?</heading></a></li>
+<li><a href="#id54364"><heading>
+      Catalogs: How can I use the HTML DTD installed by my distribution?
+    </heading></a></li>
+<li><a href="#id54390"><heading>
+      Can I load DTDs through HTTP?
+    </heading></a></li>
+</ul>
+    
+    <p>
+      To try the following examples, create a test file
+      called <tt>example.xml</tt>:
+    </p>
+    <pre>* <b>(with-open-file (s "example.xml" :direction :output)
+    (write-string "&lt;test a='b'&gt;&lt;child/&gt;&lt;/test&gt;" s))</b></pre>
+
+    <a name="id53435"></a><h3><heading>Parsing a file</heading></h3>
+
+    <p>Parse <tt>example.xml</tt> into a DOM tree (<a href="sax.html#parser">read
+    more</a>):</p>
+    <pre>* <b>(cxml:parse-file "example.xml" (cxml-dom:make-dom-builder))</b>
+#&lt;DOM-IMPL::DOCUMENT @ #x72206172&gt;
+
+;; save result for later:
+* <b>(defparameter *example* *)</b>
+*EXAMPLE*</pre>
+
+    <a name="id54079"></a><h3><heading>Using DOM</heading></h3>
+
+    <p>Inspect the DOM tree (<a href="sax.html#dom">read more</a>):</p>
+    <pre>* <b>(dom:document-element *example*)</b>
+#&lt;DOM-IMPL::ELEMENT test @ #x722b6ba2&gt;
+
+* (<b>dom:tag-name</b> (dom:document-element *example*))
+"test"
+
+* (<b>dom:child-nodes</b> (dom:document-element *example*))
+#(#&lt;DOM-IMPL::ELEMENT child @ #x722b6d8a&gt;)
+
+* (<b>dom:get-attribute</b> (dom:document-element *example*) <b>"a"</b>)
+"b"</pre>
+
+    <a name="id54112"></a><h3><heading>Serializing DOM</heading></h3>
+
+    <p>Serialize the DOM document back into a file (<a href="sax.html#serialization">read more</a>):</p>
+    <pre>(with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8))
+  <b>(dom:map-document (cxml:make-octet-stream-sink out) *example*)</b></pre>
+
+    <a name="id54132"></a><h3><heading>Parsing into XMLS-like lists</heading></h3>
+
+    <p>
+      If DOM is not the representation you want to you, parsing into
+      other data structures is possible using the same SAX parser
+      function, while using a different handler.
+      The XMLS builder is included for compatibility with XMLS, and also
+      also sample code (see cxml/xml/xmls-compat.lisp) for your own
+      handlers.
+    </p>
+
+    <p>As an alternative to DOM, parse into xmls-compatible list
+    structure (<a href="xmls-compat.html">read more</a>):</p>
+    <pre>* <b>(cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))</b>
+("test" (("a" "b")) ("child" NIL))</pre>
+
+    <p>
+      Again, serialization into XML is done using a sink as a SAX
+      handler and a data-structure specific function to generate SAX
+      events for the document, in this case <tt>cxml-xmls:map-node</tt>.
+    </p>
+
+    <pre>* (with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8))
+    (<b>cxml-xmls:map-node (cxml:make-octet-stream-sink out)
+                        '("test" (("a" "b")) ("child" nil)))</b>)</pre>
+
+    <a name="id54176"></a><h3><heading>Parsing incrementally using Klacks</heading></h3>
+
+    <p>Use klacks to read events from the parser incrementally.  The
+    following example looks only for :start-element and :end-element
+    events and prints them (<a href="klacks.html">read more</a>):</p>
+    <pre>* <b>(klacks:with-open-source
+    (s (cxml:make-source #p"example.xml"))</b>
+  (loop
+      for key = <b>(klacks:peek s)</b>
+      while key
+      do
+	(case key
+	  (:start-element
+	    (format t "~A {" <b>(klacks:current-qname s)</b>))
+	  (:end-element
+	    (format t "}")))
+	<b>(klacks:consume s)</b>))
+test {child {}}</pre>
+
+    <a name="id54210"></a><h3><heading>Writing XML</heading></h3>
+
+    <p>
+      Serialization is always done using sinks, which accept SAX events,
+      but there are convenience functions and macros to make that easier
+      to use:
+    </p>
+    <pre>(cxml:with-xml-output (cxml:make-octet-stream-sink stream :indentation 2 :canonical nil)
+  (cxml:with-element "foo"
+    (cxml:attribute "xyz" "abc")
+    (cxml:with-element "bar"
+      (cxml:attribute "blub" "bla"))
+    (cxml:text "Hi there.")))</pre>
+   <p>
+      Prints this to <tt>stream</tt>:
+   </p>
+   <pre>&lt;foo xyz="abc"&gt;
+  &lt;bar blub="bla"&gt;&lt;/bar&gt;
+  Hi there.
+&lt;/foo&gt;</pre>
+    
+    <a name="id54235"></a><h3><heading>Help! CXML says 'URI scheme :HTTP not supported'</heading></h3>
+
+    <p>
+      By default, this error will occur when the DTD (or generally, any
+      entity) has an http:// URL as its system ID.  CXML itself
+      understands only file:// URLs, but allows users to customize the
+      behaviour for all URLs.
+    </p>
+
+    <p>
+      The are several solutions to this, covered in detail below:
+      <ul>
+	<li>
+	  Load the DTD/entity from local files using an entity resolver
+	</li>
+	<li>
+	  Skip parsing of the DTD/entity entirely by pretending it is
+	  empty, again using an entity resolver.
+	</li>
+	<li>
+	  Use a <em>catalog</em> to make CXML find DTDs in the local
+	  filesystem automatically.
+	</li>
+	<li>
+	  Teach CXML actually load DTDs using HTTP.
+	</li>
+      </ul>
+    </p>
+
+    <p>
+      Here are the example files for the following solutions to this
+      problem:
+    </p>
+
+    <a href="http://www.lichteblau.com/blubba/dtdexample.xml">
+      <tt>dtdexample.xml</tt>:</a>
+    <pre>&lt;!DOCTYPE test SYSTEM 'http://www.lichteblau.com/blubba/dtdexample.dtd'&gt;
+&lt;test a='b'&gt;blub&lt;child/&gt;&lt;/test&gt;</pre>
+    
+    <a href="http://www.lichteblau.com/blubba/dtdexample.dtd">
+      <tt>dtdexample.dtd</tt></a>:
+    <pre>&lt;!ELEMENT test (#PCDATA|child)*&gt;
+&lt;!ATTLIST test
+  a CDATA #REQUIRED
+  &gt;
+
+&lt;!ELEMENT child EMPTY&gt;
+</pre>
+
+    <a name="id54302"></a><h3><heading>Loading DTDs from local files</heading></h3>
+
+    <p>
+      Use the :entity-resolver argument to <tt>parse-file</tt> to
+      specify a function that maps System IDs and Public IDs to local
+      files of your choice:
+    </p>
+    
+    <pre>(let ((uri "http://www.lichteblau.com/blubba/dtdexample.dtd")
+      (pathname "dtdexample.dtd"))
+  (flet ((resolver (pubid sysid)
+	   (declare (ignore pubid))
+	   <b>(when (puri:uri= sysid (puri:parse-uri uri))
+	     (open pathname :element-type '(unsigned-byte 8)))</b>))
+    (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>)))</pre>
+
+
+    <a name="id54328"></a><h3><heading>Can I skip loading of DTDs entirely?</heading></h3>
+
+    <p>
+      Yes and no.
+    </p>
+    <p>
+      <i>Yes</i>, you can force CXML to do this, see the following example.
+    </p>
+    
+    <p>
+      But no, skipping the DTD will not actually work if the document
+      references entities declared in the DTD, especially since neither
+      SAX nor DOM are able to report unresolved entity references in
+      attributes.
+    </p>
+
+    <p>
+      The trick to make CXML skip the DTD is to pretend that it is empty
+      by returning a zero-length stream instead:
+    </p>
+    
+    <pre>(flet ((resolver (pubid sysid)
+	 (declare (ignore pubid sysid))
+	 <b>(flexi-streams:make-in-memory-input-stream nil)</b>))
+  (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre>
+
+    <a name="id54364"></a><h3><heading>
+      Catalogs: How can I use the HTML DTD installed by my distribution?
+    </heading></h3>
+
+    <p>
+      Rather than writing an entity resolver function yourself, CXML can
+      use XML catalogs to find DTDs and entity files on your local system.
+    </p>
+    <p>
+      Catalogs are particularly helpful for DTDs that are
+      pre-installed.  For example, most Linux distributions include a
+      package for the XHTML DTD.  The DTD will reside in a
+      distribution-dependent location, which the central catalog file
+      points to.
+    </p>
+    <p>By default, CXML looks for the catalog in /etc/xml/catalog
+    (Linux) and /usr/local/share/xml/catalog.ports (FreeBSD).
+    </p>
+    <pre>* <b>(setf cxml:*catalog* (cxml:make-catalog))</b>
+* (cxml:parse-file "test.xhtml" (cxml-dom:make-dom-builder))</pre>
+
+    <a name="id54390"></a><h3><heading>
+      Can I load DTDs through HTTP?
+    </heading></h3>
+
+    <p>
+      Sure, just use an entity-resolver function that does it.
+    </p>
+    <p>
+      Install <a href="http://weitz.de/drakma/">Drakma</a> and try this:
+    </p>
+    <pre>(flet ((resolver (pubid sysid)
+	 (declare (ignore pubid))
+	 <b>(when (eq (puri:uri-scheme sysid) :http)
+	   (drakma:http-request sysid :want-stream t))</b>))
+  (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/quickstart.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,247 @@
+<documentation title="CXML Quick-Start Example">
+    <h1>Quick-Start Example / FAQ</h1>
+
+    <p>
+      Make sure to <a href="installation.html#installation">install and load</a> cxml first.
+    </p>
+
+    <h3>
+      On this page
+    </h3>      
+    <page-index/>
+    
+    <p>
+      To try the following examples, create a test file
+      called <tt>example.xml</tt>:
+    </p>
+    <pre>* <b>(with-open-file (s "example.xml" :direction :output)
+    (write-string "&lt;test a='b'&gt;&lt;child/&gt;&lt;/test>" s))</b></pre>
+
+    <heading>Parsing a file</heading>
+
+    <p>Parse <tt>example.xml</tt> into a DOM tree (<a href="sax.html#parser">read
+    more</a>):</p>
+    <pre>* <b>(cxml:parse-file "example.xml" (cxml-dom:make-dom-builder))</b>
+#&lt;DOM-IMPL::DOCUMENT @ #x72206172>
+
+;; save result for later:
+* <b>(defparameter *example* *)</b>
+*EXAMPLE*</pre>
+
+    <heading>Using DOM</heading>
+
+    <p>Inspect the DOM tree (<a href="sax.html#dom">read more</a>):</p>
+    <pre>* <b>(dom:document-element *example*)</b>
+#&lt;DOM-IMPL::ELEMENT test @ #x722b6ba2&gt;
+
+* (<b>dom:tag-name</b> (dom:document-element *example*))
+"test"
+
+* (<b>dom:child-nodes</b> (dom:document-element *example*))
+#(#&lt;DOM-IMPL::ELEMENT child @ #x722b6d8a&gt;)
+
+* (<b>dom:get-attribute</b> (dom:document-element *example*) <b>"a"</b>)
+"b"</pre>
+
+    <heading>Serializing DOM</heading>
+
+    <p>Serialize the DOM document back into a file (<a
+    href="sax.html#serialization">read more</a>):</p>
+    <pre>(with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8))
+  <b>(dom:map-document (cxml:make-octet-stream-sink out) *example*)</b></pre>
+
+    <heading>Parsing into XMLS-like lists</heading>
+
+    <p>
+      If DOM is not the representation you want to you, parsing into
+      other data structures is possible using the same SAX parser
+      function, while using a different handler.
+      The XMLS builder is included for compatibility with XMLS, and also
+      also sample code (see cxml/xml/xmls-compat.lisp) for your own
+      handlers.
+    </p>
+
+    <p>As an alternative to DOM, parse into xmls-compatible list
+    structure (<a href="xmls-compat.html">read more</a>):</p>
+    <pre>* <b>(cxml:parse-file "example.xml" (cxml-xmls:make-xmls-builder))</b>
+("test" (("a" "b")) ("child" NIL))</pre>
+
+    <p>
+      Again, serialization into XML is done using a sink as a SAX
+      handler and a data-structure specific function to generate SAX
+      events for the document, in this case <tt>cxml-xmls:map-node</tt>.
+    </p>
+
+    <pre>* (with-open-file (out "example.out" :direction :output :element-type '(unsigned-byte 8))
+    (<b>cxml-xmls:map-node (cxml:make-octet-stream-sink out)
+                        '("test" (("a" "b")) ("child" nil)))</b>)</pre>
+
+    <heading>Parsing incrementally using Klacks</heading>
+
+    <p>Use klacks to read events from the parser incrementally.  The
+    following example looks only for :start-element and :end-element
+    events and prints them (<a href="klacks.html">read more</a>):</p>
+    <pre>* <b>(klacks:with-open-source
+    (s (cxml:make-source #p"example.xml"))</b>
+  (loop
+      for key = <b>(klacks:peek s)</b>
+      while key
+      do
+	(case key
+	  (:start-element
+	    (format t "~A {" <b>(klacks:current-qname s)</b>))
+	  (:end-element
+	    (format t "}")))
+	<b>(klacks:consume s)</b>))
+test {child {}}</pre>
+
+    <heading>Writing XML</heading>
+
+    <p>
+      Serialization is always done using sinks, which accept SAX events,
+      but there are convenience functions and macros to make that easier
+      to use:
+    </p>
+    <pre>(cxml:with-xml-output (cxml:make-octet-stream-sink stream :indentation 2 :canonical nil)
+  (cxml:with-element "foo"
+    (cxml:attribute "xyz" "abc")
+    (cxml:with-element "bar"
+      (cxml:attribute "blub" "bla"))
+    (cxml:text "Hi there.")))</pre>
+   <p>
+      Prints this to <tt>stream</tt>:
+   </p>
+   <pre>&lt;foo xyz="abc"&gt;
+  &lt;bar blub="bla"&gt;&lt;/bar&gt;
+  Hi there.
+&lt;/foo&gt;</pre>
+    
+    <heading>Help! CXML says 'URI scheme :HTTP not supported'</heading>
+
+    <p>
+      By default, this error will occur when the DTD (or generally, any
+      entity) has an http:// URL as its system ID.  CXML itself
+      understands only file:// URLs, but allows users to customize the
+      behaviour for all URLs.
+    </p>
+
+    <p>
+      The are several solutions to this, covered in detail below:
+      <ul>
+	<li>
+	  Load the DTD/entity from local files using an entity resolver
+	</li>
+	<li>
+	  Skip parsing of the DTD/entity entirely by pretending it is
+	  empty, again using an entity resolver.
+	</li>
+	<li>
+	  Use a <em>catalog</em> to make CXML find DTDs in the local
+	  filesystem automatically.
+	</li>
+	<li>
+	  Teach CXML actually load DTDs using HTTP.
+	</li>
+      </ul>
+    </p>
+
+    <p>
+      Here are the example files for the following solutions to this
+      problem:
+    </p>
+
+    <a href="http://www.lichteblau.com/blubba/dtdexample.xml">
+      <tt>dtdexample.xml</tt>:</a>
+    <pre>&lt;!DOCTYPE test SYSTEM 'http://www.lichteblau.com/blubba/dtdexample.dtd'>
+&lt;test a='b'>blub&lt;child/>&lt;/test></pre>
+    
+    <a href="http://www.lichteblau.com/blubba/dtdexample.dtd">
+      <tt>dtdexample.dtd</tt></a>:
+    <pre>&lt;!ELEMENT test (#PCDATA|child)*>
+&lt;!ATTLIST test
+  a CDATA #REQUIRED
+  >
+
+&lt;!ELEMENT child EMPTY>
+</pre>
+
+    <heading>Loading DTDs from local files</heading>
+
+    <p>
+      Use the :entity-resolver argument to <tt>parse-file</tt> to
+      specify a function that maps System IDs and Public IDs to local
+      files of your choice:
+    </p>
+    
+    <pre>(let ((uri "http://www.lichteblau.com/blubba/dtdexample.dtd")
+      (pathname "dtdexample.dtd"))
+  (flet ((resolver (pubid sysid)
+	   (declare (ignore pubid))
+	   <b>(when (puri:uri= sysid (puri:parse-uri uri))
+	     (open pathname :element-type '(unsigned-byte 8)))</b>))
+    (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>)))</pre>
+
+
+    <heading>Can I skip loading of DTDs entirely?</heading>
+
+    <p>
+      Yes and no.
+    </p>
+    <p>
+      <i>Yes</i>, you can force CXML to do this, see the following example.
+    </p>
+    
+    <p>
+      But no, skipping the DTD will not actually work if the document
+      references entities declared in the DTD, especially since neither
+      SAX nor DOM are able to report unresolved entity references in
+      attributes.
+    </p>
+
+    <p>
+      The trick to make CXML skip the DTD is to pretend that it is empty
+      by returning a zero-length stream instead:
+    </p>
+    
+    <pre>(flet ((resolver (pubid sysid)
+	 (declare (ignore pubid sysid))
+	 <b>(flexi-streams:make-in-memory-input-stream nil)</b>))
+  (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre>
+
+    <heading>
+      Catalogs: How can I use the HTML DTD installed by my distribution?
+    </heading>
+
+    <p>
+      Rather than writing an entity resolver function yourself, CXML can
+      use XML catalogs to find DTDs and entity files on your local system.
+    </p>
+    <p>
+      Catalogs are particularly helpful for DTDs that are
+      pre-installed.  For example, most Linux distributions include a
+      package for the XHTML DTD.  The DTD will reside in a
+      distribution-dependent location, which the central catalog file
+      points to.
+    </p>
+    <p>By default, CXML looks for the catalog in /etc/xml/catalog
+    (Linux) and /usr/local/share/xml/catalog.ports (FreeBSD).
+    </p>
+    <pre>* <b>(setf cxml:*catalog* (cxml:make-catalog))</b>
+* (cxml:parse-file "test.xhtml" (cxml-dom:make-dom-builder))</pre>
+
+    <heading>
+      Can I load DTDs through HTTP?
+    </heading>
+
+    <p>
+      Sure, just use an entity-resolver function that does it.
+    </p>
+    <p>
+      Install <a href="http://weitz.de/drakma/">Drakma</a> and try this:
+    </p>
+    <pre>(flet ((resolver (pubid sysid)
+	 (declare (ignore pubid))
+	 <b>(when (eq (puri:uri-scheme sysid) :http)
+	   (drakma:http-request sysid :want-stream t))</b>))
+  (cxml:parse-file "dtdexample.xml" (cxml-dom:make-dom-builder) <b>:entity-resolver #'resolver</b>))</pre>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,771 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML SAX parser</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>SAX parsing and serialization</h1>
+
+    <a name="parser"></a>
+
+    <p>
+      This chapter describes CXML's SAX-like parser interface.
+    </p>
+    <p>
+      The SAX layer is an important concept in CXML that users will
+      encounter in various situations:
+    </p>
+    <ul>
+      <li>
+        To <b>parse into DOM</b>, use the SAX parser as described below with
+        a <b>DOM builder</b> as the SAX handler.  (Refer to <a href="dom.html#parser">make-dom-builder</a> for information about
+        DOM.)
+      </li>
+      <li>
+        <b>Serialization</b> is done using SAX, too.   SAX handlers that
+        process and consume events without sending them to another
+        handler are called <i>sinks</i> in CXML.  Serialization sinks
+        write XML output for the events they receive.  For example, to
+        serialize DOM, use <tt>map-document</tt> to turn the DOM
+        document into SAX events together with a <tt>sink</tt> for
+        serialization.
+      </li>
+      <li>
+        SAX handlers can be chained together.  Various SAX handlers
+        are offered that can be used in this way, transforming SAX
+        events before handing them to the next handler.  This includes
+        handlers for <b>whitespace removal</b>, <b>namespace
+        normalization</b>, and rod-to-string <b>recoding</b>.
+      </li>
+    </ul>
+    <p>
+      However, SAX events are easier to generate than to process.  That
+      is why CXML offers <i>Klacks</i>, a "pull-based" API in addition to SAX.
+      Klacks events are generally easier to process than to generate.
+      Please refer to the <a href="klacks.html">Klacks documentation</a>
+      for details.
+    </p>
+
+    <h3>Parsing and Validating</h3>
+    <div style="border: 1px dotted black;   width: 70%;   padding: 1em">
+    <p>
+      Old-style convenience functions:
+    </p>
+    <div style="font-weight: bold">Function CXML:PARSE-FILE (pathname handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a pathname argument.
+      (But note that <tt>cxml:parse-file</tt> interprets string
+      arguments as namestrings, while <tt>cxml:parse</tt> expects
+      literal XML documents.)
+    </p>
+    <div style="font-weight: bold">Function CXML:PARSE-STREAM (stream handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a stream argument.</p>
+    <div style="font-weight: bold">Function CXML:PARSE-OCTETS (octets handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with an octet vector argument.</p>
+    <div style="font-weight: bold">Function CXML:PARSE-ROD (rod handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a string argument.</p>
+    </div>
+
+    <h4>
+      New all-in-one parser interface:
+    </h4>
+    <div class="def">Function CXML:PARSE (input handler &amp;key ...)</div>
+    <p>
+      Parse an XML document, where input is a string, pathname, octet
+      vector, or stream.
+      Return values from this function depend on the SAX handler used.<br>
+      Arguments:
+    </p>
+    <ul>
+      <li>
+	<tt>input</tt> -- one of:<br>
+	<ul>
+	  <li>
+	    <tt>pathname</tt> -- a Common Lisp pathname.  
+	    Open the file specified by the pathname and parse its
+	    contents as an XML document. 
+	  </li>
+	  <li>
+<tt>stream</tt> -- a Common Lisp stream with element-type
+            <tt>(unsigned-byte 8)</tt>.
+	  </li>
+	  <li>
+	    <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array.
+	    The array is parsed directly, and interpreted according to the
+	    encoding it specifies.
+	  </li>
+	  <li>
+	    <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on
+	    unicode-capable implementations).
+	    Parses an XML document from the input string that has already
+	    undergone external-format decoding.
+	  </li>
+	</ul>
+      </li>
+      <li>
+<tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt>
+</li>
+      <li>
+<tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array</li>
+      <li>
+<tt>handler</tt> -- a SAX handler</li>
+    </ul>
+    <p>
+      Common keyword arguments:
+    </p>
+    <ul>
+      <li>
+        <tt>validate</tt> -- A boolean.? Defaults to
+        <tt>nil</tt>.  If true, parse in validating mode, i.e. assert that
+        the document contains a DOCTYPE declaration and conforms to the
+        DTD declared.
+      </li>
+      <li>
+        <tt>dtd</tt> -- unless <tt>nil</tt>, an extid instance
+        specifying the external subset to load.  This options overrides
+        the extid specified in the document type declaration, if any.
+        See below for <tt>make-extid</tt>.  This option is useful
+        for verification purposes together with the <tt>root</tt>
+        and <tt>disallow-internal-subset</tt> arguments.
+      </li>
+      <li>
+<tt>root</tt> -- the expected root element
+        name, or <tt>nil</tt> (the default).
+      </li>
+      <li>
+        <tt>entity-resolver</tt> -- <tt>nil</tt> or a function of two
+        arguments which is invoked for every entity referenced by the
+        document with the entity's Public ID (a rod) and System ID (an
+        URI object) as arguments.  The function may either return
+        nil, CXML will then try to resolve the entity as usual.
+        Alternatively it may return a Common Lisp stream specialized on
+        <tt>(unsigned-byte 8)</tt> which will be used instead.  (It may
+        also signal an error, of course, which can be useful to prohibit
+        parsed XML documents from including arbitrary files readable by
+        the parser.)
+      </li>
+      <li>
+        <tt>disallow-internal-subset</tt> -- a boolean.  If true, signal
+        an error if the document contains an internal subset.
+      </li>
+      <li>
+        <tt>recode</tt> -- a boolean.  (Ignored on Lisps with Unicode
+        support.)  Recode rods to UTF-8 strings.  Defaults to true.
+	Make sure to use <tt>utf8-dom:make-dom-builder</tt> if this
+        option is enabled and <tt>rune-dom:make-dom-builder</tt>
+        otherwise.
+      </li>
+    </ul>
+    <p>
+      Note: <tt>parse-rod</tt> assumes that the input has already been
+      decoded into Unicode runes and ignores the encoding
+      specified in the XML declaration, if any.
+    </p>
+
+    <p>
+      <div class="def">Function CXML:PARSE-EMPTY-DOCUMENT (uri qname handler &amp;key public-id system-id entity-resolver recode)</div>
+    </p>
+    <p>
+      Simulate parsing a document with a document element <tt>qname</tt>
+      having no attributes except for an optional namespace
+      declaration to <tt>uri</tt>.  If an external ID is specified
+      (<tt>system-id</tt>, <tt>public-id</tt>), find, parse, and report
+      this DTD as if with <tt>parse-file</tt>, using the specified
+      entity resolver.
+    </p>
+
+    <p>
+      <div class="def">Function CXML:PARSE-DTD-FILE (pathname)</div>
+      <div class="def">Function CXML:PARSE-DTD-STREAM (stream)</div>
+      Parse <a href="http://www.w3.org/TR/2000/REC-xml-20001006#NT-extSubset">declarations</a>
+      from a stand-alone file and return an object representing the DTD,
+      suitable as an argument to <tt>validate</tt>.
+    </p>
+    <ul>
+      <li>
+<tt>pathname</tt> -- a Common Lisp pathname</li>
+      <li>
+<tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt>
+</li>
+    </ul>
+
+    <p>
+      <div class="def">Function CXML:MAKE-EXTID (publicid systemid)</div>
+      Create an object representing the External ID composed
+      of the specified Public ID, a rod or <tt>nil</tt>, and System ID
+      (an URI object).
+    </p>
+
+    <p>
+      <div class="def">Condition class CXML:XML-PARSE-ERROR ()</div>
+      Superclass of all conditions signalled by the CXML parser.
+    </p>
+    <p>
+      <div class="def">Condition class CXML:WELL-FORMEDNESS-VIOLATION (cxml:xml-parse-error)</div>
+      This condition is signalled for all well-formedness violations.
+      (Note that, when parsing document that is not well-formed in validating
+      mode, the parser might encounter validity errors before detecting
+      well-formedness problems, so also be prepared for <tt>validity-error</tt>
+      in that situation.)
+    </p>
+    <p>
+      <div class="def">Condition class CXML:VALIDITY-ERROR (cxml:xml-parse-error)</div>
+      Reports the violation of a validity constraint.
+    </p>
+
+    <a name="serialization"></a>
+    <h3>Serialization</h3>
+    <p>
+      Serialization is performed using <tt>sink</tt> objects.  There are
+      different kinds of sinks for output to lisp streams and vectors in
+      various flavours.
+    </p>
+    <p>
+      Technically, sinks are SAX handlers that write XML output for SAX
+      events sent to them.  In practise, user code would normally not
+      generate those SAX events manually, and instead use a function
+      like <a href="dom.html#serialization">dom:map-document</a> or <a href="xmls-compat.html">xmls-compat:map-node</a> to serialize an
+      in-memory document.
+    </p>
+    <p>
+      In addition to <tt>map-document</tt>, cxml has a set of
+      convenience macros for serialization (see below for
+      <tt>with-xml-output</tt>, <tt>with-element</tt>, etc).
+    </p>
+
+    <div style="background-color: #ddddff">
+      Portable sinks:<br>
+      <span class="def">Function CXML:MAKE-OCTET-VECTOR-SINK (&amp;rest keys) =&gt; sink</span><br>
+      <span class="def">Function CXML:MAKE-OCTET-STREAM-SINK (stream &amp;rest keys) =&gt; sink</span><br>
+      <span class="def">Function CXML:MAKE-ROD-SINK (&amp;rest keys) =&gt; sink</span><br>
+      <br>
+      Only on Lisps with Unicode support:<br>
+      <span class="def">Function CXML:MAKE-STRING-SINK</span> -- alias for <tt>cxml:make-rod-sink</tt><br>
+      <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &amp;rest keys) =&gt; sink</span><br>
+      <br>
+      Only on Lisps <em>without</em> Unicode support:<br>
+      <span class="def">Function CXML:MAKE-STRING-SINK/UTF8 (&amp;rest keys) =&gt; sink</span><br>
+      <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK/UTF8 (stream &amp;rest keys) =&gt; sink</span><br>
+    </div>
+    <p>
+      Return a SAX serialization handle.
+    </p>
+    <ul>
+      <li>
+        The <tt>-octet-</tt> functions write the document encoded into
+        UTF-8.
+	<tt>make-octet-stream-sink</tt> works with Lisp streams of
+	element-type <tt>(unsigned-byte 8)</tt>.
+	<tt>make-octet-vector-sink</tt> returns a vector of
+	<tt>(unsigned-byte 8)</tt>.
+      </li>
+      <li>
+        <tt>make-character-stream-sink</tt> works with character
+	streams.  It serializes the document into characters <em>without
+	encoding it into an external format</em>.  When using these
+	functions, <em>take care to avoid encoding the result into
+	an incorrect external format</em>.  (Note that characters undergo
+	external format conversion when written to a character stream.
+	If the document's XML declaration specifies an encoding, make
+	sure to specify this encoding as the external format if and when
+	writing the serialized document to a character stream.  If the
+	document does not specify an encoding, either UTF-8 or UTF-16
+	must be used.)  This function is available only on Lisps with
+	unicode support.
+      </li>
+      <li>
+        <tt>make-rod-sink</tt> serializes the document into a vector of
+	runes <em>without encoding it into an external format</em>.
+	(On Lisp with unicode support, the result will be a string;
+	otherwise, a vector of character codes will be returned.)
+	The warnings given for <tt>make-character-stream-sink</tt>
+	apply to this function as well.
+      </li>
+      <li>
+        The <tt>/utf8</tt> functions write the document encoded into
+	characters representing a UTF-8 encoding.
+	When using these functions, <em>take care to avoid encoding the
+	result</em> into an external format for a second time.  (Note
+	that characters undergo external format conversion when written
+	to a character stream.  Since these functions already perform
+	external format conversion, make sure to specify an external
+	format that does "nothing" if and when writing the serialized document
+	to a character stream.  ISO-8859-1 external formats usually
+	achieve the desired effect.)
+	<tt>make-character-stream-sink/utf8</tt> works with character streams.
+	<tt>make-string-sink/utf8</tt> returns a string.
+        These functions are available only on Lisps without unicode support.
+      </li>
+    </ul>
+    <p>Keyword arguments:</p>
+    <ul>
+      <li>
+        <tt>canonical</tt> -- canonical form, one of NIL, T, 1, 2
+      </li>
+      <li>
+        <tt>indentation</tt> -- indentation level.  An integer or <tt>nil</tt>.
+      </li>
+    </ul>
+    <p>
+      The following <tt>canonical</tt> values are allowed:
+    </p>
+    <ul>
+      <li>
+        <tt>t</tt> or <tt>1</tt>: <a href="http://www.w3.org/TR/2001/REC-xml-c14n-20010315">Canonical
+         XML</a>
+      </li>
+      <li>
+        <tt>2</tt>: <a href="http://dev.w3.org/cvsweb/~checkout~/2001/XML-Test-Suite/xmlconf/sun/cxml.html?content-type=text/html;%20charset=iso-8859-1">Second
+         Canonical Form</a>
+      </li>
+      <li>
+        <tt>NIL</tt>: Use a more readable non-canonical representation.
+      </li>
+    </ul>
+    <p>
+      An internal subset will be included in the result regardless of
+      the <tt>canonical</tt> setting.  It is the responsibility of the
+      caller to not report an internal subset for
+      canonical?&lt;=?1, or only notations as required for
+      canonical?=?2.  For example, the
+      <tt>include-doctype</tt> argument to <tt>dom:map-document</tt>
+      should be set to <tt>nil</tt> for the former behaviour and
+      <tt>:canonical-notations</tt> for the latter.
+    </p>
+    <p>
+      With an <tt>indentation</tt> level, pretty-print the XML by
+      inserting additional whitespace.? Note that indentation
+      changes the document model and should only be used if whitespace
+      does not matter to the application.
+    </p>
+
+    <p>
+      <div class="def">Macro CXML:WITH-XML-OUTPUT (sink &amp;body body) =&gt; sink-specific result</div>
+      <div class="def">Macro CXML:WITH-NAMESPACE ((prefix uri) &amp;body body) =&gt; result</div>
+      <div class="def">Macro CXML:WITH-ELEMENT (qname &amp;body body) =&gt; result</div>
+      <div class="def">Macro CXML:WITH-ELEMENT* ((prefix lname) &amp;body body) =&gt; result</div>
+      <div class="def">Function CXML:ATTRIBUTE (qname value) =&gt; value</div>
+      <div class="def">Generic Function CXML:UNPARSE-ATTRIBUTE (value) =&gt; string</div>
+      <div class="def">Function CXML:ATTRIBUTE* (prefix lname value) =&gt; value</div>
+      <div class="def">Function CXML:TEXT (data) =&gt; data</div>
+      <div class="def">Function CXML:CDATA (data) =&gt; data</div>
+      <div class="def">Function CXML:doctype (name public-id system-id &amp;optional internal-subset)</div>
+      Convenience syntax for event-based serialization.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>(with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil)
+  (with-element "foo"
+    (attribute "xyz" "abc")
+    (with-element "bar"
+      (attribute "blub" "bla"))
+    (text "Hi there.")))</pre>
+   <p>
+      Prints this to <tt>stream</tt>:
+   </p>
+   <pre>&lt;foo xyz="abc"&gt;
+  &lt;bar blub="bla"&gt;&lt;/bar&gt;
+  Hi there.
+&lt;/foo&gt;</pre>
+
+    <p>
+      <div class="def">Macro XHTML-GENERATOR:WITH-XHTML (sink &amp;rest forms)</div>
+      <div class="def">Macro XHTML-GENERATOR:WRITE-DOCTYPE (sink)</div>
+      Macro <tt>with-xhtml</tt> is a modified version of
+      Franz' <tt>htmlgen</tt> works as a SAX driver for XHTML.
+      It aims to be a plug-in replacement for the <tt>html</tt> macro.
+    </p>
+    <p>
+      <tt>xhtmlgen</tt> is included as <tt>contrib/xhtmlgen.lisp</tt> in
+      the cxml distribution.  Example:
+    </p>
+    <pre>(let ((sink (cxml:make-character-stream-sink *standard-output*)))
+  (sax:start-document sink)
+  (xhtml-generator:write-doctype sink)
+  (xhtml-generator:with-html sink
+    (:html
+     (:head
+      (:title "Titel"))
+     (:body
+      ((:p "style" "font-weight: bold")
+       "Inhalt")
+      (:ul
+       (:li "Eins")
+       (:li "Zwei")
+       (:li "Drei")))))
+  (sax:end-document sink))</pre>
+
+    <a name="misc"></a>
+    <h3>Miscellaneous SAX handlers</h3>
+    <p>
+      <div class="def">Function CXML:MAKE-VALIDATOR (dtd root)</div>
+      Create a SAX handler which validates against a DTD instance.?
+      The document's root element must be named <tt>root</tt>.? 
+      Used with <tt>dom:map-document</tt>, this validates a document
+      object as if by re-reading it with a validating parser, except
+      that declarations recorded in the document instance are completely
+      ignored.<br>
+      Example:
+    </p>
+    <pre>(let ((d (parse-file "~/test.xml" (cxml-dom:make-dom-builder)))
+      (x (parse-dtd-file "~/test.dtd")))
+  (dom:map-document (cxml:make-validator x #"foo") d))</pre>
+
+    <p>
+      <div class="def">Class CXML:BROADCAST-HANDLER ()</div>
+      <div class="def">Accessor CXML:BROADCAST-HANDLER-HANDLERS</div>
+      <div class="def">Function CXML:MAKE-BROADCAST-HANDLER (&amp;rest handlers)</div>
+      <tt>broadcast-handler</tt> is a SAX handler which passes every event it
+      receives on to each of several chained handlers, somewhat similar
+      to the way a <tt>broadcast-stream</tt> works.
+    </p>
+    <p>
+      You can subclass <tt>broadcast-stream</tt> to modify the events
+      before they are being passed on.  Define methods on your handler
+      class for the events to be modified.  All other events will pass
+      through to the chained handlers unmodified.
+    </p>
+    <p>
+      Broadcast handler functions return the result of calling the event
+      function on the <i>last</i> handler in the list.  In particular,
+      the overall result from <tt>sax:end-document</tt> will be ignored
+      for all other handlers.
+    </p>
+
+    <p>
+      <div class="def">Class CXML:SAX-PROXY (broadcast-handler)</div>
+      <div class="def">Accessor CXML:PROXY-CHAINED-HANDLER</div>
+      <tt>sax-proxy</tt> is a subclass of <tt>broadcast-handler</tt>
+      which sends events to exactly one chained handler.  This class is
+      still included for compatibility with older versions of
+      CXML which did not include the more
+      general <tt>broadcast-handler</tt> yet, but has been retrofitted
+      as a subclass of the latter.
+    </p>
+
+    <p>
+    <div class="def">Accessor CXML:MAKE-NAMESPACE-NORMALIZER (next-handler)</div>
+    </p>
+    <p>
+      Return a SAX handler that performs <a href="http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo">DOM
+      3-style namespace normalization</a> on attribute lists in
+      <tt>start-element</tt> events before passing them on the next
+      handler.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-WHITESPACE-NORMALIZER (chained-handler &amp;optional dtd)</div>
+      Return a SAX handler which removes whitespace from elements that
+      have <em>element content</em> and have not been declared to
+      preserve space using an xml:space attribute.
+    </p>
+    <p>Example:</p>
+    <pre>(cxml:parse-file "example.xml"
+                 (cxml:make-whitespace-normalizer (cxml-dom:make-dom-builder))
+                 :validate t)</pre>
+    <p>Example input:</p>
+    <pre>&lt;!DOCTYPE test [
+&lt;!ELEMENT test (foo,bar*)&gt;
+&lt;!ATTLIST test a CDATA #IMPLIED&gt;
+&lt;!ELEMENT foo #PCDATA&gt;
+&lt;!ELEMENT bar (foo?)&gt;
+&lt;!ATTLIST bar xml:space (default|preserve) "default"&gt;
+]&gt;
+&lt;test a='b'&gt;
+  &lt;foo&gt;   &lt;/foo&gt;
+  &lt;bar&gt;   &lt;/bar&gt;
+  &lt;bar xml:space="preserve"&gt;   &lt;/bar&gt;
+&lt;/test&gt;
+</pre>
+    <p>Example result:</p>
+    <pre>&lt;test a="b"&gt;&lt;foo&gt;   &lt;/foo&gt;&lt;bar&gt;&lt;/bar&gt;&lt;bar xml:space="preserve"&gt;   &lt;/bar&gt;&lt;/test&gt;</pre>
+
+    <a name="rods"></a>
+    <h3>Recoders</h3>
+    <p>
+      Recoders are a mechanism used by CXML internally on Lisp implementations
+      without Unicode support to recode UTF-16 vectors (rods) of
+      integers (runes) into UTF-8 strings.
+    </p>
+    <p>
+      User code does not usually need to deal with recoders in current
+      versions of CXML.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div>
+      Return a SAX handler which passes all events on to
+      <tt>chained-handler</tt> after converting all strings and rods
+      using <tt>recoder-fn</tt>, a function of one argument.
+    </p>
+
+    <a name="dtdcache"></a>
+    <h3>Caching of DTD Objects</h3>
+    <p>
+      To avoid spending time parsing the same DTD over and over again,
+      CXML can cache DTD objects.  The parser consults
+      <tt>cxml:*dtd-cache*</tt> whenever it is looking for an external
+      subset in a document which does not have an internal subset and
+      uses the cached DTD instance if one is present in the cache for
+      the System ID in question.
+    </p>
+    <p>
+      Note that DTDs do not expire from the cache automatically.
+      (Future versions of CXML might introduce automatic checks for
+      outdated DTDs.)
+    </p>
+    <p>
+      <div class="def">Variable CXML:*DTD-CACHE*</div>
+      The DTD cache object consulted by the parser when it needs a DTD.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-DTD-CACHE ()</div>
+      Return a new, empty DTD cache object.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*CACHE-ALL-DTDS*</div>
+      If true, instructs the parser to enter all DTDs that could have
+      been cached into <tt>*dtd-cache*</tt> if they were not cached
+      already.  Defaults to <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Reader CXML:GETDTD (uri dtd-cache)</div>
+      Return a cached instance of the DTD at <tt>uri</tt>, if present in
+      the cache, or <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Writer CXML:GETDTD (uri dtd-cache)</div>
+      Enter a new value for <tt>uri</tt> into <tt>dtd-cache</tt>.
+    </p>
+    <p>
+      <div class="def">Function CXML:REMDTD (uri dtd-cache)</div>
+      Ensure that no DTD is recorded for <tt>uri</tt> in the cache and
+      return true if such a DTD was present.
+    </p>
+    <p>
+      <div class="def">Function CXML:CLEAR-DTD-CACHE (dtd-cache)</div>
+      Remove all entries from <tt>dtd-cache</tt>.
+    </p>
+    <p>
+      <em>fixme:</em> thread-safety
+    </p>
+
+    <a name="saxparser"></a>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER ()</div>
+      A class providing location information through an
+      implementation-specific subclass.  Parsers will use
+      <tt>sax:register-sax-parser</tt> to pass their parser instance to
+      the handler.  The easiest way to receive sax parsers instances is
+      to inherit from sax-parser-mixin when defining a sax handler.
+    </p>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER-MIXIN ()</div>
+      A mixin for sax handler classes that records the sax handler
+      object for use with the following functions.  Trampoline methods
+      are provided that allow those functions to be called directly on
+      the sax-parser-mixin.
+    </p>
+    <p>
+      <div class="def">Function SAX:SAX-HANDLER (sax-handler-mixin) =&gt; sax-handler</div>
+      Return the sax-parser instance recorded by this handler, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:LINE-NUMBER (sax-parser)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:COLUMN-NUMBER (sax-parser)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:SYSTEM-ID (sax-parser)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function SAX:XML-BASE (sax-parser)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>sax:system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
+    <a name="catalogs"></a>
+    <h3>XML Catalogs</h3>
+    <p>
+      External entities (for example, DTDs) are referred to using their
+      Public and System IDs.  Usually the System ID, a URI, is used to
+      locate the entity.  CXML itself handles only file://-URIs, but
+      many System IDs in practical use are http://-URIs.  There are two
+      different mechanims applications can use to allow CXML to locate
+      entities using arbitrary Public ID or System ID:
+    </p>
+    <ul>
+      <li>
+        User-defined entity resolvers can be used to open entities using
+        arbitrary protocols.   For example, an entity resolver could
+        handle all System-IDs with the <tt>http</tt> scheme using some
+        HTTP library.  Refer to the description of the 
+        <tt>entity-resolver</tt> keyword argument to parser functions (see <a href="#parser"><tt>cxml:parse-file</tt></a>) to more
+        information on entity resolvers.
+      </li>
+      <li>
+        XML Catalogs are (local) tables in XML syntax which map External
+        IDs to alternative System IDs.  If, say, the xhtml DTD is
+        present in the local file system and the local copy has been
+        registered with the XML catalog, CXML will use the local copy of
+        the DTD instead of trying to open the version available using HTTP.
+      </li>
+    </ul>
+    <p>
+      This section describes XML Catalogs, the second solution.  CXML
+      implements <a href="http://www.oasis-open.org/committees/entity/spec.html">Oasis
+      XML Catalogs</a>.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*CATALOG*</div>
+      The XML Catalog object consulted by the parser before trying to
+      open an entity.  Initially <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*PREFER*</div>
+      The default "prefer" mode from the Catalog specification, one
+      of <tt>:public</tt> or <tt>:system</tt>.  Defaults
+      to <tt>:public</tt>.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-CATALOG (&amp;optional uris)</div>
+      Return a catalog object for the catalog files specified.
+    </p>
+    <p>
+      <div class="def">Function CXML:RESOLVE-URI (uri catalog)</div>
+      Look up <tt>uri</tt> in <tt>catalog</tt> and return the
+      resulting URI, or <tt>nil</tt> if no match was found.
+    </p>
+    <p>
+      <div class="def">Function CXML:RESOLVE-EXTID (publicid systemid catalog)</div>
+      Look up the External ID (<tt>publicid</tt>, <tt>systemid</tt>)
+      in <tt>catalog</tt> and return the resulting URI, or <tt>nil</tt>
+      if no match was found.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>* (setf cxml:*catalog* nil)
+* (cxml:parse-file "test.xhtml" nil)
+=&gt; Error: URI scheme :HTTP not supported
+
+* (setf cxml:*catalog* (cxml:make-catalog))
+* (cxml:parse-file "test.xhtml" nil)
+;; no error!
+NIL</pre>
+    <p>
+      Note that parsed catalog files are cached in the catalog object.
+      Catalog files cached do not expire automatically.  To ensure that
+      all catalog files are parsed again, create a new catalog object.
+    </p>
+
+    <a name="sax"></a>
+    <h2>SAX Interface</h2>
+    <p>
+      A SAX handler is an arbitrary objects that implements some of the
+      generic functions in the SAX package.? Note that no default
+      handler class is necessary, because all generic functions have default
+      methods which do nothing.? SAX functions are:
+      <div class="def">Function SAX:START-DOCUMENT (handler)</div>
+      <div class="def">Function SAX:END-DOCUMENT (handler)</div>
+      <br>
+      <div class="def">Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)</div>
+      <div class="def">Function SAX:END-ELEMENT (handler namespace-uri local-name qname)</div>
+      <div class="def">Function SAX:START-PREFIX-MAPPING (handler prefix uri)</div>
+      <div class="def">Function SAX:END-PREFIX-MAPPING (handler prefix)</div>
+      <div class="def">Function SAX:PROCESSING-INSTRUCTION (handler target data)</div>
+      <div class="def">Function SAX:COMMENT (handler data)</div>
+      <div class="def">Function SAX:START-CDATA (handler)</div>
+      <div class="def">Function SAX:END-CDATA (handler)</div>
+      <div class="def">Function SAX:CHARACTERS (handler data)</div>
+      <br>
+      <div class="def">Function SAX:START-DTD (handler name public-id system-id)</div>
+      <div class="def">Function SAX:END-DTD (handler)</div>
+      <div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div>
+      <div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div>
+      <div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div>
+      <div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div>
+      <div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div>
+      <div class="def">Function SAX:NOTATION-DECLARATION (handler name public-id system-id)</div>
+      <div class="def">Function SAX:ELEMENT-DECLARATION (handler name model)</div>
+      <div class="def">Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)</div>
+      <br>
+      <div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
+      <br>
+      <div class="def">Function SAX:FIND-ATTRIBUTE (qname attributes)</div>
+      <div class="def">Function SAX:FIND-ATTRIBUTE-NS (uri lname attributes)</div>
+    </p>
+    <p>
+      The entity declaration methods are similar to Java SAX
+      definitions, but parameter entities are distinguished from
+      general entities not by a <tt>%</tt> prefix to the name, but by
+      the <tt>kind</tt> argument, either <tt>:parameter</tt> or
+      <tt>:general</tt>.
+    </p>
+    <p>
+      The arguments to <tt>sax:element-declaration</tt> and
+      <tt>sax:attribute-declaration</tt> differ significantly from their
+      Java counterparts.
+    </p>
+    <p>
+      <i>fixme</i>: For more information on these functions refer to the docstrings.
+    </p>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/sax.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,722 @@
+<documentation title="CXML SAX parser">
+    <h1>SAX parsing and serialization</h1>
+
+    <a name="parser"/>
+
+    <p>
+      This chapter describes CXML's SAX-like parser interface.
+    </p>
+    <p>
+      The SAX layer is an important concept in CXML that users will
+      encounter in various situations:
+    </p>
+    <ul>
+      <li>
+        To <b>parse into DOM</b>, use the SAX parser as described below with
+        a <b>DOM builder</b> as the SAX handler.  (Refer to <a
+        href="dom.html#parser">make-dom-builder</a> for information about
+        DOM.)
+      </li>
+      <li>
+        <b>Serialization</b> is done using SAX, too.   SAX handlers that
+        process and consume events without sending them to another
+        handler are called <i>sinks</i> in CXML.  Serialization sinks
+        write XML output for the events they receive.  For example, to
+        serialize DOM, use <tt>map-document</tt> to turn the DOM
+        document into SAX events together with a <tt>sink</tt> for
+        serialization.
+      </li>
+      <li>
+        SAX handlers can be chained together.  Various SAX handlers
+        are offered that can be used in this way, transforming SAX
+        events before handing them to the next handler.  This includes
+        handlers for <b>whitespace removal</b>, <b>namespace
+        normalization</b>, and rod-to-string <b>recoding</b>.
+      </li>
+    </ul>
+    <p>
+      However, SAX events are easier to generate than to process.  That
+      is why CXML offers <i>Klacks</i>, a "pull-based" API in addition to SAX.
+      Klacks events are generally easier to process than to generate.
+      Please refer to the <a href="klacks.html">Klacks documentation</a>
+      for details.
+    </p>
+
+    <h3>Parsing and Validating</h3>
+    <div style="border: 1px dotted black;
+		width: 70%;
+		padding: 1em">
+    <p>
+      Old-style convenience functions:
+    </p>
+    <div style="font-weight: bold">Function CXML:PARSE-FILE (pathname handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a pathname argument.
+      (But note that <tt>cxml:parse-file</tt> interprets string
+      arguments as namestrings, while <tt>cxml:parse</tt> expects
+      literal XML documents.)
+    </p>
+    <div style="font-weight: bold">Function CXML:PARSE-STREAM (stream handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a stream argument.</p>
+    <div style="font-weight: bold">Function CXML:PARSE-OCTETS (octets handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with an octet vector argument.</p>
+    <div style="font-weight: bold">Function CXML:PARSE-ROD (rod handler &amp;key ...)</div>
+    <p style="margin-left: 2em">Same as <tt>cxml:parse</tt> with a string argument.</p>
+    </div>
+
+    <h4>
+      New all-in-one parser interface:
+    </h4>
+    <div class="def">Function CXML:PARSE (input handler &amp;key ...)</div>
+    <p>
+      Parse an XML document, where input is a string, pathname, octet
+      vector, or stream.
+      Return values from this function depend on the SAX handler used.<br/>
+      Arguments:
+    </p>
+    <ul>
+      <li>
+	<tt>input</tt> -- one of:<br/>
+	<ul>
+	  <li>
+	    <tt>pathname</tt> -- a Common Lisp pathname.  
+	    Open the file specified by the pathname and parse its
+	    contents as an XML document. 
+	  </li>
+	  <li><tt>stream</tt> -- a Common Lisp stream with element-type
+            <tt>(unsigned-byte 8)</tt>.
+	  </li>
+	  <li>
+	    <tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array.
+	    The array is parsed directly, and interpreted according to the
+	    encoding it specifies.
+	  </li>
+	  <li>
+	    <tt>string</tt>/<tt>rod</tt> -- a rod (or <tt>string</tt> on
+	    unicode-capable implementations).
+	    Parses an XML document from the input string that has already
+	    undergone external-format decoding.
+	  </li>
+	</ul>
+      </li>
+      <li><tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt></li>
+      <li><tt>octets</tt> -- an <tt>(unsigned-byte 8)</tt> array</li>
+      <li><tt>handler</tt> -- a SAX handler</li>
+    </ul>
+    <p>
+      Common keyword arguments:
+    </p>
+    <ul>
+      <li>
+        <tt>validate</tt> -- A boolean.&#160; Defaults to
+        <tt>nil</tt>.  If true, parse in validating mode, i.e. assert that
+        the document contains a DOCTYPE declaration and conforms to the
+        DTD declared.
+      </li>
+      <li>
+        <tt>dtd</tt> -- unless <tt>nil</tt>, an extid instance
+        specifying the external subset to load.  This options overrides
+        the extid specified in the document type declaration, if any.
+        See below for <tt>make-extid</tt>.  This option is useful
+        for verification purposes together with the <tt>root</tt>
+        and <tt>disallow-internal-subset</tt> arguments.
+      </li>
+      <li><tt>root</tt> -- the expected root element
+        name, or <tt>nil</tt> (the default).
+      </li>
+      <li>
+        <tt>entity-resolver</tt> -- <tt>nil</tt> or a function of two
+        arguments which is invoked for every entity referenced by the
+        document with the entity's Public ID (a rod) and System ID (an
+        URI object) as arguments.  The function may either return
+        nil, CXML will then try to resolve the entity as usual.
+        Alternatively it may return a Common Lisp stream specialized on
+        <tt>(unsigned-byte 8)</tt> which will be used instead.  (It may
+        also signal an error, of course, which can be useful to prohibit
+        parsed XML documents from including arbitrary files readable by
+        the parser.)
+      </li>
+      <li>
+        <tt>disallow-internal-subset</tt> -- a boolean.  If true, signal
+        an error if the document contains an internal subset.
+      </li>
+      <li>
+        <tt>recode</tt> -- a boolean.  (Ignored on Lisps with Unicode
+        support.)  Recode rods to UTF-8 strings.  Defaults to true.
+	Make sure to use <tt>utf8-dom:make-dom-builder</tt> if this
+        option is enabled and <tt>rune-dom:make-dom-builder</tt>
+        otherwise.
+      </li>
+    </ul>
+    <p>
+      Note: <tt>parse-rod</tt> assumes that the input has already been
+      decoded into Unicode runes and ignores the encoding
+      specified in the XML declaration, if any.
+    </p>
+
+    <p>
+      <div class="def">Function CXML:PARSE-EMPTY-DOCUMENT (uri qname handler &amp;key public-id system-id entity-resolver recode)</div>
+    </p>
+    <p>
+      Simulate parsing a document with a document element <tt>qname</tt>
+      having no attributes except for an optional namespace
+      declaration to <tt>uri</tt>.  If an external ID is specified
+      (<tt>system-id</tt>, <tt>public-id</tt>), find, parse, and report
+      this DTD as if with <tt>parse-file</tt>, using the specified
+      entity resolver.
+    </p>
+
+    <p>
+      <div class="def">Function CXML:PARSE-DTD-FILE (pathname)</div>
+      <div class="def">Function CXML:PARSE-DTD-STREAM (stream)</div>
+      Parse <a
+      href="http://www.w3.org/TR/2000/REC-xml-20001006#NT-extSubset">declarations</a>
+      from a stand-alone file and return an object representing the DTD,
+      suitable as an argument to <tt>validate</tt>.
+    </p>
+    <ul>
+      <li><tt>pathname</tt> -- a Common Lisp pathname</li>
+      <li><tt>stream</tt> -- a Common Lisp stream with element-type
+        <tt>(unsigned-byte 8)</tt></li>
+    </ul>
+
+    <p>
+      <div class="def">Function CXML:MAKE-EXTID (publicid systemid)</div>
+      Create an object representing the External ID composed
+      of the specified Public ID, a rod or <tt>nil</tt>, and System ID
+      (an URI object).
+    </p>
+
+    <p>
+      <div class="def">Condition class CXML:XML-PARSE-ERROR ()</div>
+      Superclass of all conditions signalled by the CXML parser.
+    </p>
+    <p>
+      <div class="def">Condition class CXML:WELL-FORMEDNESS-VIOLATION (cxml:xml-parse-error)</div>
+      This condition is signalled for all well-formedness violations.
+      (Note that, when parsing document that is not well-formed in validating
+      mode, the parser might encounter validity errors before detecting
+      well-formedness problems, so also be prepared for <tt>validity-error</tt>
+      in that situation.)
+    </p>
+    <p>
+      <div class="def">Condition class CXML:VALIDITY-ERROR (cxml:xml-parse-error)</div>
+      Reports the violation of a validity constraint.
+    </p>
+
+    <a name="serialization"/>
+    <h3>Serialization</h3>
+    <p>
+      Serialization is performed using <tt>sink</tt> objects.  There are
+      different kinds of sinks for output to lisp streams and vectors in
+      various flavours.
+    </p>
+    <p>
+      Technically, sinks are SAX handlers that write XML output for SAX
+      events sent to them.  In practise, user code would normally not
+      generate those SAX events manually, and instead use a function
+      like <a href="dom.html#serialization">dom:map-document</a> or <a
+      href="xmls-compat.html">xmls-compat:map-node</a> to serialize an
+      in-memory document.
+    </p>
+    <p>
+      In addition to <tt>map-document</tt>, cxml has a set of
+      convenience macros for serialization (see below for
+      <tt>with-xml-output</tt>, <tt>with-element</tt>, etc).
+    </p>
+
+    <div style="background-color: #ddddff">
+      Portable sinks:<br/>
+      <span class="def">Function CXML:MAKE-OCTET-VECTOR-SINK (&amp;rest keys) => sink</span><br/>
+      <span class="def">Function CXML:MAKE-OCTET-STREAM-SINK (stream &amp;rest keys) => sink</span><br/>
+      <span class="def">Function CXML:MAKE-ROD-SINK (&amp;rest keys) => sink</span><br/>
+      <br/>
+      Only on Lisps with Unicode support:<br/>
+      <span class="def">Function CXML:MAKE-STRING-SINK</span> -- alias for <tt>cxml:make-rod-sink</tt><br/>
+      <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK (stream &amp;rest keys) => sink</span><br/>
+      <br/>
+      Only on Lisps <em>without</em> Unicode support:<br/>
+      <span class="def">Function CXML:MAKE-STRING-SINK/UTF8 (&amp;rest keys) => sink</span><br/>
+      <span class="def">Function CXML:MAKE-CHARACTER-STREAM-SINK/UTF8 (stream &amp;rest keys) => sink</span><br/>
+    </div>
+    <p>
+      Return a SAX serialization handle.
+    </p>
+    <ul>
+      <li>
+        The <tt>-octet-</tt> functions write the document encoded into
+        UTF-8.
+	<tt>make-octet-stream-sink</tt> works with Lisp streams of
+	element-type <tt>(unsigned-byte 8)</tt>.
+	<tt>make-octet-vector-sink</tt> returns a vector of
+	<tt>(unsigned-byte 8)</tt>.
+      </li>
+      <li>
+        <tt>make-character-stream-sink</tt> works with character
+	streams.  It serializes the document into characters <em>without
+	encoding it into an external format</em>.  When using these
+	functions, <em>take care to avoid encoding the result into
+	an incorrect external format</em>.  (Note that characters undergo
+	external format conversion when written to a character stream.
+	If the document's XML declaration specifies an encoding, make
+	sure to specify this encoding as the external format if and when
+	writing the serialized document to a character stream.  If the
+	document does not specify an encoding, either UTF-8 or UTF-16
+	must be used.)  This function is available only on Lisps with
+	unicode support.
+      </li>
+      <li>
+        <tt>make-rod-sink</tt> serializes the document into a vector of
+	runes <em>without encoding it into an external format</em>.
+	(On Lisp with unicode support, the result will be a string;
+	otherwise, a vector of character codes will be returned.)
+	The warnings given for <tt>make-character-stream-sink</tt>
+	apply to this function as well.
+      </li>
+      <li>
+        The <tt>/utf8</tt> functions write the document encoded into
+	characters representing a UTF-8 encoding.
+	When using these functions, <em>take care to avoid encoding the
+	result</em> into an external format for a second time.  (Note
+	that characters undergo external format conversion when written
+	to a character stream.  Since these functions already perform
+	external format conversion, make sure to specify an external
+	format that does "nothing" if and when writing the serialized document
+	to a character stream.  ISO-8859-1 external formats usually
+	achieve the desired effect.)
+	<tt>make-character-stream-sink/utf8</tt> works with character streams.
+	<tt>make-string-sink/utf8</tt> returns a string.
+        These functions are available only on Lisps without unicode support.
+      </li>
+    </ul>
+    <p>Keyword arguments:</p>
+    <ul>
+      <li>
+        <tt>canonical</tt> -- canonical form, one of NIL, T, 1, 2
+      </li>
+      <li>
+        <tt>indentation</tt> -- indentation level.  An integer or <tt>nil</tt>.
+      </li>
+    </ul>
+    <p>
+      The following <tt>canonical</tt> values are allowed:
+    </p>
+    <ul>
+      <li>
+        <tt>t</tt> or <tt>1</tt>: <a
+         href="http://www.w3.org/TR/2001/REC-xml-c14n-20010315">Canonical
+         XML</a>
+      </li>
+      <li>
+        <tt>2</tt>: <a
+         href="http://dev.w3.org/cvsweb/~checkout~/2001/XML-Test-Suite/xmlconf/sun/cxml.html?content-type=text/html;%20charset=iso-8859-1">Second
+         Canonical Form</a>
+      </li>
+      <li>
+        <tt>NIL</tt>: Use a more readable non-canonical representation.
+      </li>
+    </ul>
+    <p>
+      An internal subset will be included in the result regardless of
+      the <tt>canonical</tt> setting.  It is the responsibility of the
+      caller to not report an internal subset for
+      canonical&#160;&lt;=&#160;1, or only notations as required for
+      canonical&#160;=&#160;2.  For example, the
+      <tt>include-doctype</tt> argument to <tt>dom:map-document</tt>
+      should be set to <tt>nil</tt> for the former behaviour and
+      <tt>:canonical-notations</tt> for the latter.
+    </p>
+    <p>
+      With an <tt>indentation</tt> level, pretty-print the XML by
+      inserting additional whitespace.&#160; Note that indentation
+      changes the document model and should only be used if whitespace
+      does not matter to the application.
+    </p>
+
+    <p>
+      <div class="def">Macro CXML:WITH-XML-OUTPUT (sink &amp;body body) => sink-specific result</div>
+      <div class="def">Macro CXML:WITH-NAMESPACE ((prefix uri) &amp;body body) => result</div>
+      <div class="def">Macro CXML:WITH-ELEMENT (qname &amp;body body) => result</div>
+      <div class="def">Macro CXML:WITH-ELEMENT* ((prefix lname) &amp;body body) => result</div>
+      <div class="def">Function CXML:ATTRIBUTE (qname value) => value</div>
+      <div class="def">Generic Function CXML:UNPARSE-ATTRIBUTE (value) => string</div>
+      <div class="def">Function CXML:ATTRIBUTE* (prefix lname value) => value</div>
+      <div class="def">Function CXML:TEXT (data) => data</div>
+      <div class="def">Function CXML:CDATA (data) => data</div>
+      <div class="def">Function CXML:doctype (name public-id system-id &amp;optional internal-subset)</div>
+      Convenience syntax for event-based serialization.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>(with-xml-output (make-octet-stream-sink stream :indentation 2 :canonical nil)
+  (with-element "foo"
+    (attribute "xyz" "abc")
+    (with-element "bar"
+      (attribute "blub" "bla"))
+    (text "Hi there.")))</pre>
+   <p>
+      Prints this to <tt>stream</tt>:
+   </p>
+   <pre>&lt;foo xyz="abc"&gt;
+  &lt;bar blub="bla"&gt;&lt;/bar&gt;
+  Hi there.
+&lt;/foo&gt;</pre>
+
+    <p>
+      <div class="def">Macro XHTML-GENERATOR:WITH-XHTML (sink &amp;rest forms)</div>
+      <div class="def">Macro XHTML-GENERATOR:WRITE-DOCTYPE (sink)</div>
+      Macro <tt>with-xhtml</tt> is a modified version of
+      Franz' <tt>htmlgen</tt> works as a SAX driver for XHTML.
+      It aims to be a plug-in replacement for the <tt>html</tt> macro.
+    </p>
+    <p>
+      <tt>xhtmlgen</tt> is included as <tt>contrib/xhtmlgen.lisp</tt> in
+      the cxml distribution.  Example:
+    </p>
+    <pre>(let ((sink (cxml:make-character-stream-sink *standard-output*)))
+  (sax:start-document sink)
+  (xhtml-generator:write-doctype sink)
+  (xhtml-generator:with-html sink
+    (:html
+     (:head
+      (:title "Titel"))
+     (:body
+      ((:p "style" "font-weight: bold")
+       "Inhalt")
+      (:ul
+       (:li "Eins")
+       (:li "Zwei")
+       (:li "Drei")))))
+  (sax:end-document sink))</pre>
+
+    <a name="misc"/>
+    <h3>Miscellaneous SAX handlers</h3>
+    <p>
+      <div class="def">Function CXML:MAKE-VALIDATOR (dtd root)</div>
+      Create a SAX handler which validates against a DTD instance.&#160;
+      The document's root element must be named <tt>root</tt>.&#160; 
+      Used with <tt>dom:map-document</tt>, this validates a document
+      object as if by re-reading it with a validating parser, except
+      that declarations recorded in the document instance are completely
+      ignored.<br/>
+      Example:
+    </p>
+    <pre>(let ((d (parse-file "~/test.xml" (cxml-dom:make-dom-builder)))
+      (x (parse-dtd-file "~/test.dtd")))
+  (dom:map-document (cxml:make-validator x #"foo") d))</pre>
+
+    <p>
+      <div class="def">Class CXML:BROADCAST-HANDLER ()</div>
+      <div class="def">Accessor CXML:BROADCAST-HANDLER-HANDLERS</div>
+      <div class="def">Function CXML:MAKE-BROADCAST-HANDLER (&amp;rest handlers)</div>
+      <tt>broadcast-handler</tt> is a SAX handler which passes every event it
+      receives on to each of several chained handlers, somewhat similar
+      to the way a <tt>broadcast-stream</tt> works.
+    </p>
+    <p>
+      You can subclass <tt>broadcast-stream</tt> to modify the events
+      before they are being passed on.  Define methods on your handler
+      class for the events to be modified.  All other events will pass
+      through to the chained handlers unmodified.
+    </p>
+    <p>
+      Broadcast handler functions return the result of calling the event
+      function on the <i>last</i> handler in the list.  In particular,
+      the overall result from <tt>sax:end-document</tt> will be ignored
+      for all other handlers.
+    </p>
+
+    <p>
+      <div class="def">Class CXML:SAX-PROXY (broadcast-handler)</div>
+      <div class="def">Accessor CXML:PROXY-CHAINED-HANDLER</div>
+      <tt>sax-proxy</tt> is a subclass of <tt>broadcast-handler</tt>
+      which sends events to exactly one chained handler.  This class is
+      still included for compatibility with older versions of
+      CXML which did not include the more
+      general <tt>broadcast-handler</tt> yet, but has been retrofitted
+      as a subclass of the latter.
+    </p>
+
+    <p>
+    <div class="def">Accessor CXML:MAKE-NAMESPACE-NORMALIZER (next-handler)</div>
+    </p>
+    <p>
+      Return a SAX handler that performs <a
+      href="http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo">DOM
+      3-style namespace normalization</a> on attribute lists in
+      <tt>start-element</tt> events before passing them on the next
+      handler.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-WHITESPACE-NORMALIZER (chained-handler &amp;optional dtd)</div>
+      Return a SAX handler which removes whitespace from elements that
+      have <em>element content</em> and have not been declared to
+      preserve space using an xml:space attribute.
+    </p>
+    <p>Example:</p>
+    <pre>(cxml:parse-file "example.xml"
+                 (cxml:make-whitespace-normalizer (cxml-dom:make-dom-builder))
+                 :validate t)</pre>
+    <p>Example input:</p>
+    <pre>&lt;!DOCTYPE test [
+&lt;!ELEMENT test (foo,bar*)>
+&lt;!ATTLIST test a CDATA #IMPLIED>
+&lt;!ELEMENT foo #PCDATA>
+&lt;!ELEMENT bar (foo?)>
+&lt;!ATTLIST bar xml:space (default|preserve) "default">
+]>
+&lt;test a='b'>
+  &lt;foo>   &lt;/foo>
+  &lt;bar>   &lt;/bar>
+  &lt;bar xml:space="preserve">   &lt;/bar>
+&lt;/test>
+</pre>
+    <p>Example result:</p>
+    <pre>&lt;test a="b">&lt;foo>   &lt;/foo>&lt;bar>&lt;/bar>&lt;bar xml:space="preserve">   &lt;/bar>&lt;/test></pre>
+
+    <a name="rods"/>
+    <h3>Recoders</h3>
+    <p>
+      Recoders are a mechanism used by CXML internally on Lisp implementations
+      without Unicode support to recode UTF-16 vectors (rods) of
+      integers (runes) into UTF-8 strings.
+    </p>
+    <p>
+      User code does not usually need to deal with recoders in current
+      versions of CXML.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div>
+      Return a SAX handler which passes all events on to
+      <tt>chained-handler</tt> after converting all strings and rods
+      using <tt>recoder-fn</tt>, a function of one argument.
+    </p>
+
+    <a name="dtdcache"/>
+    <h3>Caching of DTD Objects</h3>
+    <p>
+      To avoid spending time parsing the same DTD over and over again,
+      CXML can cache DTD objects.  The parser consults
+      <tt>cxml:*dtd-cache*</tt> whenever it is looking for an external
+      subset in a document which does not have an internal subset and
+      uses the cached DTD instance if one is present in the cache for
+      the System ID in question.
+    </p>
+    <p>
+      Note that DTDs do not expire from the cache automatically.
+      (Future versions of CXML might introduce automatic checks for
+      outdated DTDs.)
+    </p>
+    <p>
+      <div class="def">Variable CXML:*DTD-CACHE*</div>
+      The DTD cache object consulted by the parser when it needs a DTD.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-DTD-CACHE ()</div>
+      Return a new, empty DTD cache object.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*CACHE-ALL-DTDS*</div>
+      If true, instructs the parser to enter all DTDs that could have
+      been cached into <tt>*dtd-cache*</tt> if they were not cached
+      already.  Defaults to <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Reader CXML:GETDTD (uri dtd-cache)</div>
+      Return a cached instance of the DTD at <tt>uri</tt>, if present in
+      the cache, or <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Writer CXML:GETDTD (uri dtd-cache)</div>
+      Enter a new value for <tt>uri</tt> into <tt>dtd-cache</tt>.
+    </p>
+    <p>
+      <div class="def">Function CXML:REMDTD (uri dtd-cache)</div>
+      Ensure that no DTD is recorded for <tt>uri</tt> in the cache and
+      return true if such a DTD was present.
+    </p>
+    <p>
+      <div class="def">Function CXML:CLEAR-DTD-CACHE (dtd-cache)</div>
+      Remove all entries from <tt>dtd-cache</tt>.
+    </p>
+    <p>
+      <em>fixme:</em> thread-safety
+    </p>
+
+    <a name="saxparser"/>
+    <h3>Location information</h3>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER ()</div>
+      A class providing location information through an
+      implementation-specific subclass.  Parsers will use
+      <tt>sax:register-sax-parser</tt> to pass their parser instance to
+      the handler.  The easiest way to receive sax parsers instances is
+      to inherit from sax-parser-mixin when defining a sax handler.
+    </p>
+    <p>
+      <div class="def">Class SAX:SAX-PARSER-MIXIN ()</div>
+      A mixin for sax handler classes that records the sax handler
+      object for use with the following functions.  Trampoline methods
+      are provided that allow those functions to be called directly on
+      the sax-parser-mixin.
+    </p>
+    <p>
+      <div class="def">Function SAX:SAX-HANDLER (sax-handler-mixin) => sax-handler</div>
+      Return the sax-parser instance recorded by this handler, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:LINE-NUMBER (sax-parser)</div>
+      Return an approximation of the current line number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:COLUMN-NUMBER (sax-parser)</div>
+      Return an approximation of the current column number, or NIL.
+    </p>
+    <p>
+      <div class="def">Function SAX:SYSTEM-ID (sax-parser)</div>
+      Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.
+    </p>
+    <p>
+      <div class="def">Function SAX:XML-BASE (sax-parser)</div>
+      Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by <tt>sax:system-id</tt> if xml:base
+      attributes are present.
+    </p>
+
+    <a name="catalogs"/>
+    <h3>XML Catalogs</h3>
+    <p>
+      External entities (for example, DTDs) are referred to using their
+      Public and System IDs.  Usually the System ID, a URI, is used to
+      locate the entity.  CXML itself handles only file://-URIs, but
+      many System IDs in practical use are http://-URIs.  There are two
+      different mechanims applications can use to allow CXML to locate
+      entities using arbitrary Public ID or System ID:
+    </p>
+    <ul>
+      <li>
+        User-defined entity resolvers can be used to open entities using
+        arbitrary protocols.   For example, an entity resolver could
+        handle all System-IDs with the <tt>http</tt> scheme using some
+        HTTP library.  Refer to the description of the 
+        <tt>entity-resolver</tt> keyword argument to parser functions (see <a
+        href="#parser"><tt>cxml:parse-file</tt></a>) to more
+        information on entity resolvers.
+      </li>
+      <li>
+        XML Catalogs are (local) tables in XML syntax which map External
+        IDs to alternative System IDs.  If, say, the xhtml DTD is
+        present in the local file system and the local copy has been
+        registered with the XML catalog, CXML will use the local copy of
+        the DTD instead of trying to open the version available using HTTP.
+      </li>
+    </ul>
+    <p>
+      This section describes XML Catalogs, the second solution.  CXML
+      implements <a
+      href="http://www.oasis-open.org/committees/entity/spec.html">Oasis
+      XML Catalogs</a>.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*CATALOG*</div>
+      The XML Catalog object consulted by the parser before trying to
+      open an entity.  Initially <tt>nil</tt>.
+    </p>
+    <p>
+      <div class="def">Variable CXML:*PREFER*</div>
+      The default "prefer" mode from the Catalog specification, one
+      of <tt>:public</tt> or <tt>:system</tt>.  Defaults
+      to <tt>:public</tt>.
+    </p>
+    <p>
+      <div class="def">Function CXML:MAKE-CATALOG (&amp;optional uris)</div>
+      Return a catalog object for the catalog files specified.
+    </p>
+    <p>
+      <div class="def">Function CXML:RESOLVE-URI (uri catalog)</div>
+      Look up <tt>uri</tt> in <tt>catalog</tt> and return the
+      resulting URI, or <tt>nil</tt> if no match was found.
+    </p>
+    <p>
+      <div class="def">Function CXML:RESOLVE-EXTID (publicid systemid catalog)</div>
+      Look up the External ID (<tt>publicid</tt>, <tt>systemid</tt>)
+      in <tt>catalog</tt> and return the resulting URI, or <tt>nil</tt>
+      if no match was found.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>* (setf cxml:*catalog* nil)
+* (cxml:parse-file "test.xhtml" nil)
+=> Error: URI scheme :HTTP not supported
+
+* (setf cxml:*catalog* (cxml:make-catalog))
+* (cxml:parse-file "test.xhtml" nil)
+;; no error!
+NIL</pre>
+    <p>
+      Note that parsed catalog files are cached in the catalog object.
+      Catalog files cached do not expire automatically.  To ensure that
+      all catalog files are parsed again, create a new catalog object.
+    </p>
+
+    <a name="sax"/>
+    <h2>SAX Interface</h2>
+    <p>
+      A SAX handler is an arbitrary objects that implements some of the
+      generic functions in the SAX package.&#160; Note that no default
+      handler class is necessary, because all generic functions have default
+      methods which do nothing.&#160; SAX functions are:
+      <div class="def">Function SAX:START-DOCUMENT (handler)</div>
+      <div class="def">Function SAX:END-DOCUMENT (handler)</div>
+      <br/>
+      <div class="def">Function SAX:START-ELEMENT (handler namespace-uri local-name qname attributes)</div>
+      <div class="def">Function SAX:END-ELEMENT (handler namespace-uri local-name qname)</div>
+      <div class="def">Function SAX:START-PREFIX-MAPPING (handler prefix uri)</div>
+      <div class="def">Function SAX:END-PREFIX-MAPPING (handler prefix)</div>
+      <div class="def">Function SAX:PROCESSING-INSTRUCTION (handler target data)</div>
+      <div class="def">Function SAX:COMMENT (handler data)</div>
+      <div class="def">Function SAX:START-CDATA (handler)</div>
+      <div class="def">Function SAX:END-CDATA (handler)</div>
+      <div class="def">Function SAX:CHARACTERS (handler data)</div>
+      <br/>
+      <div class="def">Function SAX:START-DTD (handler name public-id system-id)</div>
+      <div class="def">Function SAX:END-DTD (handler)</div>
+      <div class="def">Function SAX:START-INTERNAL-SUBSET (handler)</div>
+      <div class="def">Function SAX:END-INTERNAL-SUBSET (handler)</div>
+      <div class="def">Function SAX:UNPARSED-ENTITY-DECLARATION (handler name public-id system-id notation-name)</div>
+      <div class="def">Function SAX:EXTERNAL-ENTITY-DECLARATION (handler kind name public-id system-id)</div>
+      <div class="def">Function SAX:INTERNAL-ENTITY-DECLARATION (handler kind name value)</div>
+      <div class="def">Function SAX:NOTATION-DECLARATION (handler name public-id system-id)</div>
+      <div class="def">Function SAX:ELEMENT-DECLARATION (handler name model)</div>
+      <div class="def">Function SAX:ATTRIBUTE-DECLARATION (handler ename aname type default)</div>
+      <br/>
+      <div class="def">Accessor SAX:ATTRIBUTE-PREFIX (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-NAMESPACE-URI (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-LOCAL-NAME (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-QNAME (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-SPECIFIED-P (attribute)</div>
+      <div class="def">Accessor SAX:ATTRIBUTE-VALUE (attribute)</div>
+      <br/>
+      <div class="def">Function SAX:FIND-ATTRIBUTE (qname attributes)</div>
+      <div class="def">Function SAX:FIND-ATTRIBUTE-NS (uri lname attributes)</div>
+    </p>
+    <p>
+      The entity declaration methods are similar to Java SAX
+      definitions, but parameter entities are distinguished from
+      general entities not by a <tt>%</tt> prefix to the name, but by
+      the <tt>kind</tt> argument, either <tt>:parameter</tt> or
+      <tt>:general</tt>.
+    </p>
+    <p>
+      The arguments to <tt>sax:element-declaration</tt> and
+      <tt>sax:attribute-declaration</tt> differ significantly from their
+      Java counterparts.
+    </p>
+    <p>
+      <i>fixme</i>: For more information on these functions refer to the docstrings.
+    </p>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.html
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.html	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,140 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
+<html>
+<head>
+<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
+<title>CXML XMLS Compatibility</title>
+<link rel="stylesheet" type="text/css" href="cxml.css">
+</head>
+<body>
+<div class="sidebar">
+<div class="sidebar-title"><a href="index.html">Closure XML</a></div>
+<div class="sidebar-main"><ul class="main">
+<li>
+<a href="installation.html">Installing Closure XML</a><ul class="sub">
+<li><a href="installation.html#download"><b>Download</b></a></li>
+<li><a href="installation.html#implementations">Implementation-specific notes</a></li>
+<li><a href="installation.html#compilation">Compilation</a></li>
+<li><a href="installation.html#tests">Tests</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="quickstart.html"><b>Quick-Start Example / FAQ</b></a></li></ul></li>
+<li>
+<a href="sax.html">SAX parsing and serialization</a><ul class="sub">
+<li><a href="sax.html#parser">Parsing and Validating</a></li>
+<li><a href="sax.html#serialization">Serialization</a></li>
+<li><a href="sax.html#misc">Miscellaneous SAX handlers</a></li>
+<li><a href="sax.html#rods">Recoders</a></li>
+<li><a href="sax.html#dtdcache">Caching of DTD Objects</a></li>
+<li><a href="sax.html#catalogs">XML Catalogs</a></li>
+<li><a href="sax.html#sax">SAX Interface</a></li>
+</ul>
+</li>
+<li>
+<a href="klacks.html">Klacks parser</a><ul class="sub">
+<li><a href="klacks.html#sources">Parsing incrementally</a></li>
+<li><a href="klacks.html#convenience">Convenience functions</a></li>
+<li><a href="klacks.html#klacksax">Bridging Klacks and SAX</a></li>
+<li><a href="klacks.html#locator">Location information</a></li>
+<li><a href="klacks.html#klacksax">Examples</a></li>
+</ul>
+</li>
+<li>
+<a href="dom.html">DOM implementation</a><ul class="sub">
+<li><a href="dom.html#parser">Parsing with the DOM builder</a></li>
+<li><a href="dom.html#serialization">Serialization</a></li>
+<li><a href="dom.html#mapping">DOM/Lisp mapping</a></li>
+</ul>
+</li>
+<li><ul class="hack"><li><a href="xmls-compat.html">XMLS Builder</a></li></ul></li>
+</ul></div>
+</div>
+    <h1>XMLS Builder</h1>
+    <p>
+      Like other XML parsers written in Lisp, CXML can work with
+      documents represented as list structures. The specific model
+      implemented by cxml is compatible with the <a href="http://common-lisp.net/project/xmls/">xmls parser</a>.  Xmls
+      list structures are a simpler and faster alternative to full DOM
+      document trees.  They also serve as an example showing how to
+      implement user-defined document models as an independent layer
+      over the the base parser (c.f. <tt>xml/xmls-compat.lisp</tt> in
+      the cxml distribution).  However, note that the list structures do
+      not include all information available in DOM documents
+      (notably, things like <tt>dom:parent-node</tt>) and are
+      sometimes more difficult to work with because of that since many
+      DOM functions cannot be implemented on them.
+    </p>
+    <p>
+      <b>New namespace handling:</b>
+      XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+      XMLS any more.  There is now a mode using pairs of local name
+      and namespace URI, and a second mode using qualified names
+      only.  The old behaviour using pairs of prefix and local names
+      was removed.
+    </p>
+    <p>
+      <strike>
+	fixme: It is unclear to me how namespaces are meant to
+	work in xmls, since xmls documentation differs from how xmls
+	actually works in current releases.  Usually applications need to
+	know both the namespace prefix <em>and</em> the namespace URI.  We
+	currently follow the xmls <em>implementation</em> and use the
+	namespace prefix instead of following its <em>documentation</em> which
+	shows the URI.  We do not follow xmls in munging xmlns attribute
+	values.  Attributes themselves have namespaces and it is not clear
+	to me how that works in xmls.
+      </strike>
+    </p>
+    <p>
+      <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&amp;key include-default-values include-namespace-uri)</div>
+      Create a SAX handler which builds XMLS list structures.?
+      If <tt>include-default-values</tt> is true, default values for
+      attributes declared in a DTD are included as attributes in the
+      xmls output.  <tt>include-default-values</tt> is true by default
+      and can be set to <tt>nil</tt> to suppress inclusion of default
+      values.
+    </p>
+    <p>
+      If <tt>include-namespace-uri</tt> is true (the default), node
+      names and attribute names are pairs of local name and namespace
+      URI. (Except for attributes without a namespace, which are named
+      using a string.) Otherwise, nodes and attributes are named by
+      their qualified name.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre>
+    <p>
+      <div class="def">Function CXML-XMLS:MAP-NODE (handler node &amp;key include-xmlns-attributes include-namespace-uri)</div>
+      Traverse an XMLS document/node and call SAX functions as if an XML
+      representation of the document were processed by a SAX parser.
+    </p>
+    <p>
+      Use this function to serialize XMLS data.  For example, we could
+      define a replacement for <tt>xmls:write-xml</tt> like this:
+    </p>
+    <pre>(defun write-xml (stream node &amp;key indent)
+  (let ((sink (cxml:make-character-stream-sink
+               stream :canonical nil :indentation indent)))
+    (cxml-xmls:map-node sink node)))</pre>
+    <p>
+      <div class="def">Function CXML-XMLS:MAKE-NODE (&amp;key name ns attrs
+      children) =&gt; xmls node</div>
+      Build a list node of the form
+      (<em>name</em>?((<em>name</em>?<em>value</em>)<em>*</em>)?<em>child*</em>).
+    </p>
+    <p>
+      The node list's <tt>car</tt> can also be a cons of local <tt>name</tt>
+      and namespace prefix <tt>ns</tt>.
+    </p>
+    <p>
+      <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-ATTRS (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-CHILDREN (node)</div>
+      Accessors for xmls node data.
+    </p>
+    <p>
+    </p>
+</body>
+</html>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.xml
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/doc/xmls-compat.xml	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,91 @@
+<documentation title="CXML XMLS Compatibility">
+    <h1>XMLS Builder</h1>
+    <p>
+      Like other XML parsers written in Lisp, CXML can work with
+      documents represented as list structures. The specific model
+      implemented by cxml is compatible with the <a
+      href="http://common-lisp.net/project/xmls/">xmls parser</a>.  Xmls
+      list structures are a simpler and faster alternative to full DOM
+      document trees.  They also serve as an example showing how to
+      implement user-defined document models as an independent layer
+      over the the base parser (c.f. <tt>xml/xmls-compat.lisp</tt> in
+      the cxml distribution).  However, note that the list structures do
+      not include all information available in DOM documents
+      (notably, things like <tt>dom:parent-node</tt>) and are
+      sometimes more difficult to work with because of that since many
+      DOM functions cannot be implemented on them.
+    </p>
+    <p>
+      <b>New namespace handling:</b>
+      XMLS compatibility is not <i>bug-for-bug</i>-compatible with
+      XMLS any more.  There is now a mode using pairs of local name
+      and namespace URI, and a second mode using qualified names
+      only.  The old behaviour using pairs of prefix and local names
+      was removed.
+    </p>
+    <p>
+      <strike>
+	fixme: It is unclear to me how namespaces are meant to
+	work in xmls, since xmls documentation differs from how xmls
+	actually works in current releases.  Usually applications need to
+	know both the namespace prefix <em>and</em> the namespace URI.  We
+	currently follow the xmls <em>implementation</em> and use the
+	namespace prefix instead of following its <em>documentation</em> which
+	shows the URI.  We do not follow xmls in munging xmlns attribute
+	values.  Attributes themselves have namespaces and it is not clear
+	to me how that works in xmls.
+      </strike>
+    </p>
+    <p>
+      <div class="def">Function CXML-XMLS:MAKE-XMLS-BUILDER (&amp;key include-default-values include-namespace-uri)</div>
+      Create a SAX handler which builds XMLS list structures.&#160;
+      If <tt>include-default-values</tt> is true, default values for
+      attributes declared in a DTD are included as attributes in the
+      xmls output.  <tt>include-default-values</tt> is true by default
+      and can be set to <tt>nil</tt> to suppress inclusion of default
+      values.
+    </p>
+    <p>
+      If <tt>include-namespace-uri</tt> is true (the default), node
+      names and attribute names are pairs of local name and namespace
+      URI. (Except for attributes without a namespace, which are named
+      using a string.) Otherwise, nodes and attributes are named by
+      their qualified name.
+    </p>
+    <p>
+      Example:
+    </p>
+    <pre>(cxml:parse-file "test.xml" (cxml-xmls:make-xmls-builder))</pre>
+    <p>
+      <div class="def">Function CXML-XMLS:MAP-NODE (handler node &amp;key include-xmlns-attributes include-namespace-uri)</div>
+      Traverse an XMLS document/node and call SAX functions as if an XML
+      representation of the document were processed by a SAX parser.
+    </p>
+    <p>
+      Use this function to serialize XMLS data.  For example, we could
+      define a replacement for <tt>xmls:write-xml</tt> like this:
+    </p>
+    <pre>(defun write-xml (stream node &amp;key indent)
+  (let ((sink (cxml:make-character-stream-sink
+               stream :canonical nil :indentation indent)))
+    (cxml-xmls:map-node sink node)))</pre>
+    <p>
+      <div class="def">Function CXML-XMLS:MAKE-NODE (&amp;key name ns attrs
+      children) => xmls node</div>
+      Build a list node of the form
+      (<em>name</em>&#160;((<em>name</em>&#160;<em>value</em>)<em>*</em>)&#160;<em>child*</em>).
+    </p>
+    <p>
+      The node list's <tt>car</tt> can also be a cons of local <tt>name</tt>
+      and namespace prefix <tt>ns</tt>.
+    </p>
+    <p>
+      <div class="def">Accessor CXML-XMLS:NODE-NAME (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-NS (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-ATTRS (node)</div>
+      <div class="def">Accessor CXML-XMLS:NODE-CHILDREN (node)</div>
+      Accessors for xmls node data.
+    </p>
+    <p>
+    </p>
+</documentation>

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/documentation.css
==============================================================================

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-builder.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-builder.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,235 @@
+;;;; dom-builder.lisp -- DOM-building SAX handler
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;; Author: Henrik Motakef <hmot at henrik-motakef.de>
+;;;; Author: David Lichteblau <david at lichteblau.com>
+;;;; Author: knowledgeTools Int. GmbH
+
+#-cxml-system::utf8dom-file
+(in-package :rune-dom)
+
+#+cxml-system::utf8dom-file
+(in-package :utf8-dom)
+
+
+(defclass dom-builder (sax:content-handler)
+  ((document      :initform nil :accessor document)
+   (element-stack :initform '() :accessor element-stack)
+   (internal-subset             :accessor internal-subset)
+   (text-buffer   :initform nil :accessor text-buffer)))
+
+#+(and rune-is-integer (not cxml-system::utf8dom-file))
+(defmethod hax:%want-strings-p ((handler dom-builder))
+  nil)
+
+(defun make-dom-builder ()
+  (make-instance 'dom-builder))
+
+(defun fast-push (new-element vector)
+  (vector-push-extend new-element vector (max 1 (array-dimension vector 0))))
+
+(defmethod sax:start-document ((handler dom-builder))
+  (when (and sax:*namespace-processing*
+	     (not (and sax:*include-xmlns-attributes*
+		       sax:*use-xmlns-namespace*)))
+    (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
+  (let ((document (make-instance 'document)))
+    (setf (slot-value document 'owner) nil
+	  (slot-value document 'doc-type) nil)
+    (setf (document handler) document)
+    (push document (element-stack handler))))
+
+;; fixme
+(defmethod sax::dtd ((handler dom-builder) dtd)
+  (setf (slot-value (document handler) 'dtd) dtd))
+
+(defmethod sax:end-document ((handler dom-builder))
+  (let ((doctype (dom:doctype (document handler))))
+    (when doctype
+      (setf (slot-value (dom:entities doctype) 'read-only-p) t)
+      (setf (slot-value (dom:notations doctype) 'read-only-p) t)))
+  (document handler))
+
+(defmethod sax:entity-resolver ((handler dom-builder) resolver)
+  (setf (slot-value (document handler) 'entity-resolver) resolver))
+
+(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
+  (let* ((document (document handler))
+         (doctype (%create-document-type name publicid systemid)))
+    (setf (slot-value doctype 'owner) document
+	  (slot-value (dom:notations doctype) 'owner) document
+	  (slot-value (dom:entities doctype) 'owner) document
+	  (slot-value document 'doc-type) doctype)))
+
+(defmethod sax:start-internal-subset ((handler dom-builder))
+  (setf (internal-subset handler) nil))
+
+(defmethod sax:end-internal-subset ((handler dom-builder))
+  (setf (dom::%internal-subset (slot-value (document handler) 'doc-type))
+	(nreverse (internal-subset handler)))
+  (slot-makunbound handler 'internal-subset))
+
+(macrolet ((defhandler (name &rest args)
+	     `(defmethod ,name ((handler dom-builder) , at args)
+		(when (slot-boundp handler 'internal-subset)
+		  (push (list ',name , at args) (internal-subset handler))))))
+  (defhandler sax:unparsed-entity-declaration
+      name public-id system-id notation-name)
+  (defhandler sax:external-entity-declaration
+      kind name public-id system-id)
+  (defhandler sax:internal-entity-declaration
+      kind name value)
+  (defhandler sax:notation-declaration
+      name public-id system-id)
+  (defhandler sax:element-declaration
+      name model)
+  (defhandler sax:attribute-declaration
+      element-name attribute-name type default))
+
+(defmethod sax:start-element
+    ((handler dom-builder) namespace-uri local-name qname attributes)
+  (check-type qname rod)		;catch recoder/builder mismatch
+  (flush-characters handler)
+  (with-slots (document element-stack) handler
+    (let* ((nsp sax:*namespace-processing*)
+	   (element (make-instance 'element 
+                     :tag-name qname
+                     :owner document
+		     :namespace-uri (when nsp namespace-uri)
+		     :local-name (when nsp local-name)
+		     :prefix (%rod (when nsp (cxml::split-qname (real-rod qname))))))
+	  (parent (car element-stack))
+          (anodes '()))
+      (dolist (attr attributes)
+	(let ((anode
+               (if nsp
+		   (dom:create-attribute-ns document
+					    (sax:attribute-namespace-uri attr)
+					    (sax:attribute-qname attr))
+		   (dom:create-attribute document (sax:attribute-qname attr))))
+              (text
+               (dom:create-text-node document (sax:attribute-value attr))))
+          (setf (slot-value anode 'specified-p)
+                (sax:attribute-specified-p attr))
+	  (setf (slot-value anode 'owner-element) element)
+          (dom:append-child anode text)
+          (push anode anodes)))
+      (setf (slot-value element 'parent) parent)
+      (fast-push element (slot-value parent 'children))
+      (let ((map
+	      (make-instance 'attribute-node-map
+		:items anodes
+		:element-type :attribute
+		:element element
+		:owner document)))
+	(setf (slot-value element 'attributes) map)
+	(dolist (anode anodes)
+	  (setf (slot-value anode 'map) map)))
+      (push element element-stack))))
+
+(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
+  (declare (ignore namespace-uri local-name qname))
+  (flush-characters handler)
+  (pop (element-stack handler)))
+
+(defmethod sax:characters ((handler dom-builder) data)
+  (with-slots (text-buffer) handler
+    (cond
+      ((null text-buffer)
+       (setf text-buffer data))
+      (t
+       (unless (array-has-fill-pointer-p text-buffer)
+	 (setf text-buffer (make-array (length text-buffer)
+				       :element-type 'rune
+				       :adjustable t
+				       :fill-pointer t
+				       :initial-contents text-buffer)))
+       (let ((n (length text-buffer))
+	     (m (length data)))
+	 (adjust-vector-exponentially text-buffer (+ n m) t)
+	 (move data text-buffer 0 n m))))))
+
+(defun flush-characters (handler)
+  (with-slots (document element-stack text-buffer) handler
+    (let ((data text-buffer))
+      (when data
+	(when (array-has-fill-pointer-p data)
+	  (setf data
+		(make-array (length data)
+			    :element-type 'rune
+			    :initial-contents data)))
+	(let ((parent (car element-stack)))
+	  (if (eq (dom:node-type parent) :cdata-section)
+	      (setf (dom:data parent) data)
+	      (let ((node (dom:create-text-node document data)))
+		(setf (slot-value node 'parent) parent)
+		(fast-push node (slot-value (car element-stack) 'children)))))
+	(setf text-buffer nil)))))
+
+(defmethod sax:start-cdata ((handler dom-builder))
+  (flush-characters handler)
+  (with-slots (document element-stack) handler
+    (let ((node (dom:create-cdata-section document #""))
+          (parent (car element-stack)))
+      (setf (slot-value node 'parent) parent)
+      (fast-push node (slot-value parent 'children))
+      (push node element-stack))))
+
+(defmethod sax:end-cdata ((handler dom-builder))
+  (flush-characters handler)
+  (let ((node (pop (slot-value handler 'element-stack))))
+    (assert (eq (dom:node-type node) :cdata-section))))
+
+(defmethod sax:processing-instruction ((handler dom-builder) target data)
+  (flush-characters handler)
+  (with-slots (document element-stack) handler
+    (let ((node (dom:create-processing-instruction document target data))
+          (parent (car element-stack)))
+      (setf (slot-value node 'parent) parent)
+      (fast-push node (slot-value (car element-stack) 'children)))))
+
+(defmethod sax:comment ((handler dom-builder) data)
+  (flush-characters handler)
+  (with-slots (document element-stack) handler
+    (let ((node (dom:create-comment document data))
+          (parent (car element-stack)))
+      (setf (slot-value node 'parent) parent)
+      (fast-push node (slot-value (car element-stack) 'children)))))
+
+(defmethod sax:unparsed-entity-declaration
+    ((handler dom-builder) name public-id system-id notation-name)
+  (set-entity handler name public-id system-id notation-name))
+
+(defmethod sax:external-entity-declaration
+    ((handler dom-builder) kind name public-id system-id)
+  (ecase kind
+    (:general (set-entity handler name public-id system-id nil))
+    (:parameter)))
+
+(defmethod sax:internal-entity-declaration
+    ((handler dom-builder) kind name value)
+  (declare (ignore value))
+  (ecase kind
+    (:general (set-entity handler name nil nil nil))
+    (:parameter)))
+
+(defun set-entity (handler name pid sid notation)
+  (dom:set-named-item (dom:entities (dom:doctype (document handler)))
+                      (make-instance 'entity
+                        :owner (document handler)
+                        :name name
+                        :public-id pid
+                        :system-id sid
+                        :notation-name notation)))
+
+(defmethod sax:notation-declaration
+    ((handler dom-builder) name public-id system-id)
+  (dom:set-named-item (dom:notations (dom:doctype (document handler)))
+                      (make-instance 'notation
+                        :owner (document handler)
+                        :name name
+                        :public-id public-id
+                        :system-id system-id)))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-impl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-impl.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,1479 @@
+;;;; dom-impl.lisp -- Implementation of DOM 1 Core -*- package: rune-dom -*-
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;; Author: David Lichteblau <david at lichteblau.com>
+;;;; Author: knowledgeTools Int. GmbH
+
+#-cxml-system::utf8dom-file
+(defpackage :rune-dom
+  (:use :cl :runes)
+  #+rune-is-character (:nicknames :cxml-dom)
+  (:export #:implementation #:make-dom-builder #:create-document))
+
+#+cxml-system::utf8dom-file
+(defpackage :utf8-dom
+  (:use :cl :utf8-runes)
+  (:nicknames :cxml-dom)
+  (:export #:implementation #:make-dom-builder #:create-document))
+
+#-cxml-system::utf8dom-file
+(in-package :rune-dom)
+
+#+cxml-system::utf8dom-file
+(in-package :utf8-dom)
+
+
+;; Classes
+
+(define-condition dom-exception (error)
+  ((key       :initarg :key       :reader dom-exception-key)
+   (string    :initarg :string    :reader dom-exception-string)
+   (arguments :initarg :arguments :reader dom-exception-arguments))
+  (:report
+   (lambda (c s)
+     (format s "~A (~D):~%~?"
+             (dom-exception-key c)
+             (dom:code c)
+             (dom-exception-string c)
+             (dom-exception-arguments c)))))
+
+(defclass node (dom:node)
+  ((parent      :initarg :parent        :initform nil)
+   (children    :initarg :children      :initform (make-node-list))
+   (owner       :initarg :owner         :initform nil)
+   (read-only-p :initform nil           :reader read-only-p)
+   (map         :initform nil)))
+
+(defmethod dom:prefix ((node node)) nil)
+(defmethod dom:local-name ((node node)) nil)
+(defmethod dom:namespace-uri ((node node)) nil)
+
+(defclass namespace-mixin ()
+  ((prefix        :initarg :prefix        :reader dom:prefix)
+   (local-name    :initarg :local-name    :reader dom:local-name)
+   (namespace-uri :initarg :namespace-uri :reader dom:namespace-uri)))
+
+(defmethod (setf dom:prefix) (newval (node namespace-mixin))
+  (assert-writeable node)
+  (when newval
+    (safe-split-qname (concatenate 'rod newval #":foo")
+		      (dom:namespace-uri node)))
+  (setf (slot-value node 'prefix) newval))
+
+(defclass document (node dom:document)
+  ((doc-type    :initarg :doc-type     :reader dom:doctype)
+   (dtd         :initform nil          :reader dtd)
+   (entity-resolver :initform nil)))
+
+(defclass document-fragment (node dom:document-fragment)
+  ())
+
+(defclass character-data (node dom:character-data)
+  ((value       :initarg :data          :reader dom:data)))
+
+(defclass attribute (namespace-mixin node dom:attr)
+  ((name        :initarg :name          :reader dom:name)
+   (owner-element :initarg :owner-element :reader dom:owner-element)
+   (specified-p :initarg :specified-p   :reader dom:specified)))
+
+(defmethod (setf dom:prefix) :before (newval (node attribute))
+  (when (rod= (dom:node-name node) #"xmlns")
+    (dom-error :NAMESPACE_ERR "must not change xmlns attribute prefix")))
+
+(defmethod (setf dom:prefix) :after (newval (node attribute))
+  (setf (slot-value node 'name)
+	(concatenate 'rod newval #":" (dom:local-name node))))
+
+(defmethod print-object ((object attribute) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (format stream "~A=~S"
+            (rod-string (dom:name object))
+            (rod-string (dom:value object)))))
+
+(defclass element (namespace-mixin node dom:element)
+  ((tag-name    :initarg :tag-name      :reader dom:tag-name)
+   (attributes  :initarg :attributes    :reader dom:attributes)))
+
+(defmethod (setf dom:prefix) :after (newval (node element))
+  (setf (slot-value node 'tag-name)
+	(concatenate 'rod newval #":" (dom:local-name node))))
+
+(defmethod print-object ((object element) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (princ (rod-string (dom:tag-name object)) stream)))
+
+(defclass text (character-data dom:text)
+  ())
+
+(defclass comment (character-data dom:comment)
+  ())
+
+(defclass cdata-section (text dom:cdata-section)
+  ())
+
+(defclass document-type (node dom:document-type)
+  ((name          :initarg :name          :reader dom:name)
+   (public-id     :initarg :public-id     :reader dom:public-id)
+   (system-id     :initarg :system-id     :reader dom:system-id)
+   (entities      :initarg :entities      :reader dom:entities)
+   (notations     :initarg :notations     :reader dom:notations)
+   (dom::%internal-subset                 :accessor dom::%internal-subset)))
+
+(defclass notation (node dom:notation)
+  ((name          :initarg :name          :reader dom:name)
+   (public-id     :initarg :public-id     :reader dom:public-id)
+   (system-id     :initarg :system-id     :reader dom:system-id)))
+
+(defclass entity (node dom:entity)
+  ((name          :initarg :name          :reader dom:name)
+   (public-id     :initarg :public-id     :reader dom:public-id)
+   (system-id     :initarg :system-id     :reader dom:system-id)
+   (notation-name :initarg :notation-name :reader dom:notation-name)))
+
+(defclass entity-reference (node dom:entity-reference)
+  ((name          :initarg :name          :reader dom:name)))
+
+(defclass processing-instruction (node dom:processing-instruction)
+  ((target        :initarg :target        :reader dom:target)
+   (data          :initarg :data          :reader dom:data)))
+
+(defclass named-node-map (dom:named-node-map)
+  ((items         :initarg :items         :reader dom:items
+                  :initform nil)
+   (owner         :initarg :owner         :reader dom:owner-document)
+   (read-only-p   :initform nil           :reader read-only-p)
+   (element-type  :initarg :element-type)))
+
+(defclass attribute-node-map (named-node-map)
+  ((element       :initarg :element)))
+
+
+;;; Implementation
+
+(defun %rod (x)
+  (etypecase x
+    (null x)
+    (rod x)
+    #+cxml-system::utf8dom-file (runes::rod (cxml::rod-to-utf8-string x))
+    (string (string-rod x))
+    (vector x)))
+
+#-cxml-system::utf8dom-file
+(defun real-rod (x)
+  (%rod x))
+
+#+cxml-system::utf8dom-file
+(defun real-rod (x)
+  (etypecase x
+    (null x)
+    (runes::rod x)
+    (string (cxml::utf8-string-to-rod x))))
+
+(defun valid-name-p (x)
+  (cxml::valid-name-p (real-rod x)))
+
+(defun assert-writeable (node)
+  (when (read-only-p node)
+    (dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node)))
+
+(defun dom:map-node-list (fn nodelist)
+  (dotimes (i (dom:length nodelist))
+    (funcall fn (dom:item nodelist i))))
+
+(defmacro dom:do-node-list ((var nodelist &optional resultform) &body body)
+  `(block nil
+     (dom:map-node-list (lambda (,var) , at body) ,nodelist)
+     ,resultform))
+
+(defun dom:map-node-map (fn node-map)
+  (with-slots (items) node-map
+    (mapc fn items)))
+
+(defmacro dom:do-node-map ((var node-map &optional resultform) &body body)
+  `(block nil
+     (dom:map-node-map (lambda (,var) , at body) ,node-map)
+     ,resultform))
+
+(defmacro dovector ((var vector &optional resultform) &body body)
+  `(loop
+       for ,var across ,vector do (progn , at body)
+       ,@(when resultform `(finally (return ,resultform)))))
+
+(defun move (from to from-start to-start length)
+  ;; like (setf (subseq to to-start (+ to-start length))
+  ;;            (subseq from from-start (+ from-start length)))
+  ;; but without creating the garbage.
+  ;; Also, this is using AREF not ELT so that fill-pointers are ignored.
+  (if (< to-start from-start)
+      (loop
+          repeat length
+          for i from from-start
+          for j from to-start
+          do (setf (aref to j) (aref from i)))
+      (loop
+          repeat length
+          for i downfrom (+ from-start length -1)
+          for j downfrom (+ to-start length -1)
+          do (setf (aref to j) (aref from i)))))
+
+(defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p)
+  (let ((d (array-dimension vector 0)))
+    (when (< d new-dimension)
+      (loop
+	  do (setf d (* 2 d))
+	  while (< d new-dimension))
+      (adjust-array vector d))
+    (when set-fill-pointer-p
+      (setf (fill-pointer vector) new-dimension))))
+
+(defun make-space (vector &optional (n 1))
+  (adjust-vector-exponentially vector (+ (length vector) n) nil))
+
+(defun extension (vector)
+  (max (array-dimension vector 0) 1))
+
+;; dom-exception
+
+(defun dom-error (key fmt &rest args)
+  (error 'dom-exception :key key :string fmt :arguments args))
+
+(defmethod dom:code ((self dom-exception))
+  (ecase (dom-exception-key self)
+    (:INDEX_SIZE_ERR                    1)
+    (:DOMSTRING_SIZE_ERR                2)
+    (:HIERARCHY_REQUEST_ERR             3)
+    (:WRONG_DOCUMENT_ERR                4)
+    (:INVALID_CHARACTER_ERR             5)
+    (:NO_DATA_ALLOWED_ERR               6)
+    (:NO_MODIFICATION_ALLOWED_ERR       7)
+    (:NOT_FOUND_ERR                     8)
+    (:NOT_SUPPORTED_ERR                 9)
+    (:INUSE_ATTRIBUTE_ERR               10)
+    (:INVALID_STATE_ERR                 11)
+    (:SYNTAX_ERR                        12)
+    (:INVALID_MODIFICATION_ERR          13)
+    (:NAMESPACE_ERR                     14)
+    (:INVALID_ACCESS_ERR                15)))
+
+;; dom-implementation protocol
+
+(defmethod dom:has-feature ((factory (eql 'implementation)) feature version)
+  (and (or (string-equal (rod-string feature) "xml")
+	   (string-equal (rod-string feature) "core"))
+       (or (zerop (length version))
+	   (string-equal (rod-string version) "1.0")
+	   (string-equal (rod-string version) "2.0"))))
+
+(defun %create-document-type (name publicid systemid)
+  (make-instance 'document-type
+    :name name
+    :notations (make-instance 'named-node-map
+		 :element-type :notation
+		 :owner nil)
+    :entities (make-instance 'named-node-map
+		:element-type :entity
+		:owner nil)
+    :public-id publicid
+    :system-id systemid))
+
+(defmethod dom:create-document-type
+    ((factory (eql 'implementation)) name publicid systemid)
+  (safe-split-qname name #"")
+  (let ((result (%create-document-type name publicid systemid)))
+    (setf (slot-value (dom:entities result) 'read-only-p) t)
+    (setf (slot-value (dom:notations result) 'read-only-p) t)
+    result))
+
+(defmethod dom:create-document
+    ((factory (eql 'implementation)) uri qname doctype)
+  (let ((document (make-instance 'document)))
+    (setf (slot-value document 'owner) nil
+	  (slot-value document 'doc-type) doctype)
+    (when doctype
+      (unless (typep doctype 'document-type)
+	(dom-error :WRONG_DOCUMENT_ERR
+		   "doctype was created by a different dom implementation"))
+      (when (dom:owner-document doctype)
+	(dom-error :WRONG_DOCUMENT_ERR "doctype already in use"))
+      (setf (slot-value doctype 'owner) document
+	    (slot-value (dom:notations doctype) 'owner) document
+	    (slot-value (dom:entities doctype) 'owner) document))
+    (when (or uri qname)
+      (dom:append-child document (dom:create-element-ns document uri qname)))
+    document))
+
+;; document-fragment protocol
+;; document protocol
+
+(defmethod dom:implementation ((document document))
+  'implementation)
+
+(defmethod dom:document-element ((document document))
+  (dovector (k (dom:child-nodes document))
+    (cond ((typep k 'element)
+           (return k)))))
+
+(defmethod dom:create-element ((document document) tag-name)
+  (setf tag-name (%rod tag-name))
+  (unless (valid-name-p tag-name)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
+  (let ((result (make-instance 'element
+                  :tag-name tag-name
+		  :namespace-uri nil
+		  :local-name nil
+		  :prefix nil
+                  :owner document)))
+    (setf (slot-value result 'attributes)
+          (make-instance 'attribute-node-map
+            :element-type :attribute
+            :owner document
+            :element result))
+    (add-default-attributes result)
+    result))
+
+(defun safe-split-qname (qname uri)
+  (unless (valid-name-p qname)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname)))
+  (multiple-value-bind (prefix local-name)
+      (handler-case
+	  (cxml::split-qname (real-rod qname))
+	(cxml:well-formedness-violation (c)
+	  (dom-error :NAMESPACE_ERR "~A" c)))
+    (setf local-name (%rod local-name))
+    (when prefix
+      (setf prefix (%rod prefix))
+      (unless uri
+	(dom-error :NAMESPACE_ERR "prefix specified but no namespace URI"))
+      (when (and (rod= prefix #"xml")
+		 (not (rod= uri #"http://www.w3.org/XML/1998/namespace")))
+	(dom-error :NAMESPACE_ERR "invalid uri for prefix `xml'"))
+      (when (and (rod= prefix #"xmlns")
+		 (not (rod= uri #"http://www.w3.org/2000/xmlns/")))
+	(dom-error :NAMESPACE_ERR "invalid uri for prefix `xmlns'")))
+    (values prefix local-name)))
+
+(defmethod dom:create-element-ns ((document document) uri qname)
+  (setf qname (%rod qname))
+  (multiple-value-bind (prefix local-name)
+      (safe-split-qname qname uri)
+    (let ((result (make-instance 'element
+		    :tag-name qname
+		    :namespace-uri uri
+		    :local-name local-name
+		    :prefix prefix
+		    :owner document)))
+      (setf (slot-value result 'attributes)
+	    (make-instance 'attribute-node-map
+	      :element-type :attribute
+	      :owner document
+	      :element result))
+      (add-default-attributes result)
+      result)))
+
+(defmethod dom:create-document-fragment ((document document))
+  (make-instance 'document-fragment
+    :owner document))
+
+(defmethod dom:create-text-node ((document document) data)
+  (setf data (%rod data))
+  (make-instance 'text
+    :data data
+    :owner document))
+
+(defmethod dom:create-comment ((document document) data)
+  (setf data (%rod data))
+  (make-instance 'comment
+    :data data
+    :owner document))
+
+(defmethod dom:create-cdata-section ((document document) data)
+  (setf data (%rod data))
+  (make-instance 'cdata-section
+    :data data
+    :owner document))
+
+(defmethod dom:create-processing-instruction ((document document) target data)
+  (setf target (%rod target))
+  (setf data (%rod data))
+  (unless (valid-name-p target)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
+  (make-instance 'processing-instruction
+    :owner document
+    :target target
+    :data data))
+
+(defmethod dom:create-attribute ((document document) name)
+  (setf name (%rod name))
+  (unless (valid-name-p name)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
+  (make-instance 'attribute
+    :name name
+    :local-name nil
+    :prefix nil
+    :namespace-uri nil
+    :specified-p t
+    :owner-element nil
+    :owner document))
+
+(defmethod dom:create-attribute-ns ((document document) uri qname)
+  (setf uri (%rod uri))
+  (setf qname (%rod qname))
+  (when (and (rod= qname #"xmlns")
+	     (not (rod= uri #"http://www.w3.org/2000/xmlns/")))
+    (dom-error :NAMESPACE_ERR "invalid uri for qname `xmlns'"))
+  (multiple-value-bind (prefix local-name)
+      (safe-split-qname qname uri)
+    (make-instance 'attribute
+      :name qname
+      :namespace-uri uri
+      :local-name local-name
+      :prefix prefix
+      :specified-p t
+      :owner-element nil
+      :owner document)))
+
+(defmethod dom:create-entity-reference ((document document) name)
+  (setf name (%rod name))
+  (unless (valid-name-p name)
+    (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
+  (make-instance 'entity-reference
+    :name name
+    :owner document))
+
+(defmethod get-elements-by-tag-name-internal (node tag-name)
+  (setf tag-name (%rod tag-name))
+  (let ((result (make-node-list))
+	(wild-p (rod= tag-name #"*")))
+    (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
+		   (when (or wild-p (rod= tag-name (dom:node-name c)))
+		     (vector-push-extend c result (extension result)))
+		   (walk c)))))
+      (walk node))
+    result))
+
+(defmethod get-elements-by-tag-name-internal-ns (node uri lname)
+  (setf uri (%rod uri))
+  (setf lname (%rod lname))
+  (let ((result (make-node-list))
+	(wild-uri-p (rod= uri #"*"))
+	(wild-lname-p (rod= lname #"*")))
+    (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
+		   (when (and (or wild-lname-p (rod= lname (dom:local-name c)))
+			      (or wild-uri-p (rod= uri (dom:namespace-uri c))))
+		     (vector-push-extend c result (extension result)))
+		   (walk c)))))
+      (walk node))
+    result))
+
+(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
+  (get-elements-by-tag-name-internal document tag-name))
+
+(defmethod dom:get-elements-by-tag-name-ns ((document document) uri lname)
+  (get-elements-by-tag-name-internal-ns document uri lname))
+
+(defmethod dom:get-element-by-id ((document document) id)
+  (block t
+    (unless (dtd document)
+      (return-from t nil))
+    (setf id (%rod id))
+    (labels ((walk (n)
+	       (dovector (c (dom:child-nodes n))
+		 (when (dom:element-p c)
+		   (let ((e (cxml::find-element
+			     (real-rod (dom:tag-name c))
+			     (dtd document))))
+		     (when e
+		       (dolist (a (cxml::elmdef-attributes e))
+			 (when (eq :ID (cxml::attdef-type a))
+			   (let* ((name (%rod (cxml::attdef-name a)))
+				  (value (dom:get-attribute c name)))
+			     (when (and value (rod= value id))
+			       (return-from t c)))))))
+		   (walk c)))))
+      (walk document))))
+
+
+;;; Node
+
+(defmethod dom:has-attributes ((element node))
+  nil)
+
+(defmethod dom:is-supported ((node node) feature version)
+  (dom:has-feature 'implementation feature version))
+
+(defmethod dom:parent-node ((node node))
+  (slot-value node 'parent))
+
+(defmethod dom:child-nodes ((node node))
+  (slot-value node 'children))
+
+(defmethod dom:first-child ((node node))
+  (dom:item (slot-value node 'children) 0))
+
+(defmethod dom:last-child ((node node))
+  (with-slots (children) node
+    (if (plusp (length children))
+        (elt children (1- (length children)))
+        nil)))
+
+(defmethod dom:previous-sibling ((node node))
+  (with-slots (parent) node
+    (when parent
+      (with-slots (children) parent
+        (let ((index (1- (position node children))))
+          (if (eql index -1)
+              nil
+              (elt children index)))))))
+
+(defmethod dom:next-sibling ((node node))
+  (with-slots (parent) node
+    (when parent
+      (with-slots (children) parent
+        (let ((index (1+ (position node children))))
+          (if (eql index (length children))
+              nil
+              (elt children index)))))))
+
+(defmethod dom:owner-document ((node node))
+  (slot-value node 'owner))
+
+(defun ensure-valid-insertion-request (node new-child)
+  (assert-writeable node)
+  (unless (can-adopt-p node new-child)
+    (dom-error :HIERARCHY_REQUEST_ERR "~S cannot adopt ~S." node new-child))
+  #+(or)                                ;XXX needs to be moved elsewhere
+  (when (eq (dom:node-type node) :document)
+    (let ((child-type (dom:node-type new-child)))
+      (when (and (member child-type '(:element :document-type))
+                 (find child-type (dom:child-nodes node) :key #'dom:node-type))
+        (dom-error :HIERARCHY_REQUEST_ERR
+                   "~S cannot adopt a second child of type ~S."
+                   node child-type))))
+  (unless (eq (if (eq (dom:node-type node) :document)
+                  node
+                  (dom:owner-document node))
+              (dom:owner-document new-child))
+    (dom-error :WRONG_DOCUMENT_ERR
+               "~S cannot adopt ~S, since it was created by a different document."
+               node new-child))
+  (do ((n node (dom:parent-node n)))
+      ((null n))
+    (when (eq n new-child)
+      (dom-error :HIERARCHY_REQUEST_ERR
+                 "~S cannot adopt ~S, since that would create a cycle"
+                 node new-child)))
+  (unless (null (slot-value new-child 'parent))
+    (dom:remove-child (slot-value new-child 'parent) new-child)))
+
+(defmethod dom:insert-before ((node node) (new-child node) ref-child)
+  (ensure-valid-insertion-request node new-child)
+  (with-slots (children) node
+    (if ref-child
+        (let ((i (position ref-child children)))
+          (unless i
+            (dom-error :NOT_FOUND_ERR "~S is no child of ~S." ref-child node))
+          (make-space children 1)
+          (move children children i (1+ i) (- (length children) i))
+          (incf (fill-pointer children))
+          (setf (elt children i) new-child))
+        (vector-push-extend new-child children (extension children)))
+    (setf (slot-value new-child 'parent) node)
+    new-child))
+
+(defmethod dom:insert-before
+    ((node node) (fragment document-fragment) ref-child)
+  (let ((children (dom:child-nodes fragment)))
+    (cxml::while (plusp (length children))
+      (dom:insert-before node (elt children 0) ref-child)))
+  fragment)
+
+(defmethod dom:replace-child ((node node) (new-child node) (old-child node))
+  (ensure-valid-insertion-request node new-child)
+  (with-slots (children) node
+    (let ((i (position old-child children)))
+      (unless i
+        (dom-error :NOT_FOUND_ERR "~S is no child of ~S." old-child node))
+      (setf (elt children i) new-child)) 
+    (setf (slot-value new-child 'parent) node)
+    (setf (slot-value old-child 'parent) nil)
+    old-child))
+
+(defmethod dom:replace-child
+    ((node node) (new-child document-fragment) (old-child node))
+  (dom:insert-before node new-child old-child)
+  (dom:remove-child node old-child))
+
+(defmethod dom:remove-child ((node node) (old-child node))
+  (assert-writeable node)
+  (with-slots (children) node
+    (let ((i (position old-child children)))
+      (unless i
+        (dom-error :NOT_FOUND_ERR "~A not found in ~A" old-child node))
+      (move children children (1+ i) i (- (length children) i 1))
+      (decf (fill-pointer children)))
+    (setf (slot-value old-child 'parent) nil)
+    old-child))
+
+(defmethod dom:append-child ((node node) (new-child node))
+  (ensure-valid-insertion-request node new-child)
+  (with-slots (children) node
+    (vector-push-extend new-child children (extension children))
+    (setf (slot-value new-child 'parent) node)
+    new-child))
+
+(defmethod dom:has-child-nodes ((node node))
+  (plusp (length (slot-value node 'children))))
+
+(defmethod dom:append-child ((node node) (new-child document-fragment))
+  (assert-writeable node)
+  (let ((children (dom:child-nodes new-child)))
+    (cxml::while (plusp (length children))
+      (dom:append-child node (elt children 0))))
+  new-child)
+
+;; was auf node noch implemetiert werden muss:
+;; - node-type
+;; - can-adopt-p
+;; - ggf attributes 
+;; - node-name
+;; - node-value
+
+;; node-name 
+
+(defmethod dom:node-name ((self document))
+  #"#document")
+
+(defmethod dom:node-name ((self document-fragment))
+  #"#document-fragment")
+
+(defmethod dom:node-name ((self text))
+  #"#text")
+
+(defmethod dom:node-name ((self cdata-section))
+  #"#cdata-section")
+
+(defmethod dom:node-name ((self comment))
+  #"#comment")
+
+(defmethod dom:node-name ((self attribute))
+  (dom:name self))
+
+(defmethod dom:node-name ((self element))
+  (dom:tag-name self))
+
+(defmethod dom:node-name ((self document-type))
+  (dom:name self))
+
+(defmethod dom:node-name ((self notation))
+  (dom:name self))
+
+(defmethod dom:node-name ((self entity))
+  (dom:name self))
+
+(defmethod dom:node-name ((self entity-reference))
+  (dom:name self))
+
+(defmethod dom:node-name ((self processing-instruction))
+  (dom:target self))
+
+;; node-type
+
+(defmethod dom:node-type ((self document)) :document)
+(defmethod dom:node-type ((self document-fragment)) :document-fragment)
+(defmethod dom:node-type ((self text)) :text)
+(defmethod dom:node-type ((self comment)) :comment)
+(defmethod dom:node-type ((self cdata-section)) :cdata-section)
+(defmethod dom:node-type ((self attribute)) :attribute)
+(defmethod dom:node-type ((self element)) :element)
+(defmethod dom:node-type ((self document-type)) :document-type)
+(defmethod dom:node-type ((self notation)) :notation)
+(defmethod dom:node-type ((self entity)) :entity)
+(defmethod dom:node-type ((self entity-reference)) :entity-reference)
+(defmethod dom:node-type ((self processing-instruction)) :processing-instruction)
+
+;; node-value
+
+(defmethod dom:node-value ((self document)) nil)
+(defmethod dom:node-value ((self document-fragment)) nil)
+(defmethod dom:node-value ((self character-data)) (dom:data self))
+(defmethod dom:node-value ((self attribute)) (dom:value self))
+(defmethod dom:node-value ((self element)) nil)
+(defmethod dom:node-value ((self document-type)) nil)
+(defmethod dom:node-value ((self notation)) nil)
+(defmethod dom:node-value ((self entity)) nil)
+(defmethod dom:node-value ((self entity-reference)) nil)
+(defmethod dom:node-value ((self processing-instruction)) (dom:data self))
+
+;; (setf node-value), first the meaningful cases...
+
+(defmethod (setf dom:node-value) (newval (self character-data))
+  (assert-writeable self)
+  (setf (dom:data self) newval))
+
+(defmethod (setf dom:node-value) (newval (self attribute))
+  (assert-writeable self)
+  (setf (dom:value self) newval))
+
+(defmethod (setf dom:node-value) (newval (self processing-instruction))
+  (assert-writeable self)
+  (setf (dom:data self) newval))
+
+;; ... and (setf node-value), part II.  The DOM Level 1 spec fails to explain
+;; this case, but it is covered by the (Level 1) test suite and clarified
+;; in Level 2:
+;;         nodeValue of type DOMString
+;;                 The value of this node, depending on its type; see the
+;;                 table above.  When it is defined to be null, setting
+;;                 it has no effect.
+
+(defmethod (setf dom:node-value) (newval (self element))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self entity-reference))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self entity))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self document))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self document-type))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self document-fragment))
+  (declare (ignore newval)))
+
+(defmethod (setf dom:node-value) (newval (self notation))
+  (declare (ignore newval)))
+
+;; attributes
+
+;; (gibt es nur auf element)
+
+(defmethod dom:attributes ((self node))
+  nil)
+
+;; dann fehlt noch can-adopt und attribute conventions fuer adoption
+
+;;; NodeList
+
+(defun make-node-list (&optional initial-contents)
+  (make-array (length initial-contents)
+              :adjustable t
+              :fill-pointer (length initial-contents)
+              :initial-contents initial-contents))
+
+(defmethod dom:item ((self vector) index)
+  (if (< index (length self))
+      (elt self index)
+      nil))
+
+(defmethod dom:length ((self vector))
+  (length self))
+
+;;; NAMED-NODE-MAP
+
+(defmethod dom:get-named-item ((self named-node-map) name)
+  (setf name (%rod name))
+  (with-slots (items) self
+    (dolist (k items nil)
+      (when (rod= name (dom:node-name k))
+	(return k)))))
+
+(defmethod dom:get-named-item-ns ((self named-node-map) uri lname)
+  (setf uri (%rod uri))
+  (setf lname (%rod lname))
+  (with-slots (items) self
+    (dolist (k items nil)
+      (when (and (rod= uri (dom:namespace-uri k))
+		 (rod= lname (dom:local-name k)))
+	(return k)))))
+
+(defun %set-named-item (map arg test)
+  (assert-writeable map)
+  (unless (eq (dom:node-type arg) (slot-value map 'element-type))
+    (dom-error :HIERARCHY_REQUEST_ERR
+               "~S cannot adopt ~S, since it is not of type ~S."
+               map arg (slot-value map 'element-type)))
+  (unless (eq (dom:owner-document map) (dom:owner-document arg))
+    (dom-error :WRONG_DOCUMENT_ERR
+               "~S cannot adopt ~S, since it was created by a different document."
+               map arg))
+  (let ((old-map (slot-value arg 'map)))
+    (when (and old-map (not (eq old-map map)))
+      (dom-error :INUSE_ATTRIBUTE_ERR "Attribute node already mapped" arg)))
+  (setf (slot-value arg 'map) map)
+  (with-slots (items) map
+    (dolist (k items (progn (setf items (cons arg items)) nil))
+      (when (funcall test k)
+	(setf items (cons arg (delete k items)))
+	(return k)))))
+
+(defmethod dom:set-named-item ((self named-node-map) arg)
+  (let ((name (dom:node-name arg)))
+    (%set-named-item self arg (lambda (k) (rod= name (dom:node-name k))))))
+
+(defmethod dom:set-named-item-ns ((self named-node-map) arg)
+  (let ((uri (dom:namespace-uri arg))
+	(lname (dom:local-name arg)))
+    (%set-named-item self
+		     arg
+		     (lambda (k)
+		       (and (rod= lname (dom:local-name k))
+			    (rod= uri (dom:namespace-uri k)))))))
+
+(defmethod dom:remove-named-item ((self named-node-map) name)
+  (assert-writeable self)
+  (setf name (%rod name))
+  (with-slots (items) self
+    (dolist (k items (dom-error :NOT_FOUND_ERR "~A not found in ~A" name self))
+      (cond ((rod= name (dom:node-name k))
+             (setf items (delete k items))
+             (return k))))))
+
+(defmethod dom:remove-named-item-ns ((self named-node-map) uri lname)
+  (assert-writeable self)
+  (setf uri (%rod uri))
+  (setf lname (%rod lname))
+  (with-slots (items) self
+    (dolist (k items
+	      (dom-error :NOT_FOUND_ERR "~A not found in ~A" lname self))
+      (when (and (rod= lname (dom:local-name k))
+		 (rod= uri (dom:namespace-uri k)))
+	(setf items (delete k items))
+	(return k)))))
+
+(defmethod dom:length ((self named-node-map))
+  (with-slots (items) self
+    (length items)))
+
+(defmethod dom:item ((self named-node-map) index)
+  (with-slots (items) self
+    (do ((nthcdr items (cdr nthcdr))
+         (i index (1- i)))
+        ((zerop i) (car nthcdr)))))
+
+;;; CHARACTER-DATA
+
+(defmethod (setf dom:data) (newval (self character-data))
+  (assert-writeable self)
+  (setf newval (%rod newval))
+  (setf (slot-value self 'value) newval))
+
+(defmethod dom:length ((node character-data))
+  (length (slot-value node 'value)))
+
+(defmethod dom:substring-data ((node character-data) offset count)
+  (with-slots (value) node
+    (unless (<= 0 offset (length value))
+      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
+    (let ((end (min (length value) (+ offset count))))
+      (subseq value offset end))))
+
+(defmethod dom:append-data ((node character-data) arg)
+  (assert-writeable node)
+  (setq arg (%rod arg))
+  (with-slots (value) node
+    (setf value (concatenate 'rod value arg)))
+  (values))
+
+(defmethod dom:delete-data ((node character-data) offset count)
+  (assert-writeable node)
+  (with-slots (value) node
+    (unless (<= 0 offset (length value))
+      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
+    (when (minusp count)
+      (dom-error :INDEX_SIZE_ERR "count is negative"))
+    (setf count (min count (- (length value) offset)))
+    (let ((new (make-array (- (length value) count)
+                           :element-type (array-element-type value))))
+      (replace new value 
+               :start1 0 :end1 offset
+               :start2 0 :end2 offset)
+      (replace new value 
+               :start1 offset :end1 (length new)
+               :start2 (+ offset count) :end2 (length value))
+      (setf value new)))
+  (values))
+
+(defmethod dom:replace-data ((node character-data) offset count arg)
+  ;; Although we could implement this by calling DELETE-DATA, then INSERT-DATA,
+  ;; we implement this function directly to avoid creating temporary garbage.
+  (assert-writeable node)
+  (setf arg (%rod arg))
+  (with-slots (value) node
+    (unless (<= 0 offset (length value))
+      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
+    (when (minusp count)
+      (dom-error :INDEX_SIZE_ERR "count is negative"))
+    (setf count (min count (- (length value) offset)))
+    (if (= count (length arg))
+        (replace value arg
+                 :start1 offset :end1 (+ offset count)
+                 :start2 0 :end2 count)
+        (let ((new (make-array (+ (length value) (length arg) (- count))
+                               :element-type (array-element-type value))))
+          (replace new value :end1 offset)
+          (replace new arg :start1 offset)
+          (replace new value
+                   :start1 (+ offset (length arg))
+                   :start2 (+ offset count))
+          (setf value new))))
+  (values))
+
+(defmethod dom:insert-data ((node character-data) offset arg)
+  (assert-writeable node)
+  (setf arg (%rod arg))
+  (with-slots (value) node
+    (unless (<= 0 offset (length value))
+      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
+    (let ((new (make-array (+ (length value) (length arg))
+                           :element-type (array-element-type value)))
+          (arglen (length arg)))
+      (replace new value :end1 offset)
+      (replace new arg :start1 offset)
+      (replace new value :start1 (+ offset arglen) :start2 offset)
+      (setf value new)))
+  (values))
+
+;;; ATTR
+;;;
+;;; An attribute value can be read and set as a string using DOM:VALUE
+;;; or frobbed by changing the attribute's children!
+;;;
+;;; We store the value in a TEXT node and read this node's DATA slot
+;;; when asked for our VALUE -- until the user changes the child nodes,
+;;; in which case we have to compute VALUE by traversing the children.
+
+(defmethod dom:value ((node attribute))
+  (with-slots (children) node
+    (cond
+      ((zerop (length children))
+        #.(rod-string ""))
+      ((and (eql (length children) 1)
+            (eq (dom:node-type (elt children 0)) :text))
+        ;; we have as single TEXT-NODE child, just return its DATA
+        (dom:data (elt children 0)))
+      (t
+        ;; traverse children to compute value
+        (attribute-to-string node)))))
+
+(defmethod (setf dom:value) (new-value (node attribute))
+  (assert-writeable node)
+  (let ((rod (%rod new-value)))
+    (with-slots (children owner) node
+      ;; remove children, add new TEXT-NODE child
+      ;; (alas, we must not reuse an old TEXT-NODE)
+      (cxml::while (plusp (length children))
+        (dom:remove-child node (dom:last-child node)))
+      (dom:append-child node (dom:create-text-node owner rod))))
+  new-value)
+
+(defun attribute-to-string (attribute)
+  (let ((stream (make-rod-stream)))
+    (flet ((doit ()
+             (dovector (child (dom:child-nodes attribute))
+               (write-attribute-child child stream))))
+      (doit)
+      (initialize-rod-stream stream)
+      (doit))
+    (rod-stream-buf stream)))
+
+(defmethod write-attribute-child ((node node) stream)
+  (put-rod (dom:node-value node) stream))
+
+(defmethod write-attribute-child ((node entity-reference) stream)
+  (dovector (child (dom:child-nodes node))
+    (write-attribute-child child stream)))
+
+;;; ROD-STREAM als Ersatz fuer MAKE-STRING-OUTPUT-STREAM zu verwenden,
+;;; nur dass der Buffer statische Groesse hat.  Solange er NIL ist,
+;;; zaehlt der Stream nur die Runen.  Dann ruft man INITIALIZE-ROD-STREAM
+;;; auf, um den Buffer zu erzeugen und die Position zurueckzusetzen, und
+;;; schreibt alles abermals.  Dann ist der Buffer gefuellt.
+(defstruct rod-stream
+  (buf nil)
+  (position 0))
+
+(defun put-rod (rod rod-stream)
+  (let ((buf (rod-stream-buf rod-stream)))
+    (when buf
+      (move rod buf 0 (rod-stream-position rod-stream) (length rod)))
+    (incf (rod-stream-position rod-stream) (length rod)))
+  rod)
+
+(defun initialize-rod-stream (stream)
+  (setf (rod-stream-buf stream) (make-rod (rod-stream-position stream)))
+  (setf (rod-stream-position stream) 0)
+  stream)
+
+;;; ELEMENT
+
+(defmethod dom:has-attributes ((element element))
+  (plusp (length (dom:items (dom:attributes element)))))
+
+(defmethod dom:has-attribute ((element element) name)
+  (and (dom:get-named-item (dom:attributes element) name) t))
+
+(defmethod dom:has-attribute-ns ((element element) uri lname)
+  (and (dom:get-named-item-ns (dom:attributes element) uri lname) t))
+
+(defmethod dom:get-attribute-node ((element element) name)
+  (dom:get-named-item (dom:attributes element) name))
+
+(defmethod dom:set-attribute-node ((element element) (new-attr attribute))
+  (assert-writeable element)
+  (dom:set-named-item (dom:attributes element) new-attr))
+
+(defmethod dom:get-attribute-node-ns ((element element) uri lname)
+  (dom:get-named-item-ns (dom:attributes element) uri lname))
+
+(defmethod dom:set-attribute-node-ns ((element element) (new-attr attribute))
+  (assert-writeable element)
+  (dom:set-named-item-ns (dom:attributes element) new-attr))
+
+(defmethod dom:get-attribute ((element element) name)
+  (let ((a (dom:get-attribute-node element name)))
+    (if a
+        (dom:value a)
+        #"")))
+
+(defmethod dom:get-attribute-ns ((element element) uri lname)
+  (let ((a (dom:get-attribute-node-ns element uri lname)))
+    (if a
+        (dom:value a)
+        #"")))
+
+(defmethod dom:set-attribute ((element element) name value)
+  (assert-writeable element)
+  (with-slots (owner) element
+    (let ((attr (dom:create-attribute owner name)))
+      (setf (slot-value attr 'owner-element) element)
+      (setf (dom:value attr) value)
+      (dom:set-attribute-node element attr))
+    (values)))
+
+(defmethod dom:set-attribute-ns ((element element) uri lname value)
+  (assert-writeable element)
+  (with-slots (owner) element
+    (let ((attr (dom:create-attribute-ns owner uri lname)))
+      (setf (slot-value attr 'owner-element) element)
+      (setf (dom:value attr) value)
+      (dom:set-attribute-node-ns element attr))
+    (values)))
+
+(defmethod dom:remove-attribute ((element element) name)
+  (assert-writeable element)
+  (dom:remove-attribute-node element (dom:get-attribute-node element name)))
+
+(defmethod dom:remove-attribute-ns ((elt element) uri lname)
+  (assert-writeable elt)
+  (dom:remove-attribute-node elt (dom:get-attribute-node-ns elt uri lname)))
+
+(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
+  (assert-writeable element)
+  (with-slots (items) (dom:attributes element)
+    (unless (find old-attr items)
+      (dom-error :NOT_FOUND_ERR "Attribute not found."))
+    (setf items (remove old-attr items))
+    (maybe-add-default-attribute element old-attr)
+    old-attr))
+
+;; eek, defaulting:
+
+(defun maybe-add-default-attribute (element old-attr)
+  (let* ((qname (dom:name old-attr))
+	 (dtd (dtd (slot-value element 'owner)))
+         (e (when dtd (cxml::find-element
+		       (real-rod (dom:tag-name element))
+		       dtd)))
+         (a (when e (cxml::find-attribute e (real-rod qname)))))
+    (when (and a (listp (cxml::attdef-default a)))
+      (let ((new (add-default-attribute element a)))
+	(setf (slot-value new 'namespace-uri) (dom:namespace-uri old-attr))
+	(setf (slot-value new 'prefix) (dom:prefix old-attr))
+	(setf (slot-value new 'local-name) (dom:local-name old-attr))))))
+
+(defun add-default-attributes (element)
+  (let* ((dtd (dtd (slot-value element 'owner)))
+         (e (when dtd (cxml::find-element
+		       (real-rod (dom:tag-name element))
+		       dtd))))
+    (when e
+      (dolist (a (cxml::elmdef-attributes e))
+        (when (and a
+		   (listp (cxml::attdef-default a))
+		   (not (dom:get-attribute-node
+			 element
+			 (%rod (cxml::attdef-name a)))))
+          (let ((anode (add-default-attribute element a)))
+	    (multiple-value-bind (prefix local-name)
+		(handler-case
+		    (cxml::split-qname (cxml::attdef-name a))
+		  (cxml:well-formedness-violation (c)
+		    (dom-error :NAMESPACE_ERR "~A" c)))
+	      (when prefix (setf prefix (%rod prefix)))
+	      (setf local-name (%rod local-name))
+	      ;; das ist fuer importnode07.
+	      ;; so richtig ueberzeugend finde ich das ja nicht.
+	      (setf (slot-value anode 'prefix) prefix)
+	      (setf (slot-value anode 'local-name) local-name))))))))
+
+(defun add-default-attribute (element adef)
+  (let* ((value (second (cxml::attdef-default adef)))
+         (owner (slot-value element 'owner))
+         (anode (dom:create-attribute owner (cxml::attdef-name adef)))
+         (text (dom:create-text-node owner value)))
+    (setf (slot-value anode 'specified-p) nil)
+    (setf (slot-value anode 'owner-element) element)
+    (dom:append-child anode text)
+    (push anode (slot-value (dom:attributes element) 'items))
+    anode))
+
+(defmethod dom:remove-named-item ((self attribute-node-map) name)
+  name
+  (let ((k (call-next-method)))
+    (maybe-add-default-attribute (slot-value self 'element) k)
+    k))
+
+(defmethod dom:remove-named-item-ns ((self attribute-node-map) uri lname)
+  uri lname
+  (let ((k (call-next-method)))
+    (maybe-add-default-attribute (slot-value self 'element) k)
+    k))
+
+(defmethod dom:get-elements-by-tag-name ((element element) name)
+  (assert-writeable element)
+  (get-elements-by-tag-name-internal element name))
+
+(defmethod dom:get-elements-by-tag-name-ns ((element element) uri lname)
+  (assert-writeable element)
+  (get-elements-by-tag-name-internal-ns element uri lname))
+
+(defmethod dom:set-named-item :after ((self attribute-node-map) arg)
+  (setf (slot-value arg 'owner-element)
+	(slot-value self 'element)))
+
+(defmethod dom:set-named-item-ns :after ((self attribute-node-map) arg)
+  (setf (slot-value arg 'owner-element)
+	(slot-value self 'element)))
+
+(defmethod dom:normalize ((node node))
+  (assert-writeable node)
+  (labels ((walk (n)
+             (when (eq (dom:node-type n) :element)
+               (map nil #'walk (dom:items (dom:attributes n))))
+             (let ((children (dom:child-nodes n))
+                   (i 0)
+                   (previous nil))
+               ;; careful here, we're modifying the array we are iterating over
+               (cxml::while (< i (length children))
+                 (let ((child (elt children i)))
+                   (cond
+                     ((not (eq (dom:node-type child) :text))
+                       (setf previous nil)
+                       (incf i))
+                     ((and previous (eq (dom:node-type previous) :text))
+                       (setf (slot-value previous 'value)
+                             (concatenate 'rod
+                               (dom:data previous)
+                               (dom:data child)))
+                       (dom:remove-child n child)
+                       ;; not (incf i)
+                       )
+		     ((zerop (length (dom:data child)))
+                       (dom:remove-child n child)
+                       ;; not (incf i)
+		       )
+                     (t
+                       (setf previous child)
+                       (incf i)))))) 
+             (map nil #'walk (dom:child-nodes n))))
+    (walk node))
+  (values))
+
+;;; TEXT
+
+(defmethod dom:split-text ((text text) offset)
+  (assert-writeable text)
+  (with-slots (owner parent value) text
+    (unless (<= 0 offset (length value))
+      (dom-error :INDEX_SIZE_ERR "offset is invalid"))
+    (prog1
+        (dom:insert-before parent
+                           (dom:create-text-node owner (subseq value offset))
+                           (dom:next-sibling text))
+      (setf value (subseq value 0 offset)))))
+
+;;; COMMENT -- nix
+;;; CDATA-SECTION -- nix
+
+;;; DOCUMENT-TYPE
+
+(defmethod dom:internal-subset ((node document-type))
+  ;; FIXME: encoding ist falsch, anderen sink nehmen!
+  (if (and (slot-boundp node 'dom::%internal-subset)
+	   ;; die damen und herren von der test suite sind wohl der meinung,
+	   ;; dass ein leeres internal subset nicht vorhanden ist und
+	   ;; wir daher nil liefern sollen.  bittesehr!
+	   (dom::%internal-subset node))
+      (let ((sink
+	     #+rune-is-character (cxml:make-string-sink)
+	     #-rune-is-character (cxml:make-string-sink/utf8)))
+	(dolist (def (dom::%internal-subset node))
+	  (apply (car def) sink (cdr def)))
+	(sax:end-document sink))
+      nil))
+
+;;; NOTATION -- nix
+;;; ENTITY -- nix
+
+;;; ENTITY-REFERENCE
+
+(defmethod initialize-instance :after ((instance entity-reference) &key)
+  (let* ((owner (dom:owner-document instance))
+         (handler (make-dom-builder))
+         (resolver (slot-value owner 'entity-resolver)))
+    (when resolver
+      (setf (document handler) owner)
+      (push instance (element-stack handler))
+      #+cxml-system::utf8dom-file
+      (setf handler (cxml:make-recoder handler #'cxml:rod-to-utf8-string))
+      (funcall resolver (real-rod (dom:name instance)) handler)
+      (flush-characters handler)))
+  (labels ((walk (n)
+             (setf (slot-value n 'read-only-p) t)
+             (when (dom:element-p n)
+	       (setf (slot-value (dom:attributes n) 'read-only-p) t)
+               (map nil #'walk (dom:items (dom:attributes n))))
+             (map nil #'walk (dom:child-nodes n))))
+    (walk instance)))
+
+;;; PROCESSING-INSTRUCTION
+
+(defmethod (setf dom:data) (newval (self processing-instruction))
+  (assert-writeable self)
+  (setf newval (%rod newval))
+  (setf (slot-value self 'data) newval))
+
+;; das koennte man auch mit einer GF machen
+(defun can-adopt-p (parent child)
+  (member (dom:node-type child)
+          (let ((default '(:element :processing-instruction :comment :text
+                           :cdata-section :entity-reference)))
+            (etypecase parent
+              (document
+                '(:element :processing-instruction :comment :document-type))
+              (document-fragment default)
+              (document-type nil)
+              (entity-reference default)
+              (element default)
+              (attribute '(:text :entity-reference))
+              (processing-instruction nil)
+              (comment nil)
+              (text nil)
+              (cdata-section nil)
+              (entity default)
+              (notation nil)))))
+
+
+;;; predicates
+
+(defmethod dom:node-p ((object node)) t)
+(defmethod dom:node-p ((object t)) nil)
+
+(defmethod dom:document-p ((object document)) t)
+(defmethod dom:document-p ((object t)) nil)
+
+(defmethod dom:document-fragment-p ((object document-fragment)) t)
+(defmethod dom:document-fragment-p ((object t)) nil)
+
+(defmethod dom:character-data-p ((object character-data)) t)
+(defmethod dom:character-data-p ((object t)) nil)
+
+(defmethod dom:attribute-p ((object attribute)) t)
+(defmethod dom:attribute-p ((object t)) nil)
+
+(defmethod dom:element-p ((object element)) t)
+(defmethod dom:element-p ((object t)) nil)
+
+(defmethod dom:text-node-p ((object text)) t)
+(defmethod dom:text-node-p ((object t)) nil)
+
+(defmethod dom:comment-p ((object comment)) t)
+(defmethod dom:comment-p ((object t)) nil)
+
+(defmethod dom:cdata-section-p ((object cdata-section)) t)
+(defmethod dom:cdata-section-p ((object t)) nil)
+
+(defmethod dom:document-type-p ((object document-type)) t)
+(defmethod dom:document-type-p ((object t)) nil)
+
+(defmethod dom:notation-p ((object notation)) t)
+(defmethod dom:notation-p ((object t)) nil)
+
+(defmethod dom:entity-p ((object entity)) t)
+(defmethod dom:entity-p ((object t)) nil)
+
+(defmethod dom:entity-reference-p ((object entity-reference)) t)
+(defmethod dom:entity-reference-p ((object t)) nil)
+
+(defmethod dom:processing-instruction-p ((object processing-instruction)) t)
+(defmethod dom:processing-instruction-p ((object t)) nil)
+
+(defmethod dom:named-node-map-p ((object named-node-map)) t)
+(defmethod dom:named-node-map-p ((object t)) nil)
+
+
+;;; IMPORT-NODE
+
+(defvar *clone-not-import* nil)         ;not beautiful, I know.  See below.
+
+(defmethod import-node-internal (class document node deep &rest initargs)
+  (let ((result (apply #'make-instance class :owner document initargs)))
+    (when deep
+      (dovector (child (dom:child-nodes node))
+        (dom:append-child result (dom:import-node document child t))))
+    result))
+
+(defmethod dom:import-node ((document document) (node t) deep)
+  (declare (ignore deep))
+  (dom-error :NOT_SUPPORTED_ERR "not implemented"))
+
+(defmethod dom:import-node ((document document) (node attribute) deep)
+  (declare (ignore deep))
+  (import-node-internal 'attribute
+			document node
+			t
+                        :specified-p (dom:specified node)
+			:name (dom:name node)
+			:namespace-uri (dom:namespace-uri node)
+			:local-name (dom:local-name node)
+			:prefix (dom:prefix node)
+			:owner-element nil))
+
+(defmethod dom:import-node ((document document) (node document-fragment) deep)
+  (import-node-internal 'document-fragment document node deep))
+
+(defmethod dom:import-node ((document document) (node element) deep)
+  (let* ((attributes (make-instance 'attribute-node-map
+                       :element-type :attribute
+                       :owner document))
+         (result (import-node-internal 'element document node deep
+                                       :attributes attributes
+				       :namespace-uri (dom:namespace-uri node)
+				       :local-name (dom:local-name node)
+				       :prefix (dom:prefix node)
+                                       :tag-name (dom:tag-name node))))
+    (setf (slot-value attributes 'element) result)
+    (dolist (attribute (dom:items (dom:attributes node)))
+      (when (or (dom:specified attribute) *clone-not-import*)
+        (let ((attr (dom:import-node document attribute t)))
+          (if (dom:namespace-uri attribute)
+              (dom:set-attribute-node-ns result attr)
+              (dom:set-attribute-node result attr)))))
+    (add-default-attributes result)
+    result))
+
+(defmethod dom:import-node ((document document) (node entity) deep)
+  (import-node-internal 'entity document node deep
+			:name (dom:name node)
+                        :public-id (dom:public-id node)
+                        :system-id (dom:system-id node)
+                        :notation-name (dom:notation-name node)))
+
+(defmethod dom:import-node ((document document) (node entity-reference) deep)
+  (declare (ignore deep))
+  (import-node-internal 'entity-reference document node nil
+                        :name (dom:name node)))
+
+(defmethod dom:import-node ((document document) (node notation) deep)
+  (import-node-internal 'notation document node deep
+                        :name (dom:name node)
+                        :public-id (dom:public-id node)
+                        :system-id (dom:system-id node)))
+
+(defmethod dom:import-node
+    ((document document) (node processing-instruction) deep)
+  (import-node-internal 'processing-instruction document node deep
+                        :target (dom:target node)
+                        :data (dom:data node)))
+
+;; TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE
+(defmethod dom:import-node
+    ((document document) (node character-data) deep)
+  (import-node-internal (class-of node) document node deep
+                        :data (copy-seq (dom:data node))))
+
+;;; CLONE-NODE
+;;;
+;;; As far as I can tell, cloneNode is the same as importNode, except
+;;; for one difference involving element attributes: importNode imports
+;;; only specified attributes, cloneNode copies even default values.
+;;;
+;;; Since I don't want to reimplement all of importNode here, we run
+;;; importNode with a special flag...
+
+(defmethod dom:clone-node ((node node) deep)
+  (let ((*clone-not-import* t))
+    (dom:import-node (dom:owner-document node) node deep)))
+
+;; extension:
+(defmethod dom:clone-node ((node document) deep)
+  (let* ((document (make-instance 'document))
+	 (original-doctype (dom:doctype node))
+	 (doctype 
+	  (when original-doctype
+	    (make-instance 'document-type
+	      :owner document
+	      :name (dom:name original-doctype)
+	      :public-id (dom:public-id original-doctype)
+	      :system-id (dom:system-id original-doctype)
+	      :notations (make-instance 'named-node-map
+			   :element-type :notation
+			   :owner document
+			   :items (dom:items (dom:notations original-doctype)))
+	      :entities (make-instance 'named-node-map
+			  :element-type :entity
+			  :owner document
+			  :items (dom:items
+				  (dom:entities original-doctype)))))))
+    (setf (slot-value document 'owner) nil)
+    (setf (slot-value document 'doc-type) doctype)
+    (setf (slot-value document 'dtd) (dtd node))
+    (setf (slot-value document 'entity-resolver)
+	  (slot-value node 'entity-resolver))
+    (setf (slot-value (dom:entities doctype) 'read-only-p) t)
+    (setf (slot-value (dom:notations doctype) 'read-only-p) t)
+    (when (and doctype (slot-boundp doctype 'dom::%internal-subset))
+      (setf (dom::%internal-subset doctype)
+	    (dom::%internal-subset original-doctype)))
+    (when (and (dom:document-element node) deep)
+      (let* ((*clone-not-import* t)
+	     (clone (dom:import-node document (dom:document-element node) t)))
+	(dom:append-child document clone)))
+    document))
+
+
+;;; Erweiterung
+
+(defun create-document (&optional document-element)
+  ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
+  ;; Dummydokument.
+  (let* ((handler (make-dom-builder))
+         (cxml::*ctx* (cxml::make-context :handler handler))
+         (result
+          (progn
+            (sax:start-document handler)
+            (sax:end-document handler))))
+    (when document-element
+      (dom:append-child result (dom:import-node result document-element t)))
+    result))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-sax.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/dom-sax.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,95 @@
+;;;; dom-sax.lisp -- DOM walker
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: David Lichteblau <david at lichteblau.com>
+;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
+
+(in-package :cxml)
+
+(defun dom:map-document
+    (handler document
+     &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
+	  include-doctype
+          include-default-values
+	  (recode (and #+rune-is-integer (typep document 'utf8-dom::node))))
+  (declare (ignorable recode))
+  #+rune-is-integer
+  (when recode
+    (setf handler (make-recoder handler #'utf8-string-to-rod)))
+  (sax:start-document handler)
+  (when include-doctype
+    (let ((doctype (dom:doctype document)))
+      (when doctype
+	(sax:start-dtd handler
+		       (dom:name doctype)
+		       (dom:public-id doctype)
+		       (dom:system-id doctype))
+	(ecase include-doctype
+	  (:full-internal-subset
+	    (when (slot-boundp doctype 'dom::%internal-subset)
+	      (sax:start-internal-subset handler)
+	      (dolist (def (dom::%internal-subset doctype))
+		(apply (car def) handler (cdr def)))
+	      (sax:end-internal-subset handler)))
+	  (:canonical-notations
+	    ;; need notations for canonical mode 2
+	    (let* ((ns (dom:notations doctype))
+		   (a (make-array (dom:length ns))))
+	      (when (plusp (dom:length ns))
+		(sax:start-internal-subset handler)
+		;; get them
+		(dotimes (k (dom:length ns))
+		  (setf (elt a k) (dom:item ns k)))
+		;; sort them 
+		(setf a (sort a #'rod< :key #'dom:name))
+		(loop for n across a do
+		      (sax:notation-declaration handler
+						(dom:name n)
+						(dom:public-id n)
+						(dom:system-id n)))
+		(sax:end-internal-subset handler)))))
+	(sax:end-dtd handler))))
+  (labels ((walk (node)
+             (dom:do-node-list (child (dom:child-nodes node))
+               (ecase (dom:node-type child)
+                 (:element
+                   (let ((attlist
+                          (compute-attributes child
+                                              include-xmlns-attributes
+                                              include-default-values))
+			 (uri (dom:namespace-uri child))
+                         (lname (dom:local-name child))
+                         (qname (dom:tag-name child)))
+                     (sax:start-element handler uri lname qname attlist)
+                     (walk child)
+                     (sax:end-element handler uri lname qname)))
+                 (:cdata-section
+                   (sax:start-cdata handler)
+                   (sax:characters handler (dom:data child))
+                   (sax:end-cdata handler))
+                 (:text
+                   (sax:characters handler (dom:data child)))
+                 (:comment
+                   (sax:comment handler (dom:data child)))
+                 (:processing-instruction
+                   (sax:processing-instruction handler
+                                               (dom:target child)
+                                               (dom:data child)))))))
+    (walk document))
+  (sax:end-document handler))
+
+(defun compute-attributes (element xmlnsp defaultp)
+  (let ((results '()))
+    (dom:do-node-list (a (dom:attributes element))
+      (when (and (or defaultp (dom:specified a))
+                 (or xmlnsp (not (cxml::xmlns-attr-p (rod (dom:name a))))))
+        (push
+         (sax:make-attribute :qname (dom:name a)
+                             :value (dom:value a)
+			     :local-name (dom:local-name a)
+			     :namespace-uri (dom:namespace-uri a)
+                             :specified-p (dom:specified a))
+         results)))
+    (reverse results)))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/dom/package.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,161 @@
+;;;; package.lisp -- Paketdefinition
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+
+(in-package :cl-user)
+
+(defpackage :dom
+  (:use)
+  (:export
+   ;; DOM 2 functions
+   #:owner-element
+   #:import-node
+   #:create-element-ns
+   #:create-attribute-ns
+   #:get-elements-by-tag-name-ns
+   #:get-element-by-id
+   #:get-named-item-ns
+   #:set-named-item-ns
+   #:remove-named-item-ns
+   #:is-supported
+   #:has-attributes
+   #:namespace-uri
+   #:prefix
+   #:local-name
+   #:internal-subset
+   #:create-document-type
+   #:create-document
+   #:get-attribute-ns
+   #:set-attribute-ns
+   #:remove-attribute-ns
+   #:get-attribute-node-ns
+   #:set-attribute-node-ns
+   #:has-attribute
+   #:has-attribute-ns
+
+   ;; DOM 1 functions
+   #:has-feature
+   #:doctype
+   #:implementation
+   #:document-element
+   #:create-element
+   #:create-document-fragment
+   #:create-text-node
+   #:create-comment
+   #:create-cdata-section
+   #:create-processing-instruction
+   #:create-attribute
+   #:create-entity-reference
+   #:get-elements-by-tag-name
+   #:node-name
+   #:node-value
+   #:node-type
+   #:parent-node 
+   #:child-nodes
+   #:first-child
+   #:last-child
+   #:previous-sibling
+   #:next-sibling
+   #:attributes
+   #:owner-document
+   #:insert-before
+   #:replace-child
+   #:remove-child
+   #:append-child
+   #:has-child-nodes
+   #:clone-node
+   #:item
+   #:length
+   #:get-named-item
+   #:set-named-item
+   #:remove-named-item
+   #:data
+   #:substring-data
+   #:append-data
+   #:insert-data
+   #:delete-data
+   #:replace-data
+   #:name
+   #:specified
+   #:value
+   #:tag-name
+   #:get-attribute
+   #:set-attribute
+   #:remove-attribute
+   #:get-attribute-node
+   #:set-attribute-node
+   #:remove-attribute-node
+   #:normalize
+   #:split-text
+   #:entities
+   #:notations
+   #:public-id
+   #:system-id
+   #:notation-name
+   #:target
+   #:code
+
+   ;; IDL interfaces, exported "inofficially"
+   #:node
+   #:document
+   #:document-fragment
+   #:character-data
+   #:attr
+   #:element
+   #:text
+   #:comment
+   #:cdata-section
+   #:document-type
+   #:notation
+   #:entity
+   #:entity-reference
+   #:processing-instruction
+   #:named-node-map
+   ;; no classes:
+;;;   #:dom-implementation
+;;;   #:node-list
+
+   ;;
+   #:items
+
+   ;;
+   #:node-p
+   #:document-p
+   #:document-fragment-p
+   #:character-data-p
+   #:attribute-p
+   #:element-p
+   #:text-node-p
+   #:comment-p
+   #:cdata-section-p
+   #:document-type-p
+   #:notation-p
+   #:entity-p
+   #:entity-reference-p
+   #:processing-instruction-p
+   #:named-node-map-p
+
+   #:map-node-list
+   #:do-node-list
+   #:map-node-map
+   #:do-node-map
+   #:create-document
+   #:map-document))
+
+(defclass dom:node () ())
+(defclass dom:document (dom:node) ())
+(defclass dom:document-fragment (dom:node) ())
+(defclass dom:character-data (dom:node) ())
+(defclass dom:attr (dom:node) ())
+(defclass dom:element (dom:node) ())
+(defclass dom:text (dom:character-data) ())
+(defclass dom:comment (dom:character-data) ())
+(defclass dom:cdata-section (dom:text) ())
+(defclass dom:document-type (dom:node) ())
+(defclass dom:notation (dom:node) ())
+(defclass dom:entity (dom:node) ())
+(defclass dom:entity-reference (dom:node) ())
+(defclass dom:processing-instruction (dom:node) ())
+
+(defclass dom:named-node-map () ())

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks-impl.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks-impl.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,528 @@
+;;; -*- Mode: Lisp; readtable: runes; -*-
+;;;  (c) copyright 2007 David Lichteblau
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :cxml)
+
+(defclass cxml-source (klacks:source)
+    (;; args to make-source
+     (context :initarg :context)
+     (validate :initarg :validate)
+     (root :initarg :root)
+     (dtd :initarg :dtd)
+     (error-culprit :initarg :error-culprit)
+     ;; current state
+     (continuation)
+     (current-key :initform nil)
+     (current-values)
+     (current-attributes)
+     (cdata-section-p :reader klacks:current-cdata-section-p)
+     ;; extra WITH-SOURCE magic
+     (data-behaviour :initform :DTD)
+     (namespace-stack :initform (list *initial-namespace-bindings*))
+     (current-namespace-declarations)
+     (temporary-streams :initform nil)
+     (scratch-pad :initarg :scratch-pad)
+     (scratch-pad-2 :initarg :scratch-pad-2)
+     (scratch-pad-3 :initarg :scratch-pad-3)
+     (scratch-pad-4 :initarg :scratch-pad-4)))
+
+(defmethod klacks:close-source ((source cxml-source))
+  (dolist (xstream (slot-value source 'temporary-streams))
+    ;; fixme: error handling?
+    (close-xstream xstream)))
+
+(defmacro with-source ((source &rest slots) &body body)
+  (let ((s (gensym)))
+    `(let* ((,s ,source)
+	    (*ctx* (slot-value ,s 'context))
+	    (*validate* (slot-value ,s 'validate))
+	    (*data-behaviour* (slot-value source 'data-behaviour))
+	    (*namespace-bindings* (car (slot-value source 'namespace-stack)))
+	    (*scratch-pad* (slot-value source 'scratch-pad))
+	    (*scratch-pad-2* (slot-value source 'scratch-pad-2))
+	    (*scratch-pad-3* (slot-value source 'scratch-pad-3))
+	    (*scratch-pad-4* (slot-value source 'scratch-pad-4)))
+       (handler-case
+	   (with-slots (, at slots) ,s
+	     , at body)
+	 (runes-encoding:encoding-error (c)
+	   (wf-error (slot-value ,s 'error-culprit) "~A" c))))))
+
+(defun fill-source (source)
+  (with-slots (current-key current-values continuation) source
+    (unless current-key
+      (setf current-key :bogus)
+      (setf continuation (funcall continuation))
+      (assert (not (eq current-key :bogus))))))
+
+(defmethod klacks:peek ((source cxml-source))
+  (with-source (source current-key current-values)
+    (fill-source source)
+    (apply #'values current-key current-values)))
+
+(defmethod klacks:peek-value ((source cxml-source))
+  (with-source (source current-key current-values)
+    (fill-source source)
+    (apply #'values current-values)))
+
+(defmethod klacks:peek-next ((source cxml-source))
+  (with-source (source current-key current-values)
+    (setf current-key nil)
+    (fill-source source)
+    (apply #'values current-key current-values)))
+
+(defmethod klacks:consume ((source cxml-source))
+  (with-source (source current-key current-values)
+    (fill-source source)
+    (multiple-value-prog1
+	(apply #'values current-key current-values)
+      (setf current-key nil))))
+
+(defmethod klacks:map-attributes (fn (source cxml-source))
+  (dolist (a (slot-value source 'current-attributes))
+    (funcall fn
+	     (sax:attribute-namespace-uri a)
+	     (sax:attribute-local-name a)
+	     (sax:attribute-qname a)
+	     (sax:attribute-value a)
+	     (sax:attribute-specified-p a))))
+
+(defmethod klacks:get-attribute
+    ((source cxml-source) lname &optional uri)
+  (dolist (a (slot-value source 'current-attributes))
+    (when (and (equal (sax:attribute-local-name a) lname)
+	       (equal (sax:attribute-namespace-uri a) uri))
+      (return (sax:attribute-value a)))))
+
+(defmethod klacks:list-attributes ((source cxml-source))
+  (slot-value source 'current-attributes))
+
+(defun make-source
+    (input &rest args
+     &key validate dtd root entity-resolver disallow-internal-subset
+	  (buffering t) pathname)
+  (declare (ignore validate dtd root entity-resolver disallow-internal-subset))
+  (etypecase input
+    (xstream
+      (when (and (not buffering) (< 1 (runes::xstream-speed input)))
+	(warn "make-source called with !buffering, but xstream is buffering"))
+      (let ((*ctx* nil))
+	(let ((zstream (make-zstream :input-stack (list input))))
+	  (peek-rune input)
+	  (with-scratch-pads ()
+	    (apply #'%make-source
+		   zstream
+		   (loop
+		       for (name value) on args by #'cddr
+		       unless (member name '(:pathname :buffering))
+		       append (list name value)))))))
+    (stream
+      (let ((xstream (make-xstream input :speed (if buffering 8192 1))))
+	(setf (xstream-name xstream)
+	      (make-stream-name
+	       :entity-name "main document"
+	       :entity-kind :main
+	       :uri (safe-stream-sysid input)))
+	(apply #'make-source xstream args)))
+    (pathname
+      (let* ((xstream
+	      (make-xstream (open input :element-type '(unsigned-byte 8))
+			    :speed (if buffering 8192 1))))
+	(setf (xstream-name xstream)
+	      (make-stream-name
+	       :entity-name "main document"
+	       :entity-kind :main
+	       :uri (pathname-to-uri (merge-pathnames input))))
+	(let ((source (apply #'make-source
+			     xstream
+			     :pathname input
+			     args)))
+	  (push xstream (slot-value source 'temporary-streams))
+	  source)))
+    (rod
+      (let ((xstream (string->xstream input)))
+	(setf (xstream-name xstream)
+	      (make-stream-name
+	       :entity-name "main document"
+	       :entity-kind :main
+	       :uri nil))
+	(apply #'make-source xstream args)))
+    (array
+     (make-source (cxml::make-octet-input-stream input)))))
+
+(defun %make-source
+    (input &key validate dtd root entity-resolver disallow-internal-subset
+		error-culprit)
+  ;; check types of user-supplied arguments for better error messages:
+  (check-type validate boolean)
+  (check-type dtd (or null extid))
+  (check-type root (or null rod))
+  (check-type entity-resolver (or null function symbol))
+  (check-type disallow-internal-subset boolean)
+  (let* ((xstream (car (zstream-input-stack input)))
+	 (name (xstream-name xstream))
+	 (base (when name (stream-name-uri name)))
+	 (context
+	  (make-context :main-zstream input
+			:entity-resolver entity-resolver
+			:base-stack (list (or base ""))
+			:disallow-internal-subset disallow-internal-subset))
+	 (source
+	  (make-instance 'cxml-source
+	    :context context
+	    :validate validate
+	    :dtd dtd
+	    :root root
+	    :error-culprit error-culprit
+	    :scratch-pad *scratch-pad*
+	    :scratch-pad-2 *scratch-pad-2*
+	    :scratch-pad-3 *scratch-pad-3*
+	    :scratch-pad-4 *scratch-pad-4*)))
+    (setf (handler context) (make-instance 'klacks-dtd-handler :source source))
+    (setf (slot-value source 'continuation)
+	  (lambda () (klacks/xmldecl source input)))
+    source))
+
+(defun klacks/xmldecl (source input)
+  (with-source (source current-key current-values)
+    (let ((hd (p/xmldecl input)))
+      (setf current-key :start-document)
+      (setf current-values
+	    (when hd
+	      (list (xml-header-version hd)
+		    (xml-header-encoding hd)
+		    (xml-header-standalone-p hd))))
+      (lambda ()
+	(klacks/misc*-2 source input
+			(lambda ()
+			  (klacks/doctype source input)))))))
+
+(defun klacks/misc*-2 (source input successor)
+  (with-source (source current-key current-values)
+    (multiple-value-bind (cat sem) (peek-token input)
+      (case cat
+	(:COMMENT
+	  (setf current-key :comment)
+	  (setf current-values (list sem))
+	  (consume-token input)
+	  (lambda () (klacks/misc*-2 source input successor)))
+	(:PI
+	  (setf current-key :processing-instruction)
+	  (setf current-values (list (car sem) (cdr sem)))
+	  (consume-token input)
+	  (lambda () (klacks/misc*-2 source input successor)))
+	(:S
+	  (consume-token input)
+	  (klacks/misc*-2 source input successor))
+	(t
+	  (funcall successor))))))
+
+(defun klacks/doctype (source input)
+  (with-source (source current-key current-values validate dtd)
+    (let ((cont (lambda () (klacks/finish-doctype source input)))
+	  l)
+      (prog1
+	  (cond
+	    ((eq (peek-token input) :<!DOCTYPE)
+	      (setf l (cdr (p/doctype-decl input dtd)))
+	      (lambda () (klacks/misc*-2 source input cont)))
+	    (dtd
+	      (setf l (cdr (synthesize-doctype dtd input)))
+	      cont)
+	    ((and validate (not dtd))
+	      (validity-error "invalid document: no doctype"))
+	    (t
+	      (return-from klacks/doctype
+		(funcall cont))))
+	(destructuring-bind (&optional name extid) l
+	  (setf current-key :dtd)
+	  (setf current-values
+		(list name
+		      (and extid (extid-public extid))
+		      (and extid (extid-system extid)))))))))
+
+(defun klacks/finish-doctype (source input)
+  (with-source (source current-key current-values root data-behaviour)
+    (ensure-dtd)
+    (when root
+      (setf (model-stack *ctx*) (list (make-root-model root))))
+    (setf data-behaviour :DOC)
+    (setf *data-behaviour* :DOC)
+    (fix-seen-< input)
+    (let* ((final
+	    (lambda ()
+	      (klacks/eof source input)))
+	   (next
+	    (lambda ()
+	      (setf data-behaviour :DTD)
+	      (setf *data-behaviour* :DTD)
+	      (klacks/misc*-2 source input final))))
+      (klacks/element source input next))))
+
+(defun klacks/eof (source input)
+  (with-source (source current-key current-values)
+    (p/eof input)
+    (klacks:close-source source)
+    (setf current-key :end-document)
+    (setf current-values nil)
+    (lambda () (klacks/nil source))))
+
+(defun klacks/nil (source)
+  (with-source (source current-key current-values)
+    (setf current-key nil)
+    (setf current-values nil)
+    (labels ((klacks/done ()
+	       (setf current-key nil)
+	       (setf current-values nil)
+	       #'klacks/done))
+      #'klacks/done)))
+
+(defun klacks/element (source input cont)
+  (with-source (source current-key current-values current-attributes
+		       current-namespace-declarations)
+    (multiple-value-bind (cat n-b new-b uri lname qname attrs) (p/sztag input)
+      (setf current-key :start-element)
+      (setf current-values (list uri lname qname))
+      (setf current-attributes attrs)
+      (setf current-namespace-declarations new-b)
+      (if (eq cat :stag)
+	  (lambda ()
+	    (klacks/element-2 source input n-b cont))
+	  (lambda ()
+	    (klacks/ztag source cont))))))
+
+(defun klacks/ztag (source cont)
+  (with-source (source current-key current-values current-attributes)
+    (setf current-key :end-element)
+    (setf current-attributes nil)
+    (validate-end-element *ctx* (third current-values))
+    cont))
+
+(defun klacks/element-2 (source input n-b cont)
+  (with-source (source
+		current-key current-values current-attributes namespace-stack
+		current-namespace-declarations)
+    (let ((values* current-values)
+	  (new-b current-namespace-declarations))
+      (setf current-attributes nil)
+      (push n-b namespace-stack)
+      (let ((finish
+	     (lambda ()
+	       (setf current-namespace-declarations new-b)
+	       (klacks/element-3 source input values* cont))))
+	(klacks/content source input finish)))))
+
+(defun klacks/element-3 (source input tag-values cont)
+  (with-source (source current-key current-values current-attributes)
+    (setf current-key :end-element)
+    (setf current-values tag-values)
+    (let ((qname (third tag-values)))
+      (p/etag input qname)
+      (validate-end-element *ctx* qname))
+    cont))
+
+(defun klacks/content (source input cont)
+  (with-source (source current-key current-values cdata-section-p)
+    (let ((recurse (lambda () (klacks/content source input cont))))
+      (multiple-value-bind (cat sem) (peek-token input)
+	(case cat
+	  ((:stag :ztag)
+	    (klacks/element source input recurse))
+	  ((:CDATA)
+	    (process-characters input sem)
+	    (setf current-key :characters)
+	    (setf current-values (list sem))
+	    (setf cdata-section-p nil)
+	    recurse)
+	  ((:ENTITY-REF)
+	    (let ((name sem))
+	      (consume-token input)
+	      (klacks/entity-reference source input name recurse)))
+	  ((:<!\[)
+	    (setf current-key :characters)
+	    (setf current-values (list (process-cdata-section input)))
+	    (setf cdata-section-p t)
+	    recurse)
+	  ((:PI)
+	    (setf current-key :processing-instruction)
+	    (setf current-values (list (car sem) (cdr sem)))
+	    (consume-token input)
+	    recurse)
+	  ((:COMMENT)
+	    (setf current-key :comment)
+	    (setf current-values (list sem))
+	    (consume-token input)
+	    recurse)
+	  (otherwise
+	    (funcall cont)))))))
+
+(defun klacks/entity-reference (source zstream name cont)
+  (assert (not (zstream-token-category zstream)))
+  (with-source (source temporary-streams context)
+    (let ((new-xstream (entity->xstream zstream name :general nil)))
+      (push new-xstream temporary-streams)
+      (push :stop (zstream-input-stack zstream))
+      (zstream-push new-xstream zstream)
+      (push (stream-name-uri (xstream-name new-xstream)) (base-stack context))
+      (let ((next
+	     (lambda ()
+	       (klacks/entity-reference-2 source zstream new-xstream cont))))
+	(etypecase (checked-get-entdef name :general)
+	  (internal-entdef
+	    (klacks/content source zstream next))
+	  (external-entdef
+	    (klacks/ext-parsed-ent source zstream next)))))))
+
+(defun klacks/entity-reference-2 (source zstream new-xstream cont)
+  (with-source (source temporary-streams context)
+    (unless (eq (peek-token zstream) :eof)
+      (wf-error zstream "Trailing garbage. - ~S" (peek-token zstream)))
+    (assert (eq (peek-token zstream) :eof))
+    (assert (eq (pop (zstream-input-stack zstream)) new-xstream))
+    (assert (eq (pop (zstream-input-stack zstream)) :stop))
+    (pop (base-stack context))
+    (setf (zstream-token-category zstream) nil)
+    (setf temporary-streams (remove new-xstream temporary-streams))
+    (close-xstream new-xstream)
+    (funcall cont)))
+
+(defun klacks/ext-parsed-ent (source input cont)
+  (with-source (source)
+    (when (eq (peek-token input) :xml-decl)
+      (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input))))))
+	(setup-encoding input hd))
+      (consume-token input))
+    (set-full-speed input)
+    (klacks/content source input cont)))
+
+
+;;;; terrible kludges
+
+(defclass klacks-dtd-handler (sax:default-handler)
+    ((handler-source :initarg :source :reader handler-source)
+     (internal-subset-p :initform nil :accessor handler-internal-subset-p)))
+
+(defmethod sax:start-internal-subset ((handler klacks-dtd-handler))
+  (setf (slot-value (handler-source handler) 'internal-declarations) '())
+  (setf (handler-internal-subset-p handler) t))
+
+(defmethod sax:end-internal-subset ((handler klacks-dtd-handler))
+  (setf (handler-internal-subset-p handler) nil))
+
+(defmethod sax:entity-resolver ((handler klacks-dtd-handler) fn)
+  (setf (slot-value (handler-source handler) 'dom-impl-entity-resolver) fn))
+
+(defmethod sax::dtd ((handler klacks-dtd-handler) dtd)
+  (setf (slot-value (handler-source handler) 'dom-impl-dtd) dtd))
+
+(defmethod sax:end-dtd ((handler klacks-dtd-handler))
+  (let ((source (handler-source handler)))
+    (when (slot-boundp source 'internal-declarations)
+      (setf (slot-value source 'internal-declarations)
+	    (reverse (slot-value source 'internal-declarations)))
+      (setf (slot-value source 'external-declarations)
+	    (reverse (slot-value source 'external-declarations))))))
+
+(macrolet
+    ((defhandler (name &rest args)
+	 `(defmethod ,name ((handler klacks-dtd-handler) , at args)
+	    (let ((source (handler-source handler))
+		  (spec (list ',name , at args)))
+	      (if (handler-internal-subset-p handler)
+		  (push spec (slot-value source 'internal-declarations))
+		  (push spec (slot-value source 'external-declarations)))))))
+  (defhandler sax:unparsed-entity-declaration
+      name public-id system-id notation-name)
+  (defhandler sax:external-entity-declaration
+      kind name public-id system-id)
+  (defhandler sax:internal-entity-declaration
+      kind name value)
+  (defhandler sax:notation-declaration
+      name public-id system-id)
+  (defhandler sax:element-declaration
+      name model)
+  (defhandler sax:attribute-declaration
+      element-name attribute-name type default))
+
+
+;;;; locator
+
+(defun source-xstream (source)
+  (car (zstream-input-stack (main-zstream (slot-value source 'context)))))
+
+(defun source-stream-name (source)
+  (let ((xstream (source-xstream source)))
+    (if xstream
+	(xstream-name xstream)
+	nil)))
+
+(defmethod klacks:current-line-number ((source cxml-source))
+  (let ((x (source-xstream source)))
+    (if x
+	(xstream-line-number x)
+	nil)))
+
+(defmethod klacks:current-column-number ((source cxml-source))
+  (let ((x (source-xstream source)))
+    (if x
+	(xstream-column-number x)
+	nil)))
+
+(defmethod klacks:current-system-id ((source cxml-source))
+  (let ((name (source-stream-name source)))
+    (if name
+	(stream-name-uri name)
+	nil)))
+
+(defmethod klacks:current-xml-base ((source cxml-source))
+  (car (base-stack (slot-value source 'context))))
+
+(defmethod klacks:map-current-namespace-declarations (fn (source cxml-source))
+  (loop
+     for (prefix . uri) in (slot-value source 'current-namespace-declarations)
+     do
+       (funcall fn prefix uri)))
+
+(defmethod klacks:find-namespace-binding (prefix (source cxml-source))
+  (with-source (source)
+    (find-namespace-binding prefix)))
+
+(defmethod klacks:decode-qname (qname (source cxml-source))
+  (with-source (source)
+    (multiple-value-bind (prefix local-name) (split-qname qname)
+      (values (and prefix (find-namespace-binding prefix))
+	      local-name
+	      prefix))))
+
+
+;;;; debugging
+
+#+(or)
+(trace CXML::KLACKS/DOCTYPE 
+       CXML::KLACKS/EXT-PARSED-ENT 
+       CXML::KLACKS/MISC*-2 
+       CXML::KLACKS/ENTITY-REFERENCE 
+       CXML::KLACKS/ENTITY-REFERENCE-2 
+       CXML::KLACKS/ELEMENT 
+       CXML::KLACKS/ZTAG 
+       CXML::KLACKS/XMLDECL 
+       CXML::KLACKS/FINISH-DOCTYPE 
+       CXML::KLACKS/ELEMENT-3 
+       CXML::KLACKS/EOF 
+       CXML::KLACKS/ELEMENT-2 
+       CXML::KLACKS/CONTENT )

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/klacks.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,259 @@
+;;; -*- Mode: Lisp; readtable: runes; -*-
+;;;  (c) copyright 2007 David Lichteblau
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :cxml)
+
+(defclass klacks:source ()
+    (
+     ;; fixme, terrible DTD kludges
+     (internal-declarations)
+     (external-declarations :initform nil)
+     (dom-impl-dtd :initform nil)
+     (dom-impl-entity-resolver :initform nil)))
+
+(defgeneric klacks:close-source (source))
+
+(defgeneric klacks:peek (source))
+(defgeneric klacks:peek-value (source))
+(defgeneric klacks:consume (source))
+
+(defgeneric klacks:map-attributes (fn source))
+(defgeneric klacks:list-attributes (source))
+(defgeneric klacks:get-attribute (source lname &optional uri))
+;;;(defgeneric klacks:current-uri (source))
+;;;(defgeneric klacks:current-lname (source))
+;;;(defgeneric klacks:current-qname (source))
+;;;(defgeneric klacks:current-characters (source))
+(defgeneric klacks:current-cdata-section-p (source))
+(defgeneric klacks:map-current-namespace-declarations (fn source))
+
+(defgeneric klacks:current-line-number (source))
+(defgeneric klacks:current-column-number (source))
+(defgeneric klacks:current-system-id (source))
+(defgeneric klacks:current-xml-base (source))
+
+(defgeneric klacks:find-namespace-binding (prefix source))
+(defgeneric klacks:decode-qname (qname source))
+
+(defmacro klacks:with-open-source ((var source) &body body)
+  `(let ((,var ,source))
+     (unwind-protect
+	 (progn , at body)
+       (klacks:close-source ,var))))
+
+(defun klacks:current-uri (source)
+  (multiple-value-bind (key uri lname qname) (klacks:peek source)
+    (declare (ignore lname qname))
+    (check-type key (member :start-element :end-element))
+    uri))
+
+(defun klacks:current-lname (source)
+  (multiple-value-bind (key uri lname qname) (klacks:peek source)
+    (declare (ignore uri qname))
+    (check-type key (member :start-element :end-element))
+    lname))
+
+(defun klacks:current-qname (source)
+  (multiple-value-bind (key uri lname qname) (klacks:peek source)
+    (declare (ignore uri lname))
+    (check-type key (member :start-element :end-element))
+    qname))
+
+(defun klacks:current-characters (source)
+  (multiple-value-bind (key characters) (klacks:peek source)
+    (check-type key (member :characters))
+    characters))
+
+(defun klacks:consume-characters (source)
+  (with-output-to-string (s)
+    (while (eq (klacks:peek source) :characters)
+      (write-string (klacks:current-characters source) s)
+      (klacks:consume source))))
+
+(defun klacks:serialize-event (source handler &key (consume t))
+  (multiple-value-bind (key a b c) (klacks:peek source)
+    (let ((result nil))
+      (case key
+	(:start-document
+	  (sax:start-document handler)
+	  (loop for (prefix . uri) in *initial-namespace-bindings* do
+	       (sax:start-prefix-mapping handler prefix uri)))
+	(:characters
+	  (cond
+	    ((klacks:current-cdata-section-p source)
+	      (sax:start-cdata handler)
+	      (sax:characters handler a)
+	      (sax:end-cdata handler))
+	    (T
+	      (sax:characters handler a))))
+	(:processing-instruction
+	  (sax:processing-instruction handler a b))
+	(:comment
+	  (sax:comment handler a))
+	(:dtd
+	  (sax:start-dtd handler a b c)
+	  (when (slot-boundp source 'internal-declarations)
+	    (sax:start-internal-subset handler)
+	    (serialize-declaration-kludge
+	     (slot-value source 'internal-declarations)
+	     handler)
+	    (sax:end-internal-subset handler))
+	  (serialize-declaration-kludge
+	   (slot-value source 'external-declarations)
+	   handler)
+	  (sax:end-dtd handler)
+	  (sax:entity-resolver handler
+			       (slot-value source 'dom-impl-entity-resolver))
+	  (sax::dtd handler (slot-value source 'dom-impl-dtd)))
+	(:start-element
+	  (klacks:map-current-namespace-declarations
+	   (lambda (prefix uri)
+	     (sax:start-prefix-mapping handler prefix uri))
+	   source)
+	  (sax:start-element handler a b c (klacks:list-attributes source)))
+	(:end-element
+	  (sax:end-element handler a b c)
+	  (klacks:map-current-namespace-declarations
+	   (lambda (prefix uri)
+	     (declare (ignore uri))
+	     (sax:end-prefix-mapping handler prefix))
+	   source))
+	(:end-document
+	 (loop for (prefix . nil) in *initial-namespace-bindings* do
+	      (sax:end-prefix-mapping handler prefix))
+	  (setf result (sax:end-document handler)))
+	((nil)
+	  (error "serialize-event read past end of document"))
+	(t
+	  (error "unexpected klacks key: ~A" key)))
+      (when consume
+	(klacks:consume source))
+      result)))
+
+(defun serialize-declaration-kludge (list handler)
+  (loop
+      for (fn . args) in list
+      do (apply fn handler args)))
+
+(defun klacks:serialize-source (source handler)
+  (loop
+    (let ((document (klacks:serialize-event source handler)))
+      (when document
+	(return document)))))
+
+(defclass klacksax (sax:sax-parser)
+    ((source :initarg :source)))
+
+(defmethod sax:line-number ((parser klacksax))
+  (klacks:current-line-number (slot-value parser 'source)))
+
+(defmethod sax:column-number ((parser klacksax))
+  (klacks:current-column-number (slot-value parser 'source)))
+
+(defmethod sax:system-id ((parser klacksax))
+  (klacks:current-system-id (slot-value parser 'source)))
+
+(defmethod sax:xml-base ((parser klacksax))
+  (klacks:current-xml-base (slot-value parser 'source)))
+
+(defun klacks:serialize-element (source handler &key (document-events t))
+  (unless (eq (klacks:peek source) :start-element)
+    (error "not at start of element"))
+  (sax:register-sax-parser handler (make-instance 'klacksax :source source))
+  (when document-events
+    (sax:start-document handler))
+  (labels ((recurse ()
+	     (klacks:serialize-event source handler)
+	     (loop
+	       (let ((key (klacks:peek source)))
+		 (ecase key
+		   (:start-element (recurse))
+		   (:end-element (return))
+		   ((:characters :comment :processing-instruction)
+		     (klacks:serialize-event source handler)))))
+	     (klacks:serialize-event source handler)))
+    (recurse))
+  (when document-events
+    (sax:end-document handler)))
+
+(defun klacks:find-element (source &optional lname uri)
+  (loop
+    (multiple-value-bind (key current-uri current-lname current-qname)
+	(klacks:peek source)
+      (case key
+	((nil)
+	  (return nil))
+	(:start-element
+	  (when (and (eq key :start-element)
+		     (or (null lname)
+			 (equal lname (klacks:current-lname source)))
+		     (or (null uri)
+			 (equal uri (klacks:current-uri source))))
+	    (return
+	      (values key current-uri current-lname current-qname)))))
+      (klacks:consume source))))
+
+(defun klacks:find-event (source key)
+  (loop
+    (multiple-value-bind (this a b c)
+	(klacks:peek source)
+      (cond
+	((null this)
+	  (return nil))
+	((eq this key)
+	  (return (values this a b c))))
+      (klacks:consume source))))
+
+(define-condition klacks-error (xml-parse-error) ())
+
+(defun klacks-error (fmt &rest args)
+  (%error 'klacks-error
+	  nil
+	  (format nil "Klacks assertion failed: ~?" fmt args)))
+
+(defun klacks:expect (source key &optional u v w)
+  (multiple-value-bind (this a b c)
+      (klacks:peek source)
+    (unless (eq this key) (klacks-error "expected ~A but got ~A" key this))
+    (when (and u (not (equal a u)))
+      (klacks-error "expected ~A but got ~A" u a))
+    (when (and v (not (equal b v)))
+      (klacks-error "expected ~A but got ~A" v b))
+    (when (and w (not (equal c w)))
+      (klacks-error "expected ~A but got ~A" w c))
+    (values this a b c)))
+
+(defun klacks:skip (source key &optional a b c)
+  (klacks:expect source key a b c)
+  (klacks:consume source))
+
+(defun invoke-expecting-element (fn source &optional lname uri)
+  (multiple-value-bind (key a b)
+      (klacks:peek source)
+    (unless (eq key :start-element)
+      (klacks-error "expected ~A but got ~A" (or lname "element") key))
+    (when (and uri (not (equal a uri)))
+      (klacks-error "expected ~A but got ~A" uri a))
+    (when (and lname (not (equal b lname)))
+      (klacks-error "expected ~A but got ~A" lname b))
+    (multiple-value-prog1
+	(funcall fn)
+      (klacks:skip source :end-element a b))))
+
+(defmacro klacks:expecting-element ((source &optional lname uri) &body body)
+  `(invoke-expecting-element (lambda () , at body) ,source ,lname ,uri))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/package.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,63 @@
+;;; -*- Mode: Lisp; readtable: runes; -*-
+;;;  (c) copyright 2007 David Lichteblau
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA  02111-1307  USA.
+
+(defpackage klacks
+  (:use)
+  (:export #:source
+	   #:close-source
+	   #:with-open-source
+
+	   #:tapping-source
+	   #:make-tapping-source
+	   #:dribble-handler
+
+	   #:peek
+	   #:peek-value
+	   #:peek-next
+	   #:consume
+
+	   #:expect
+	   #:skip
+	   #:find-element
+	   #:find-event
+	   #:expecting-element
+
+	   #:map-attributes
+	   #:list-attributes
+	   #:get-attribute
+	   #:current-uri
+	   #:current-lname
+	   #:current-qname
+	   #:current-characters
+	   #:consume-characters
+	   #:current-cdata-section-p
+	   #:map-current-namespace-declarations
+	   
+	   #:serialize-event
+	   #:serialize-element
+	   #:serialize-source
+
+	   #:klacks-error
+
+	   #:current-line-number
+	   #:current-column-number
+	   #:current-system-id
+	   #:current-xml-base
+
+	   #:find-namespace-binding
+	   #:decode-qname))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/tap-source.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/klacks/tap-source.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,106 @@
+;;; -*- Mode: Lisp; readtable: runes; -*-
+;;;  (c) copyright 2007 David Lichteblau
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :cxml)
+
+(defun klacks:make-tapping-source (upstream-source &optional sax-handler)
+  (make-instance 'klacks:tapping-source
+		 :upstream-source upstream-source
+		 :dribble-handler sax-handler))
+
+(defclass klacks:tapping-source (klacks:source)
+    ((upstream-source :initarg :upstream-source :accessor upstream-source)
+     (dribble-handler :initarg :dribble-handler :accessor dribble-handler)
+     (seen-event-p :initform nil :accessor seen-event-p)
+     (document-done-p :initform nil :accessor document-done-p)))
+
+(defmethod initialize-instance :after ((instance klacks:tapping-source) &key)
+  (let ((s-p (make-instance 'klacksax :source (upstream-source instance))))
+    (sax:register-sax-parser (dribble-handler instance) s-p)))
+
+
+;;; event dribbling 
+
+(defun maybe-dribble (source)
+  (unless (or (seen-event-p source) (document-done-p source))
+    (when (eq (klacks:peek (upstream-source source)) :end-document)
+      (setf (document-done-p source) t))
+    (klacks:serialize-event (upstream-source source)
+			    (dribble-handler source)
+			    :consume nil)
+    (setf (seen-event-p source) t)))
+
+(defmethod klacks:peek ((source klacks:tapping-source))
+  (multiple-value-prog1
+      (klacks:peek (upstream-source source))
+    (maybe-dribble source)))
+
+(defmethod klacks:peek-value ((source klacks:tapping-source))
+  (multiple-value-prog1
+      (klacks:peek-value (upstream-source source))
+    (maybe-dribble source)))
+
+(defmethod klacks:peek-next ((source klacks:tapping-source))
+  (setf (seen-event-p source) nil)
+  (multiple-value-prog1
+      (klacks:peek-next (upstream-source source))
+    (maybe-dribble source)))
+
+(defmethod klacks:consume ((source klacks:tapping-source))
+  (maybe-dribble source)
+  (multiple-value-prog1
+      (klacks:consume (upstream-source source))
+    (setf (seen-event-p source) nil)))
+
+
+;;; loop through
+
+(defmethod klacks:close-source ((source klacks:tapping-source))
+  (klacks:close-source (upstream-source source)))
+
+(defmethod klacks:map-attributes (fn (source klacks:tapping-source))
+  (klacks:map-attributes fn (upstream-source source)))
+
+(defmethod klacks:map-current-namespace-declarations
+    (fn (source klacks:tapping-source))
+  (klacks:map-current-namespace-declarations fn (upstream-source source)))
+
+(defmethod klacks:list-attributes ((source klacks:tapping-source))
+  (klacks:list-attributes (upstream-source source)))
+
+(defmethod klacks:current-line-number ((source klacks:tapping-source))
+  (klacks:current-line-number (upstream-source source)))
+
+(defmethod klacks:current-column-number ((source klacks:tapping-source))
+  (klacks:current-column-number (upstream-source source)))
+
+(defmethod klacks:current-system-id ((source klacks:tapping-source))
+  (klacks:current-system-id (upstream-source source)))
+
+(defmethod klacks:current-xml-base ((source klacks:tapping-source))
+  (klacks:current-xml-base (upstream-source source)))
+
+(defmethod klacks:current-cdata-section-p ((source klacks:tapping-source))
+  (klacks:current-cdata-section-p (upstream-source source)))
+
+(defmethod klacks:find-namespace-binding
+    (prefix (source klacks:tapping-source))
+  (klacks:find-namespace-binding prefix (upstream-source source)))
+
+(defmethod klacks:decode-qname (qname (source klacks:tapping-source))
+  (klacks:decode-qname qname (upstream-source source)))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/mlisp-patch.diff
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/mlisp-patch.diff	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,68 @@
+--- xml/xml-parse.lisp
++++ xml/xml-parse.lisp
+@@ -2497,20 +2497,20 @@
+   (let ((input-var (gensym))
+         (collect (gensym))
+         (c (gensym)))
+-    `(LET ((,input-var ,input))
+-       (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) 
+-           (WITH-RUNE-COLLECTOR/RAW (,collect)
+-             (LOOP
+-               (LET ((,c (PEEK-RUNE ,input-var)))
+-                 (COND ((EQ ,c :EOF) 
++    `(let ((,input-var ,input))
++       (multiple-value-bind (,res ,res-start ,res-end) 
++           (with-rune-collector/raw (,collect)
++             (loop
++               (let ((,c (peek-rune ,input-var)))
++                 (cond ((eq ,c :eof) 
+                         ;; xxx error message
+-                        (RETURN))
+-                       ((FUNCALL ,predicate ,c)
+-                        (RETURN))
++                        (return))
++                       ((funcall ,predicate ,c)
++                        (return))
+                        (t
+                         (,collect ,c)
+-                        (CONSUME-RUNE ,input-var))))))
+-         (LOCALLY
++                        (consume-rune ,input-var))))))
++         (locally
+            , at body)))))
+   
+ (defun read-name-token (input)
+
+
+
+Index: xml/xml-name-rune-p.lisp
+===================================================================
+RCS file: /project/cxml/cvsroot/cxml/xml/xml-name-rune-p.lisp,v
+retrieving revision 1.2
+diff -r1.2 xml-name-rune-p.lisp
+214,225c214,225
+<              (DEFINLINE NAME-RUNE-P (RUNE)
+<                (SETF RUNE (RUNE-CODE RUNE))
+<                (AND (<= 0 RUNE ,*max*)
+<                     (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
+<                              (= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
+<                                         (THE FIXNUM RUNE))))))
+<              (DEFINLINE NAME-START-RUNE-P (RUNE)
+<                (SETF RUNE (RUNE-CODE RUNE))
+<                (AND (<= 0 RUNE ,*MAX*)
+<                     (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
+<                              (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
+<                                         (THE FIXNUM RUNE)))))))) ))))
+---
+>              (definline name-rune-p (rune)
+>                (setf rune (rune-code rune))
+>                (and (<= 0 rune ,*max*)
+>                     (locally (declare (optimize (safety 0) (speed 3)))
+>                              (= 1 (sbit ',(predicate-to-bv #'name-rune-p)
+>                                         (the fixnum rune))))))
+>              (definline name-start-rune-p (rune)
+>                (setf rune (rune-code rune))
+>                (and (<= 0 rune ,*max*)
+>                     (locally (declare (optimize (safety 0) (speed 3)))
+>                              (= 1 (sbit ',(predicate-to-bv #'name-start-rune-p)
+>                                         (the fixnum rune)))))))) ))))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/domtest.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/domtest.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,719 @@
+(defpackage :domtest
+  (:use :cl :cxml)
+  (:export #:run-all-tests))
+(defpackage :domtest-tests
+  (:use))
+(in-package :domtest)
+
+
+;;;; allgemeine Hilfsfunktionen
+
+(defmacro string-case (keyform &rest clauses)
+  (let ((key (gensym "key")))
+    `(let ((,key ,keyform))
+       (declare (ignorable ,key))
+       (cond
+	 ,@(loop
+	       for (keys . forms) in clauses
+	       for test = (etypecase keys
+			    (string `(string= ,key ,keys))
+			    (sequence `(find ,key ',keys :test 'string=))
+			    ((eql t) t))
+	       collect
+		 `(,test , at forms))))))
+
+(defun rcurry (function &rest args)
+  (lambda (&rest more-args)
+    (apply function (append more-args args))))
+
+(defmacro for ((&rest clauses) &rest body-forms)
+  `(%for ,clauses (progn , at body-forms)))
+
+(defmacro for* ((&rest clauses) &rest body-forms)
+  `(%for* ,clauses (progn , at body-forms)))
+
+(defmacro %for ((&rest clauses) body-form &rest finally-forms)
+  (for-aux 'for clauses body-form finally-forms))
+
+(defmacro %for* ((&rest clauses) body-form &rest finally-forms)
+  (for-aux 'for* clauses body-form finally-forms))
+
+(defmacro for-finish ()
+  '(loop-finish))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun for-aux (kind clauses body-form finally-forms)
+    ` (loop ,@ (loop for firstp = t then nil
+		   for %clauses = clauses then (rest %clauses)
+		   for clause = (first %clauses) then (first %clauses)
+		   while (and %clauses (listp clause))
+		   append (cons (ecase kind
+				  (for (if firstp 'as 'and))
+				  (for* 'as))
+				(if (= 2 (length clause))
+				    (list (first clause) '= (second clause))
+				    clause))
+		   into result
+		   finally (return (append result %clauses)))
+	  do (progn ,body-form)
+	  finally (progn , at finally-forms))))
+
+
+;;;; spezielle Hilfsfunktionen
+
+(defun tag-name (elt)
+  (runes:rod-string (dom:tag-name elt)))
+
+(defmacro with-attributes ((&rest attributes) element &body body)
+  (let ((e (gensym "element")))
+    `(let* ((,e ,element)
+            ,@(mapcar (lambda (var)
+                       `(,var (dom:get-attribute ,e ,(symbol-name var))))
+                     attributes))
+       , at body)))
+
+(defun map-child-elements (result-type fn element &key name)
+  (remove '#1=#:void
+          (map result-type
+            (lambda (node)
+              (if (and (eq (dom:node-type node) :element)
+                       (or (null name)
+                           (equal (tag-name node) name)))
+                  (funcall fn node)
+                  '#1#))
+            (dom:child-nodes element))))
+
+(defmacro do-child-elements ((var element &key name) &body body)
+  `(block nil
+     (map-child-elements nil (lambda (,var) , at body) ,element :name ,name)))
+
+(defun find-child-element (name element)
+  (do-child-elements (child element :name name)
+    (return child)))
+
+(defun %intern (name)
+  (unless (stringp name)
+    (setf name (runes:rod-string name)))
+  (if (zerop (length name))
+      nil
+      (intern name :domtest-tests)))
+
+(defun replace-studly-caps (str)
+  (unless (stringp str)
+    (setf str (runes:rod-string str)))
+  ;; s/([A-Z][a-z])/-\1/
+  (with-output-to-string (out)
+    (with-input-from-string (in str)
+      (for ((c = (read-char in nil nil))
+            (previous = nil then c)
+            (next = (peek-char nil in nil nil))
+            :while c)
+        (when (and previous
+                   (upper-case-p c) next (lower-case-p next)
+                   (not (lower-case-p previous)))
+          (write-char #\- out))
+        (write-char (char-downcase c) out)
+        (when (and (lower-case-p c) next (upper-case-p next))
+          (write-char #\- out))))))
+
+(defun intern-dom (name)
+  (setf name (replace-studly-caps name))
+  (when (eq :foo :FOO)
+    (setf name (string-upcase name)))
+  (intern name :dom))
+
+(defun child-elements (element)
+  (map-child-elements 'list #'identity element))
+
+(defun parse-java-literal (str)
+  (when (stringp str)
+    (setf str (runes:string-rod str)))
+  (cond
+    ((zerop (length str)) nil)
+    ((runes:rod= str #"true")
+      t)
+    ((runes:rod= str #"false")
+      nil)
+    ((digit-char-p (runes:rune-char (elt str 0)))
+      (parse-integer (runes:rod-string str)))
+    ((runes:rune= (elt str 0) #.(runes:char-rune #\"))
+      (let ((v (make-array 1 :fill-pointer 0 :adjustable t)))
+        (for* ((i = 1 :then (1+ i))
+               (c = (elt str i))
+               :until (runes:rune= c #.(runes:char-rune #\")))
+            (if (runes:rune= c #.(runes:char-rune #\\))
+                (let ((frob
+		       (progn
+                         (incf i)
+                         (elt str i))))
+		  (ecase frob
+		    ;; ...
+		    (#/n (vector-push-extend #/newline v (length v)))
+		    ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
+                (vector-push-extend c v (length v))))
+        (make-array (length v) :element-type 'runes:rune :initial-contents v)))
+    (t
+      (%intern str))))
+
+(defun maybe-setf (place form)
+  (if place
+      `(setf ,place ,form)
+      form))
+
+(defun nullify (str)
+  (if (zerop (length str)) nil str))
+
+
+;;;; dom1-interfaces.xml auslesen
+
+(defparameter *methods* '())
+(defparameter *fields* '())
+
+(declaim (special *directory*))
+(declaim (special *files-directory*))
+
+(defun read-members (&optional (directory *directory*))
+  (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
+         (builder (rune-dom:make-dom-builder))
+         (library (dom:document-element
+		   (cxml:parse-file pathname builder :recode nil)))
+         (methods '())
+         (fields '()))
+    (do-child-elements (interface library :name "interface")
+      (do-child-elements (method interface :name "method")
+        (let ((parameters (find-child-element "parameters" method)))
+          (push (cons (dom:get-attribute method "name")
+                      (map-child-elements 'list
+                                          (rcurry #'dom:get-attribute "name")
+                                          parameters
+                                          :name "param"))
+                methods)))
+      (do-child-elements (attribute interface :name "attribute")
+        (push (dom:get-attribute attribute "name") fields)))
+    (values methods fields)))
+
+
+;;;; Conditions uebersetzen
+
+(defun translate-condition (element)
+  (string-case (tag-name element)
+    ("equals" (translate-equals element))
+    ("notEquals" (translate-not-equals element))
+    ("contentType" (translate-content-type element))
+    ("implementationAttribute" (assert-have-implementation-attribute element))
+    ("isNull" (translate-is-null element))
+    ("not" (translate-is-null element))
+    ("notNull" (translate-not-null element))
+    ("or" (translate-or element))
+    ("same" (translate-same element))
+    ("less" (translate-less element))
+    (t (error "unknown condition: ~A" element))))
+
+(defun equalsp (a b test)
+  (when (dom:named-node-map-p a)
+    (setf a (dom:items a)))
+  (when (dom:named-node-map-p b)
+    (setf b (dom:items b)))
+  (if (and (typep a 'sequence) (typep b 'sequence))
+      (null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test))
+      (funcall test a b)))
+
+(defun %equal (a b)
+  (or (equal a b) (and (runes::rodp a) (runes::rodp b) (runes:rod= a b))))
+
+(defun %equalp (a b)
+  (or (equalp a b) (and (runes::rodp a) (runes::rodp b) (runes:rod-equal a b))))
+
+(defun translate-equals (element)
+  (with-attributes (|actual| |expected| |ignoreCase|) element
+    `(equalsp ,(%intern |actual|)
+              ,(parse-java-literal |expected|)
+              ',(if (parse-java-literal |ignoreCase|) '%equal '%equal))))
+
+(defun translate-not-equals (element)
+  `(not ,(translate-equals element)))
+
+(defun translate-same (element)
+  (with-attributes (|actual| |expected|) element
+    `(eql ,(%intern |actual|) ,(parse-java-literal |expected|))))
+
+(defun translate-less (element)
+  (with-attributes (|actual| |expected|) element
+    `(< ,(%intern |actual|) ,(parse-java-literal |expected|))))
+
+(defun translate-or (element)
+  `(or ,@(map-child-elements 'list #'translate-condition element)))
+
+(defun translate-instance-of (element)
+  (with-attributes (|obj| |type|) element
+    `(eq (dom:node-type ,(%intern |obj|))
+         ',(string-case (runes:rod-string |type|)
+             ("Document" :document)
+             ("DocumentFragment" :document-fragment)
+             ("Text" :text)
+             ("Comment" :comment)
+             ("CDATASection" :cdata-section)
+             ("Attr" :attribute)
+             ("Element" :element)
+             ("DocumentType" :document-type)
+             ("Notation" :notation)
+             ("Entity" :entity)
+             ("EntityReference" :entity-reference)
+             ("ProcessingInstruction" :processing-instruction)
+             (t (error "unknown interface: ~A" |type|))))))
+
+(defun translate-is-null (element)
+  (with-attributes (|obj|) element
+    `(null ,(%intern |obj|))))
+
+(defun translate-not-null (element)
+  (with-attributes (|obj|) element
+    (%intern |obj|)))
+
+(defun translate-content-type (element) ;XXX verstehe ich nicht
+  (with-attributes (|type|) element 
+   `(equal ,|type| "text/xml")))
+
+(defun translate-uri-equals (element)
+  (with-attributes
+      (|actual|
+       |scheme| |path| |host| |file| |name| |query| |fragment| |isAbsolute|)
+      element
+    |isAbsolute|
+   `(let ((uri (net.uri:parse-uri (runes:rod-string ,(%intern |actual|)))))
+      (flet ((uri-directory (path)
+               (namestring
+                (make-pathname :directory (pathname-directory path))))
+             (uri-file (path)
+               (namestring (make-pathname :name (pathname-name path)
+                                          :type (pathname-type path))))
+             (uri-name (path)
+               (pathname-name path))
+             (maybe-equal (expected actual)
+               (if expected
+                   (%equal (runes::rod expected) (runes::rod actual))
+                   t)))
+        (and (maybe-equal ,(parse-java-literal |scheme|)
+                          (net.uri:uri-scheme uri))
+             (maybe-equal ,(parse-java-literal |host|)
+                          (net.uri:uri-host uri))
+             (maybe-equal ,(parse-java-literal |path|)
+                          (uri-directory (net.uri:uri-path uri)))
+             (maybe-equal ,(parse-java-literal |file|)
+                          (uri-file (net.uri:uri-path uri)))
+             (maybe-equal ,(parse-java-literal |name|)
+                          (uri-name (net.uri:uri-path uri)))
+             (maybe-equal ,(parse-java-literal |query|)
+                          (net.uri:uri-query uri))
+             (maybe-equal ,(parse-java-literal |fragment|)
+                          (net.uri:uri-fragment uri)))))))
+
+
+;;;; Statements uebersetzen
+
+(defun translate-statement (element)
+  (string-case (tag-name element)
+    ("append" (translate-append element))
+    ("assertDOMException" (translate-assert-domexception element))
+    ("assertEquals"	(translate-assert-equals element))
+    ("assertNotNull"	(translate-assert-not-null element))
+    ("assertInstanceOf"	(translate-assert-instance-of element))
+    ("assertNull"	(translate-assert-null element))
+    ("assertSame"	(translate-assert-same element))
+    ("assertSize"	(translate-assert-size element))
+    ("assertTrue"	(translate-assert-true element))
+    ("assertFalse"	(translate-assert-false element))
+    ("assertURIEquals"	(translate-assert-uri-equals element))
+    ("assign"		(translate-assign element))
+    ("for-each"		(translate-for-each element))
+    ("fail"		(translate-fail element))
+    ("hasFeature" (translate-has-feature element))
+    ("if"		(translate-if element))
+    ("implementation"	(translate-implementation element))
+    ("increment"	(translate-unary-assignment '+ element))
+    ("decrement"	(translate-unary-assignment '- element))
+    ("length"		(translate-length element))
+    ("load"		(translate-load element))
+    ("nodeType"		(translate-node-type element))
+    ("plus"		(translate-binary-assignment '+ element))
+    ("try"		(translate-try element))
+    ("while"		(translate-while element))
+    (t			(translate-member element))))
+
+(defun translate-binary-assignment (fn element)
+  (with-attributes (|var| |op1| |op2|) element
+    (maybe-setf (%intern |var|)
+                `(,fn ,(parse-java-literal |op1|)
+                      ,(parse-java-literal |op2|)))))
+
+(defun translate-assign (element)
+  (with-attributes (|var| |value|) element
+    (maybe-setf (%intern |var|) (parse-java-literal |value|))))
+
+(defun translate-unary-assignment (fn element)
+  (with-attributes (|var| |value|) element
+    (maybe-setf (%intern |var|)
+                `(,fn ,(%intern |var|) ,(parse-java-literal |value|)))))
+
+(defun translate-load (load)
+  (with-attributes (|var| |href| |willBeModified|) load
+    (maybe-setf (%intern |var|)
+                `(load-file ,|href| ,(parse-java-literal |willBeModified|)))))
+
+(defun translate-implementation (elt)
+  (with-attributes (|var|) elt
+    (maybe-setf (%intern |var|) `'rune-dom:implementation)))
+
+(defun translate-length (load)
+  ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen
+  ;; der Laenge von DOMString und der length()-Methode der uebrigen
+  ;; Interfaces.  Also unterscheiden wir das erstmal manuell.
+  (with-attributes (|var| |obj|) load
+    (let ((obj (%intern |obj|)))
+      (maybe-setf (%intern |var|)
+                  `(if (typep ,obj 'sequence)
+                       (length ,obj)
+                       (dom:length ,obj))))))
+
+(defun translate-call (call method)
+  (let ((name (car method))
+        (args (mapcar (lambda (name)
+                        (parse-java-literal (dom:get-attribute call name)))
+                      (cdr method))))
+    (with-attributes (|var| |obj|) call
+      (maybe-setf (%intern |var|)
+                  `(,(intern-dom name) ,(%intern |obj|) , at args)))))
+
+(defun translate-get (call name)
+  (with-attributes (|var| |value| |obj|) call
+    (cond
+      ((nullify |var|)                  ;get
+        (maybe-setf (%intern |var|) `(,(intern-dom name) ,(%intern |obj|))))
+      ((nullify |value|)                ;set
+        `(setf (,(intern-dom name) ,(%intern |obj|))
+               ,(parse-java-literal |value|)))
+      (t
+        (error "oops")))))
+
+(defun translate-has-feature (element)
+  (with-attributes (|obj| |var| |feature| |version|) element
+    (if (nullify |obj|)
+	(translate-member element)
+	(maybe-setf (%intern |var|)
+		    `(dom:has-feature 'rune-dom:implementation
+				      ,(parse-java-literal |feature|)
+				      ,(parse-java-literal |version|))))))
+
+(defun translate-fail (element)
+  (declare (ignore element))
+  `(error "failed"))
+
+(defun translate-node-type (element)
+  ;; XXX Das muessten eigentlich ints sein, sind aber Keywords in CXML.
+  (with-attributes (|var| |obj|) element
+    (maybe-setf (%intern |var|)
+                `(ecase (dom:node-type ,(%intern |obj|))
+                   (:element                1)
+                   (:attribute              2)
+                   (:text                   3)
+                   (:cdata-section          4)
+                   (:entity-reference       5)
+                   (:entity                 6)
+                   (:processing-instruction 7)
+                   (:comment                8)
+                   (:document               9)
+                   (:document-type          10)
+                   (:document-fragment      11)
+                   (:notation               12)))))
+
+(defun translate-member (element)
+  (let* ((name (dom:tag-name element))
+         (method (find name *methods* :key #'car :test #'runes:rod=))
+         (field (find name *fields* :test #'runes:rod=)))
+    (cond
+      (method (translate-call element method))
+      (field (translate-get element field))
+      (t (error "unknown element ~A" element)))))
+
+(defun translate-assert-equals (element)
+  `(assert ,(translate-equals element)))
+
+(defun translate-assert-same (element)
+  `(assert ,(translate-same element)))
+
+(defun translate-assert-null (element)
+  (with-attributes (|actual|) element
+    `(assert (null ,(%intern |actual|)))))
+
+(defun translate-assert-not-null (element)
+  (with-attributes (|actual|) element
+    `(assert ,(%intern |actual|))))
+
+(defun translate-assert-size (element)
+  (with-attributes (|collection| |size|) element
+    `(let ((collection ,(%intern |collection|)))
+       (when (dom:named-node-map-p collection)
+         (setf collection (dom:items collection)))
+       (assert (eql (length collection) ,(parse-java-literal |size|))))))
+
+(defun translate-assert-instance-of (element)
+  `(assert ,(translate-instance-of element)))
+
+(defun translate-if (element)
+  (destructuring-bind (condition &rest rest)
+      (child-elements element)
+    (let (then else)
+      (dolist (r rest)
+        (when (equal (tag-name r) "else")
+          (setf else (child-elements r))
+          (return))
+        (push r then))
+      `(cond
+         (,(translate-condition condition)
+           ,@(mapcar #'translate-statement (reverse then)))
+         (t
+           ,@(mapcar #'translate-statement else))))))
+
+(defun translate-while (element)
+  (destructuring-bind (condition &rest body)
+      (child-elements element)
+    `(loop
+         while ,(translate-condition condition)
+         do (progn ,@(mapcar #'translate-statement body)))))
+
+(defun translate-assert-domexception (element)
+  (do-child-elements (c element)
+    (unless (equal (tag-name c) "metadata")
+      (return
+        `(block assert-domexception
+           (handler-bind
+               ((rune-dom::dom-exception
+                 (lambda (c)
+                   (when (eq (rune-dom::dom-exception-key c)
+                             ,(intern (tag-name c) :keyword))
+                     (return-from assert-domexception)))))
+             ,@(translate-body c)
+             (error "expected exception ~A" ,(tag-name c))))))))
+
+(defun translate-catch (catch return)
+  `(lambda (c)
+     ,@(map-child-elements
+        'list
+        (lambda (exception)
+          `(when (eq (rune-dom::dom-exception-key c)
+                     ,(intern (runes:rod-string (dom:get-attribute exception "code"))
+                              :keyword))
+             ,@(translate-body exception)
+             ,return))
+        catch)))
+
+(defun translate-try (element)
+  `(block try
+     (handler-bind
+         ((rune-dom::dom-exception
+           ,(translate-catch
+             (do-child-elements (c element :name "catch") (return c))
+             '(return-from try))))
+       ,@(map-child-elements 'list
+                             (lambda (c)
+                               (if (equal (tag-name c) "catch")
+                                   nil
+                                   (translate-statement c)))
+                             element))))
+
+(defun translate-append (element)
+  (with-attributes (|collection| |item|) element
+    (let ((c (%intern |collection|))
+          (i (%intern |item|)))
+      (maybe-setf c `(append ,c (list ,i))))))
+
+(defun translate-assert-true (element)
+  (with-attributes (|actual|) element
+    `(assert ,(if (nullify |actual|)
+                  (%intern |actual|)
+                  (translate-condition
+                   (do-child-elements (c element) (return c)))))))
+
+(defun translate-assert-false (element)
+  (with-attributes (|actual|) element
+    `(assert (not ,(%intern |actual|)))))
+
+(defun translate-assert-uri-equals (element)
+  `(assert ,(translate-uri-equals element)))
+
+
+;;;; Tests uebersetzen
+
+(defun translate-body (element)
+  (map-child-elements 'list #'translate-statement element))
+
+(defun translate-for-each (element)
+  (with-attributes (|collection| |member|) element
+    `(let ((collection ,(%intern |collection|)))
+       (when (dom:named-node-map-p collection)
+         (setf collection (dom:items collection)))
+       (map nil (lambda (,(%intern |member|)) ,@(translate-body element))
+            collection))))
+
+(defun assert-have-implementation-attribute (element)
+  (let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
+    (string-case attribute
+      ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo
+      ;; wir uns schon die muehe machen...
+      ("validating"
+        (setf cxml::*validate* t))
+      ("namespaceAware"
+	;; ???  dom 2 ohne namespace-support gibt's doch gar nicht,
+	;; ausser vielleicht in html-only implementationen, und dann sollen
+	;; sie halt auf hasFeature "XML" testen.
+        )
+      (t
+        (format t "~&implementationAttribute ~A not supported, skipping test~%"
+                attribute)
+        (throw 'give-up nil)))))
+
+(defun slurp-test (pathname)
+  (unless *fields*
+    (multiple-value-setq (*methods* *fields*) (read-members)))
+  (catch 'give-up
+    (let* ((builder (rune-dom:make-dom-builder))
+           (cxml::*validate* nil)         ;dom1.dtd is buggy
+           (test (dom:document-element
+		  (cxml:parse-file pathname builder :recode nil)))
+           title
+           (bindings '())
+           (code '()))
+      (declare (ignorable title))
+      (do-child-elements (e test)
+        (string-case (tag-name e)
+          ("metadata"
+            (let ((title-element (find-child-element "title" e)))
+              (setf title (dom:data (dom:first-child title-element)))))
+          ("var"
+            (push (list (%intern (dom:get-attribute e "name"))
+                        (string-case (runes:rod-string
+                                       (dom:get-attribute e "type"))
+                          (("byte" "short" "int" "long") 0)
+                          (t nil)))
+                  bindings)
+	    (let ((value (dom:get-attribute e "value")))
+	      (when value
+		(push `(setf ,(%intern (dom:get-attribute e "name"))
+			     ,(parse-java-literal value))
+		      code)))
+            (do-child-elements (member e :name "member") e
+              (push `(setf ,(%intern (dom:get-attribute e "name"))
+                           (append ,(%intern (dom:get-attribute e "name"))
+                                   (list
+                                    ,(parse-java-literal
+                                      (dom:data
+                                       (dom:item
+                                        (dom:child-nodes member)
+                                        0))))))
+                    code)))
+          ("implementationAttribute"
+            (assert-have-implementation-attribute e))
+          (t
+            (push (translate-statement e) code))))
+      `(lambda ()
+         (let ((*files-directory* ,*files-directory*) ;fuer copy&paste:
+	       , at bindings)
+           (declare (ignorable ,@(mapcar #'car bindings)))
+           ,@(reverse code))))))
+
+(defun load-file (name &optional will-be-modified-p)
+  (declare (ignore will-be-modified-p))
+  (setf name (runes:rod-string name))
+  (cxml:parse-file
+   (make-pathname :name name :type "xml" :defaults *files-directory*)
+   (rune-dom:make-dom-builder)
+   :recode nil))
+
+(defparameter *bad-tests*
+    '("hc_elementnormalize2.xml"
+      "hc_nodereplacechildnewchildexists.xml"
+      "characterdatadeletedatanomodificationallowederr.xml"))
+
+(defun dribble-tests (directory)
+  (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)))
+    (with-open-file (*standard-output*
+		     (merge-pathnames "DOMTEST" base)
+		     :direction :output
+		     :if-exists :supersede)
+      (run-all-tests directory))))
+
+(defun run-all-tests (*directory* &optional verbose)
+  (let* ((cxml::*redefinition-warning* nil)
+         (n 0)
+         (i 0)
+         (ntried 0)
+         (nfailed 0))
+    (flet ((parse (test-directory)
+	     (let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
+		    (builder (rune-dom:make-dom-builder))
+		    (suite (dom:document-element
+			    (cxml:parse-file all-tests builder :recode nil)))
+		    (*files-directory*
+		     (merge-pathnames "files/" test-directory)))
+	       (do-child-elements (member suite)
+		 (unless
+		     (or (equal (dom:tag-name member) "metadata")
+			 (member (runes:rod-string
+				  (dom:get-attribute member "href"))
+				 *bad-tests*
+				 :test 'equal))
+		   (incf n)))
+	       suite))
+	   (run (test-directory suite)
+	     (print test-directory)
+	     (let ((*files-directory*
+		    (merge-pathnames "files/" test-directory)))
+	       (do-child-elements (member suite)
+		 (let ((href (runes:rod-string
+			      (dom:get-attribute member "href"))))
+		   (unless (or (runes:rod= (dom:tag-name member) #"metadata")
+			       (member href *bad-tests* :test 'equal))
+		     (format t "~&~D/~D ~A~%" i n href)
+		     (let ((lisp (slurp-test
+				  (merge-pathnames href test-directory))))
+		       (when verbose
+			 (print lisp))
+		       (when lisp
+			 (incf ntried)
+			 (with-simple-restart (skip-test "Skip this test")
+			   (handler-case
+			       (let ((cxml::*validate* nil))
+				 (funcall (compile nil lisp)))
+			     (serious-condition (c)
+			       (incf nfailed)
+			       (format t "~&TEST FAILED: ~A~&" c))))))
+		     (incf i)))))))
+      (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*))
+	     (d2 (merge-pathnames "tests/level2/core/" *directory*))
+	     (suite1 (parse d1))
+	     (suite2 (parse d2)))
+	(run d1 suite1)
+	(run d2 suite2)))
+    (format t "~&~D/~D tests failed; ~D test~:P were skipped"
+            nfailed ntried (- n ntried))))
+
+(defun run-test (*directory* level href)
+  (let* ((test-directory
+	  (ecase level
+	    (1 (merge-pathnames "tests/level1/core/" *directory*))
+	    (2 (merge-pathnames "tests/level2/core/" *directory*))))
+	 (*files-directory* (merge-pathnames "files/" test-directory))
+	 (lisp (slurp-test (merge-pathnames href test-directory)))
+         (cxml::*validate* nil))
+    (print lisp)
+    (fresh-line)
+    (when lisp
+      (funcall (compile nil lisp)))))
+
+#+(or)
+(domtest::run-all-tests "/home/david/2001/DOM-Test-Suite/")
+
+#+(or)
+(domtest::run-test "/home/david/2001/DOM-Test-Suite/"
+		   1
+		   "attrcreatedocumentfragment.xml")

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/misc.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/misc.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,29 @@
+;;;
+;;; When I'll grow up, I'll be a complete test suite.
+
+(deftest utf-8
+    (flet ((doit (from below)
+	     (loop for code from from below below do
+		  (when (and (code-char code)
+			     (not (eql code #xfffe))
+			     (not (eql code #xffff)))
+		    (let* ((a (if (< code #x10000)
+				  (format nil "abc~C" (code-char code))
+				  (let* ((x (- code #x10000))
+					 (lo (ldb (byte 10 0) x))
+					 (hi (ldb (byte 10 10) x)))
+				    (format nil "abc~C~C"
+					    (code-char (logior #xD800 hi))
+					    (code-char 
+					     (logior #xDC00 lo))))))
+			   (b (cxml:utf8-string-to-rod
+			       (cxml:rod-to-utf8-string
+				a))))
+		      (unless (string= a b)
+			(format t "FAIL: ~S ~A ~A~%"
+				(code-char code)
+				(map 'vector #'char-code a)
+				(map 'vector #'char-code b))))))))
+      (doit 32 #xD800)
+      (doit #x10000 char-code-limit)
+      (values)))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/utf8domtest.diff
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/utf8domtest.diff	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,102 @@
+Index: test/domtest.lisp
+===================================================================
+RCS file: /project/cxml/cvsroot/cxml/test/domtest.lisp,v
+retrieving revision 1.13
+diff -u -r1.13 domtest.lisp
+--- test/domtest.lisp	27 Dec 2005 00:21:37 -0000	1.13
++++ test/domtest.lisp	27 Dec 2005 00:46:00 -0000
+@@ -137,21 +137,22 @@
+     ((digit-char-p (runes:rune-char (elt str 0)))
+       (parse-integer (runes:rod-string str)))
+     ((runes:rune= (elt str 0) #.(runes:char-rune #\"))
+-      (let ((v (make-array 1 :fill-pointer 0 :adjustable t)))
+-        (for* ((i = 1 :then (1+ i))
+-               (c = (elt str i))
+-               :until (runes:rune= c #.(runes:char-rune #\")))
+-            (if (runes:rune= c #.(runes:char-rune #\\))
+-                (let ((frob
+-		       (progn
+-                         (incf i)
+-                         (elt str i))))
+-		  (ecase frob
+-		    ;; ...
+-		    (#/n (vector-push-extend #/newline v (length v)))
+-		    ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
+-                (vector-push-extend c v (length v))))
+-        (coerce v 'runes::simple-rod)))
++      (utf8-dom::%rod
++       (let ((v (make-array 1 :fill-pointer 0 :adjustable t)))
++	 (for* ((i = 1 :then (1+ i))
++		(c = (elt str i))
++		:until (runes:rune= c #.(runes:char-rune #\")))
++	       (if (runes:rune= c #.(runes:char-rune #\\))
++		   (let ((frob
++			  (progn
++			    (incf i)
++			    (elt str i))))
++		     (ecase frob
++		       ;; ...
++		       (#/n (vector-push-extend #/newline v (length v)))
++		       ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
++		 (vector-push-extend c v (length v))))
++	 (coerce v 'runes::simple-rod))))
+     (t
+       (%intern str))))
+ 
+@@ -368,7 +369,7 @@
+ 
+ (defun translate-implementation (elt)
+   (with-attributes (|var|) elt
+-    (maybe-setf (%intern |var|) `'rune-dom:implementation)))
++    (maybe-setf (%intern |var|) `'utf8-dom:implementation)))
+ 
+ (defun translate-length (load)
+   ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen
+@@ -406,7 +407,7 @@
+     (if (nullify |obj|)
+ 	(translate-member element)
+ 	(maybe-setf (%intern |var|)
+-		    `(dom:has-feature 'rune-dom:implementation
++		    `(dom:has-feature 'utf8-dom:implementation
+ 				      ,(parse-java-literal |feature|)
+ 				      ,(parse-java-literal |version|))))))
+ 
+@@ -493,9 +494,9 @@
+       (return
+         `(block assert-domexception
+            (handler-bind
+-               ((rune-dom::dom-exception
++               ((utf8-dom::dom-exception
+                  (lambda (c)
+-                   (when (eq (rune-dom::dom-exception-key c)
++                   (when (eq (utf8-dom::dom-exception-key c)
+                              ,(intern (tag-name c) :keyword))
+                      (return-from assert-domexception)))))
+              ,@(translate-body c)
+@@ -506,7 +507,7 @@
+      ,@(map-child-elements
+         'list
+         (lambda (exception)
+-          `(when (eq (rune-dom::dom-exception-key c)
++          `(when (eq (utf8-dom::dom-exception-key c)
+                      ,(intern (runes:rod-string (dom:get-attribute exception "code"))
+                               :keyword))
+              ,@(translate-body exception)
+@@ -516,7 +517,7 @@
+ (defun translate-try (element)
+   `(block try
+      (handler-bind
+-         ((rune-dom::dom-exception
++         ((utf8-dom::dom-exception
+            ,(translate-catch
+              (do-child-elements (c element :name "catch") (return c))
+              '(return-from try))))
+@@ -631,7 +632,7 @@
+   (setf name (runes:rod-string name))
+   (cxml:parse-file
+    (make-pathname :name name :type "xml" :defaults *files-directory*)
+-   (rune-dom:make-dom-builder)))
++   (cxml:make-recoder (utf8-dom:make-dom-builder) 'cxml:rod-to-utf8-string)))
+ 
+ (defparameter *bad-tests*
+     '("hc_elementnormalize2.xml"

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf-base.diff
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf-base.diff	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,53 @@
+A recent check-in to the XML-Test-Suite's metadata has broken my parser for
+xmlconf.xml.  Apply this patch to revert it.
+
+Index: oasis/oasis.xml
+===================================================================
+RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/oasis/oasis.xml,v
+retrieving revision 1.5
+retrieving revision 1.6
+diff -u -r1.5 -r1.6
+--- oasis/oasis.xml	16 May 2002 14:46:32 -0000	1.5
++++ oasis/oasis.xml	4 Mar 2004 18:23:37 -0000	1.6
+@@ -1,6 +1,6 @@
+ <?xml version='1.0' encoding='UTF-8'?>
+ 
+-<TESTCASES PROFILE='OASIS/NIST TESTS, 1-Nov-1998' xml:base="oasis/">
++<TESTCASES PROFILE='OASIS/NIST TESTS, 1-Nov-1998'>
+ 
+   <TEST TYPE='valid' SECTIONS='2.2 [1]'
+       ID='o-p01pass2' URI='p01pass2.xml'>
+Index: xmltest/xmltest.xml
+===================================================================
+RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/xmltest/xmltest.xml,v
+retrieving revision 1.9
+retrieving revision 1.10
+diff -u -r1.9 -r1.10
+--- xmltest/xmltest.xml	21 May 2002 19:05:57 -0000	1.9
++++ xmltest/xmltest.xml	4 Mar 2004 18:25:11 -0000	1.10
+@@ -5,7 +5,7 @@
+     All Rights Reserved.
+ -->
+ 
+-<TESTCASES PROFILE="James Clark XMLTEST cases, 18-Nov-1998" xml:base="xmltest/">
++<TESTCASES PROFILE="James Clark XMLTEST cases, 18-Nov-1998">
+ 
+ <!-- Start:  not-wf/sa -->
+ <TEST TYPE="not-wf" ENTITIES="none" ID="not-wf-sa-001"
+Index: japanese/japanese.xml
+===================================================================
+RCS file: /sources/public/2001/XML-Test-Suite/xmlconf/japanese/japanese.xml,v
+retrieving revision 1.4
+retrieving revision 1.5
+diff -u -r1.4 -r1.5
+--- japanese/japanese.xml	26 Mar 2002 14:43:54 -0000	1.4
++++ japanese/japanese.xml	4 Mar 2004 18:18:39 -0000	1.5
+@@ -5,7 +5,7 @@
+     All Rights Reserved.
+ -->
+ 
+-<TESTCASES PROFILE="Fuji Xerox Japanese Text Tests" xml:base="japanese/">
++<TESTCASES PROFILE="Fuji Xerox Japanese Text Tests">
+ 
+     <TEST TYPE="error" SECTIONS="4.3.3 [4,84]"
+ 	    ID="pr-xml-euc-jp" ENTITIES="parameter" URI="pr-xml-euc-jp.xml">

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/test/xmlconf.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,232 @@
+(defpackage xmlconf
+  (:use :cl :runes)
+  (:export #:run-all-tests))
+(in-package :xmlconf)
+
+(defun get-attribute (element name)
+  (rod-string (dom:get-attribute element name)))
+
+(defparameter *bad-tests*
+    '(;; TS14
+      ;; http://lists.w3.org/Archives/Public/public-xml-testsuite/2002Mar/0001.html
+      "ibm-valid-P28-ibm28v02.xml"
+      "ibm-valid-P29-ibm29v01.xml"
+      "ibm-valid-P29-ibm29v02.xml"))
+
+(defun test-class (test)
+  (cond
+    ((not (and (let ((version (get-attribute test "RECOMMENDATION")))
+                 (cond
+                   ((or (equal version "") ;XXX
+                        (equal version "XML1.0")
+                        (equal version "NS1.0"))
+                     (cond
+                       ((equal (get-attribute test "NAMESPACE") "no")
+                         (format t "~A: test applies to parsers without namespace support, skipping~%"
+                                 (get-attribute test "URI"))
+                         nil)
+                       (t
+                         t)))
+                   ((equal version "XML1.1")
+                     ;; not supported
+                     nil)
+                   (t
+                     (warn "unrecognized RECOMMENDATION value: ~S" version)
+                     nil)))
+               (not (member (get-attribute test "ID") *bad-tests* :test 'equal))))
+      nil)
+    ((equal (get-attribute test "TYPE") "valid") :valid)
+    ((equal (get-attribute test "TYPE") "invalid") :invalid)
+    ((equal (get-attribute test "TYPE") "not-wf") :not-wf)
+    (t nil)))
+
+(defun test-pathnames (directory test)
+  (let* ((sub-directory
+          (loop
+              for parent = test then (dom:parent-node parent)
+              for base = (get-attribute parent "xml:base")
+              until (plusp (length base))
+              finally (return (merge-pathnames base directory))))
+         (uri (get-attribute test "URI"))
+         (output (get-attribute test "OUTPUT")))
+    (values (merge-pathnames uri sub-directory)
+            (when (plusp (length output))
+              (merge-pathnames output sub-directory)))))
+
+(defmethod serialize-document ((document t))
+  (dom:map-document (cxml:make-octet-vector-sink :canonical 2)
+		    document
+		    :include-doctype :canonical-notations
+		    :include-default-values t))
+
+(defun file-contents (pathname)
+  (with-open-file (s pathname :element-type '(unsigned-byte 8))
+    (let ((result
+           (make-array (file-length s) :element-type '(unsigned-byte 8))))
+      (read-sequence result s )
+      result)))
+
+(defun dribble-tests (parser-fn directory)
+  (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)))
+    (with-open-file (*standard-output*
+		     (merge-pathnames "XMLCONF" base)
+		     :direction :output
+		     :external-format :iso-8859-1
+		     :if-exists :supersede)
+      (run-all-tests parser-fn directory))))
+
+(defvar *parser-fn* 'sax-test)
+
+(defun sax-test (filename handler &rest args)
+  (apply #'cxml:parse-file filename handler :recode nil args))
+
+(defun klacks-test (filename handler &rest args)
+  (klacks:with-open-source
+      (s (apply #'cxml:make-source (pathname filename) args))
+    (klacks:serialize-source s handler)))
+
+(defun run-all-tests (parser-fn directory)
+  (let* ((*parser-fn* parser-fn)
+	 (pathname (merge-pathnames "xmlconf.xml" directory))
+         (builder (rune-dom:make-dom-builder))
+         (xmlconf (cxml:parse-file pathname builder :recode nil))
+         (ntried 0)
+         (nfailed 0)
+         (nskipped 0)
+         ;; XXX someone found it funny to include invalid URIs in the
+         ;; test suite.  And no, in "invalid" not "not-wf".
+         (puri:*strict-parse* nil))
+    (dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST"))
+      (let ((description
+             (apply #'concatenate
+		    'string
+		    (map 'list
+		      (lambda (child)
+			(if (dom:text-node-p child)
+			    (rod-string (dom:data child))
+			    ""))
+		      (dom:child-nodes test))))
+            (class (test-class test)))
+        (cond
+          (class
+            (incf ntried)
+            (multiple-value-bind (pathname output)
+                (test-pathnames directory test)
+              (princ (enough-namestring pathname directory))
+              (unless (probe-file pathname)
+                (error "file not found: ~A" pathname))
+              (with-simple-restart (skip-test "Skip this test")
+                (unless (run-test class pathname output description)
+                  (incf nfailed))
+                (fresh-line))))
+          (t
+            (incf nskipped)))))
+    (format t "~&~D/~D tests failed; ~D test~:P were skipped"
+            nfailed ntried nskipped)))
+
+(defmethod run-test :around (class pathname output description &rest args)
+  (declare (ignore class pathname output args))
+  (handler-case
+      (call-next-method)
+    (serious-condition (c)
+      (format t " FAILED:~%  ~A~%[~A]~%" c description)
+      nil)))
+
+(defmethod run-test ((class null) pathname output description &rest args)
+  (declare (ignore description))
+  (let ((document (apply *parser-fn*
+                         pathname
+                         (rune-dom:make-dom-builder)
+                         args)))
+    (cond
+      ((null output)
+        (format t " input"))
+      ((equalp (file-contents output) (serialize-document document))
+        (format t " input/output"))
+      (t
+        (let ((error-output (make-pathname :type "error" :defaults output)))
+          (with-open-file (s error-output
+                           :element-type '(unsigned-byte 8)
+                           :direction :output
+                           :if-exists :supersede)
+            (write-sequence (serialize-document document) s))
+          (error "well-formed, but output ~S not the expected ~S~%"
+                 error-output output))))
+    t))
+
+(defmethod run-test
+    ((class (eql :valid)) pathname output description &rest args)
+  (assert (null args))
+  (and (progn
+         (format t " [not validating:]")
+         (run-test nil pathname output description :validate nil))
+       (progn
+         (format t " [validating:]")
+         (run-test nil pathname output description :validate t))))
+
+(defmethod run-test
+    ((class (eql :invalid)) pathname output description &rest args)
+  (assert (null args))
+  (and (progn
+         (format t " [not validating:]")
+         (run-test nil pathname output description :validate nil))
+       (handler-case
+           (progn
+             (format t " [validating:]")
+             (funcall *parser-fn*
+		      pathname
+		      (rune-dom:make-dom-builder)
+		      :validate t)
+             (error "validity error not detected")
+             nil)
+         (cxml:validity-error ()
+           (format t " invalid")
+           t))))
+
+(defmethod run-test
+    ((class (eql :not-wf)) pathname output description &rest args)
+  (assert (null args))
+  (handler-case
+      (progn
+         (format t " [not validating:]")
+	(funcall *parser-fn*
+		 pathname
+		 (rune-dom:make-dom-builder)
+		 :validate nil)
+	(error "well-formedness violation not detected")
+      nil)
+    #+fixme-stp-test
+    (error ()
+      (format t " unexpected-error")
+      t)
+    (cxml:well-formedness-violation ()
+      (format t " not-wf")
+      t))
+  (handler-case
+      (progn
+	(format t " [validating:]")
+	(funcall *parser-fn*
+		 pathname
+		 (rune-dom:make-dom-builder)
+		 :validate t)
+	(error "well-formedness violation not detected")
+      nil)
+    #+fixme-stp-test
+    (error ()
+      (format t " unexpected-error")
+      t)
+    (cxml:well-formedness-violation ()
+      (format t " not-wf")
+      t)
+    (cxml:validity-error ()
+      ;; das erlauben wir mal auch, denn valide => wf
+      (format t " invalid")
+      t)))
+
+#+(or)
+(xmlconf::run-all-tests 'xmlconf::sax-test
+			"/home/david/2001/XML-Test-Suite/xmlconf/")
+
+#+(or)
+(xmlconf::run-all-tests 'xmlconf::klacks-test
+			"/home/david/2001/XML-Test-Suite/xmlconf/")

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/catalog.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/catalog.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,349 @@
+;;;; catalogs.lisp -- XML Catalogs  -*- Mode: Lisp; readtable: runes -*-
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Developed 2004 for headcraft - http://headcraft.de/
+;;;; Copyright: David Lichteblau
+
+(in-package :cxml)
+
+;;; http://www.oasis-open.org/committees/entity/spec.html
+;;;
+;;; Bugs:
+;;;   - We validate using the Catalog DTD while parsing, which is too strict
+;;;     and will will fail to parse files using other parser's extensions.
+;;;     (Jedenfalls behauptet das die Spec.)
+;;;     A long-term solution might be an XML Schema validator.
+
+(defvar *prefer* :public)
+(defvar *default-catalog*
+    '(;; libxml standard
+      "/etc/xml/catalog"
+      ;; FreeBSD
+      "/usr/local/share/xml/catalog.ports"))
+
+(defstruct (catalog (:constructor %make-catalog ()))
+  main-files
+  (dtd-cache (make-dtd-cache))
+  (file-table (puri:make-uri-space)))
+
+(defstruct (entry-file (:conc-name ""))
+  (system-entries)                      ;extid 2
+  (rewrite-system-entries)              ;      3
+  (delegate-system-entries)             ;      4
+  (public-entries)                      ;      5
+  (delegate-public-entries)             ;      6
+  (uri-entries)                         ;uri 2
+  (rewrite-uri-entries)                 ;    3
+  (delegate-uri-entries)                ;    4
+  (next-catalog-entries)                ;    5/7
+  )
+
+(defun starts-with-p (string prefix)
+  (let ((mismatch (mismatch string prefix)))
+    (or (null mismatch) (= mismatch (length prefix)))))
+
+(defun normalize-public (str)
+  (setf str (rod-to-utf8-string (rod str)))
+  (flet ((whitespacep (c)
+           (find c #.(map 'string #'code-char '(#x9 #xa #xd #x20)))))
+    (let ((start (position-if-not #'whitespacep str))
+          (end (position-if-not #'whitespacep str :from-end t))
+          (spacep nil))
+      (with-output-to-string (out)
+        (when start
+          (loop for i from start to end do
+                (let ((c (char str i)))
+                  (cond
+                    ((whitespacep c)
+                      (unless spacep
+                        (setf spacep t)
+                        (write-char #\space out)))
+                    (t
+                      (setf spacep nil)
+                      (write-char c out))))))))))
+
+(defun normalize-uri (str)
+  (when (typep str 'puri:uri)
+    (setf str (puri:render-uri str nil)))
+  (setf str (rod-to-utf8-string (rod str)))
+  (with-output-to-string (out)
+    (loop for ch across str do
+          (let ((c (char-code ch)))
+            (if (< c 15)
+                (write-string (string-upcase (format nil "%~2,'0X" c)) out)
+                (write-char ch out))))))
+
+(defun unwrap-publicid (str)
+  (normalize-public
+   (with-output-to-string (out)
+     (let ((i (length "urn:publicid:"))
+           (n (length str)))
+       (while (< i n)
+         (let ((c (char str i)))
+           (case c
+             (#\+ (write-char #\space out))
+             (#\: (write-string "//" out))
+             (#\; (write-string "::" out))
+             (#\%
+               (let ((code
+                      (parse-integer str
+                                     :start (+ i 1)
+                                     :end (+ i 3)
+                                     :radix 16)))
+                 (write-char (code-char code) out))
+               (incf i 2))
+             (t (write-char c out))))
+         (incf i))))))
+
+(defun match-exact (key table &optional check-prefer)
+  (dolist (pair table)
+    (destructuring-bind (from to &optional prefer) pair
+      (when (and (equal key from) (or (not check-prefer) (eq prefer :public)))
+        (return to)))))
+
+(defun match-prefix/rewrite (key table &optional check-prefer)
+  (let ((match nil)
+        (match-length -1))
+    (dolist (pair table)
+      (destructuring-bind (from to &optional prefer) pair
+        (when (and (or (not check-prefer) (eq prefer :public))
+                   (starts-with-p key from)
+                   (> (length from) match-length))
+          (setf match-length (length from))
+          (setf match to))))
+    (if match
+        (concatenate 'string
+          match
+          (subseq key match-length))
+        nil)))
+
+(defun match-prefix/sorted (key table &optional check-prefer)
+  (let ((result '()))
+    (dolist (pair table)
+      (destructuring-bind (from to &optional prefer) pair
+        (when (and (or (not check-prefer) (eq prefer :public))
+                   (starts-with-p key from))
+          (push (cons (length from) to) result))))
+    (mapcar #'cdr (sort result #'> :key #'car))))
+
+(defun resolve-extid (public system catalog)
+  (when public (setf public (normalize-public public)))
+  (when system (setf system (normalize-uri system)))
+  (when (and system (starts-with-p system "urn:publicid:"))
+    (let ((new-public (unwrap-publicid system)))
+      (assert (or (null public) (equal public new-public)))
+      (setf public new-public
+            system nil)))
+  (let ((files (catalog-main-files catalog))
+        (seen '()))
+    (while files
+      (let ((file (pop files))
+            (delegates nil))
+        (unless (typep file 'entry-file)
+          (setf file (find-catalog-file file catalog)))
+        (unless (or (null file) (member file seen))
+          (push file seen)
+          (when system
+            (let ((result
+                   (or (match-exact system (system-entries file))
+                       (match-prefix/rewrite
+                        system
+                        (rewrite-system-entries file)))))
+              (when result
+                (return result))
+              (setf delegates
+                    (match-prefix/sorted
+                     system
+                     (delegate-system-entries file)))))
+          (when (and public (not delegates))
+            (let* ((check-prefer (and system t))
+                   (result
+                    (match-exact public
+                                 (public-entries file)
+                                 check-prefer)))
+              (when result
+                (return result))
+              (setf delegates
+                    (match-prefix/sorted
+                     public
+                     (delegate-public-entries file)
+                     check-prefer))))
+          (if delegates
+              (setf files delegates)
+              (setf files (append (next-catalog-entries file) files))))))))
+
+(defun resolve-uri (uri catalog)
+  (setf uri (normalize-uri uri))
+  (when (starts-with-p uri "urn:publicid:")
+    (return-from resolve-uri
+      (resolve-extid (unwrap-publicid uri) nil catalog)))
+  (let ((files (catalog-main-files catalog))
+        (seen '()))
+    (while files
+      (let ((file (pop files)))
+        (unless (typep file 'entry-file)
+          (setf file (find-catalog-file file catalog)))
+        (unless (or (null file) (member file seen))
+          (push file seen)
+          (let ((result
+                 (or (match-exact uri (uri-entries file))
+                     (match-prefix/rewrite uri (rewrite-uri-entries file)))))
+            (when result
+              (return result))
+            (let* ((delegate-entries
+                    (delegate-uri-entries file))
+                   (delegates
+                    (match-prefix/sorted uri delegate-entries)))
+              (if delegates
+                  (setf files delegates)
+                  (setf files (append (next-catalog-entries file) files))))))))))
+
+(defun find-catalog-file (uri catalog)
+  (setf uri (if (stringp uri) (safe-parse-uri uri) uri))
+  (let* ((*dtd-cache* (catalog-dtd-cache catalog))
+         (*cache-all-dtds* t)
+         (file (parse-catalog-file uri)))
+    (when file
+      (let ((interned (puri:intern-uri uri (catalog-file-table catalog))))
+        (setf (getf (puri:uri-plist interned) 'catalog) file)))
+    file))
+
+(defun make-catalog (&optional (uris *default-catalog*))
+  (let ((result (%make-catalog)))
+    (setf (catalog-main-files result)
+          (loop
+              for uri in uris
+              for file = (find-catalog-file uri result)
+              when file collect file))
+    result))
+
+(defun parse-catalog-file (uri)
+  (handler-case
+      (parse-catalog-file/strict uri)
+    ((or file-error xml-parse-error) (c)
+      (warn "ignoring catalog error: ~A" c))))
+
+(defparameter *catalog-dtd*
+    (let* ((cxml
+            (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname))
+           (dtd (merge-pathnames "catalog.dtd" cxml)))
+      (with-open-file (s dtd :element-type '(unsigned-byte 8))
+        (let ((bytes
+               (make-array (file-length s) :element-type '(unsigned-byte 8))))
+          (read-sequence bytes s)
+          bytes))))
+
+(defun parse-catalog-file/strict (uri)
+  (let* ((*catalog* nil)
+         (dtd-sysid
+          (puri:parse-uri "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd")))
+    (flet ((entity-resolver (public system)
+             (declare (ignore public))
+             (if (puri:uri= system dtd-sysid)
+                 (make-octet-input-stream *catalog-dtd*)
+                 nil)))
+      (with-open-stream (s (open (uri-to-pathname uri)
+                                 :element-type '(unsigned-byte 8)
+                                 :direction :input))
+        (parse-stream s
+                      (make-instance 'catalog-parser :uri uri)
+                      :validate nil
+                      :dtd (make-extid nil dtd-sysid)
+                      :root #"catalog"
+                      :entity-resolver #'entity-resolver)))))
+
+(defclass catalog-parser ()
+  ((result :initform (make-entry-file) :accessor result)
+   (next :initform '() :accessor next)
+   (prefer-stack :initform (list *prefer*) :accessor prefer-stack)
+   (catalog-base-stack :accessor catalog-base-stack)))
+
+(defmethod initialize-instance :after
+    ((instance catalog-parser) &key uri)
+  (setf (catalog-base-stack instance) (list uri)))
+
+(defmethod prefer ((handler catalog-parser))
+  (car (prefer-stack handler)))
+
+(defmethod base ((handler catalog-parser))
+  (car (catalog-base-stack handler)))
+
+(defun get-attribute/lname (name attributes)
+  (let ((a (find name attributes
+                 :key (lambda (a)
+                        (or (sax:attribute-local-name a)
+                            (sax:attribute-qname a)))
+                 :test #'string=)))
+    (and a (sax:attribute-value a))))
+
+(defmethod sax:start-element ((handler catalog-parser) uri lname qname attrs)
+  (declare (ignore uri))
+  (setf lname (or lname qname))
+  ;; we can dispatch on lnames only because we validate against the DTD,
+  ;; which disallows other namespaces.
+  ;; FIXME: we don't, because we can't.
+  (push (let ((new (get-attribute/lname "prefer" attrs)))
+          (cond
+            ((equal new "public") :public)
+            ((equal new "system") :system)
+            ((null new) (prefer handler))))
+        (prefer-stack handler))
+  (push (string-or (get-attribute/lname "base" attrs) (base handler))
+        (catalog-base-stack handler))
+  (flet ((geturi (lname)
+           (puri:merge-uris
+            (safe-parse-uri (get-attribute/lname lname attrs))
+            (base handler))))
+    (cond
+      ((string= lname "public")
+        (push (list (normalize-public (get-attribute/lname "publicId" attrs))
+                    (geturi "uri")
+                    (prefer handler))
+              (public-entries (result handler))))
+      ((string= lname "system")
+        (push (list (normalize-uri (get-attribute/lname "systemId" attrs))
+                    (geturi "uri"))
+              (system-entries (result handler))))
+      ((string= lname "uri")
+        (push (list (normalize-uri (get-attribute/lname "name" attrs))
+                    (geturi "uri"))
+              (uri-entries (result handler))))
+      ((string= lname "rewriteSystem")
+        (push (list (normalize-uri
+                     (get-attribute/lname "systemIdStartString" attrs))
+                    (get-attribute/lname "rewritePrefix" attrs))
+              (rewrite-system-entries (result handler))))
+      ((string= lname "rewriteURI")
+        (push (list (normalize-uri
+                     (get-attribute/lname "uriStartString" attrs))
+                    (get-attribute/lname "rewritePrefix" attrs))
+              (rewrite-uri-entries (result handler))))
+      ((string= lname "delegatePublic")
+        (push (list (normalize-public
+                     (get-attribute/lname "publicIdStartString" attrs))
+                    (geturi "catalog")
+                    (prefer handler))
+              (delegate-public-entries (result handler))))
+      ((string= lname "delegateSystem")
+        (push (list (normalize-uri
+                     (get-attribute/lname "systemIdStartString" attrs))
+                    (geturi "catalog"))
+              (delegate-system-entries (result handler))))
+      ((string= lname "delegateURI")
+        (push (list (normalize-uri
+                     (get-attribute/lname "uriStartString" attrs))
+                    (geturi "catalog"))
+              (delegate-uri-entries (result handler))))
+      ((string= lname "nextCatalog")
+        (push (geturi "catalog")
+              (next-catalog-entries (result handler)))))))
+
+(defmethod sax:end-element ((handler catalog-parser) uri lname qname)
+  (declare (ignore uri lname qname))
+  (pop (catalog-base-stack handler))
+  (pop (prefer-stack handler)))
+
+(defmethod sax:end-document ((handler catalog-parser))
+  (result handler))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/package.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,99 @@
+;;;; package.lisp -- Paketdefinition
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+
+(in-package :cl-user)
+
+(defpackage :cxml
+  (:use :cl :runes :runes-encoding #-scl :trivial-gray-streams)
+  (:export
+   ;; xstreams
+   #:make-xstream
+   #:make-rod-xstream
+   #:close-xstream
+   #:read-rune
+   #:peek-rune
+   #:unread-rune
+   #:fread-rune
+   #:fpeek-rune
+   #:xstream-position
+   #:xstream-line-number
+   #:xstream-column-number
+   #:xstream-plist
+   #:xstream-encoding
+   
+   ;; xstream controller protocol
+   #:read-octects
+   #:xstream/close
+
+   #:attribute-namespace-uri
+   #:attribute-local-name
+   #:attribute-qname
+   #:attribute-value
+   
+   #:parse
+   #:parse-file
+   #:parse-stream
+   #:parse-rod
+   #:parse-octets
+   #:parse-empty-document
+
+   #:make-octet-vector-sink
+   #:make-octet-stream-sink
+   #:make-rod-sink
+   #+rune-is-character #:make-string-sink
+   #+rune-is-character #:make-character-stream-sink
+   ;; See comment in runes/package.lisp
+   ;; #-rune-is-character
+   #:make-string-sink/utf8
+   ;; #-rune-is-character
+   #:make-character-stream-sink/utf8
+
+   #:with-xml-output
+   #:with-output-sink
+   #:with-namespace
+   #:with-element
+   #:with-element*
+   #:attribute
+   #:attribute*
+   #:unparse-attribute
+   #:cdata
+   #:text
+   #:doctype
+
+   #:xml-parse-error
+   #:well-formedness-violation
+   #:validity-error
+
+   #:parse-dtd-file
+   #:parse-dtd-stream
+   #:make-validator
+
+   #:*cache-all-dtds*
+   #:*dtd-cache*
+   #:getdtd
+   #:remdtd
+   #:make-dtd-cache
+   #:clear-dtd-cache
+   #:make-extid
+
+   #:*catalog*
+   #:*prefer*
+   #:make-catalog
+   #:resolve-uri
+   #:resolve-extid
+   
+   #:make-recoder
+   #:make-namespace-normalizer
+   #:make-whitespace-normalizer
+   #:rod-to-utf8-string
+   #:utf8-string-to-rod
+
+   #:broadcast-handler
+   #:broadcast-handler-handlers
+   #:make-broadcast-handler
+   #:sax-proxy
+   #:proxy-chained-handler
+
+   #:make-source))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/recoder.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/recoder.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,125 @@
+;;;; recoder.lisp -- SAX handler for string conversion
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Developed 2004 for headcraft - http://headcraft.de/
+;;;; Copyright: David Lichteblau
+
+(in-package :cxml)
+
+(defclass recoder ()
+    ((recoder :initarg :recoder :accessor recoder)
+     (chained-handler :initarg :chained-handler :accessor chained-handler)))
+
+(defun make-recoder (chained-handler recoder-fn)
+  (make-instance 'recoder
+    :recoder recoder-fn
+    :chained-handler chained-handler))
+
+(macrolet ((%string (rod)
+             `(let ((rod ,rod))
+                (if (typep rod '(or rod string))
+                    (funcall (recoder handler) rod)
+                    rod)))
+           (defwrapper (name (&rest args) &rest forms)
+             `(defmethod ,name ((handler recoder) , at args)
+                (,name (chained-handler handler) , at forms))))
+  (defwrapper sax:start-document ())
+
+  (defwrapper sax:start-element
+      (namespace-uri local-name qname attributes)
+    (%string namespace-uri)
+    (%string local-name)
+    (%string qname)
+    (mapcar (lambda (attr)
+              (sax:make-attribute
+               :namespace-uri (%string (sax:attribute-namespace-uri attr))
+               :local-name (%string (sax:attribute-local-name attr))
+               :qname (%string (sax:attribute-qname attr))
+               :value (%string (sax:attribute-value attr))
+               :specified-p (sax:attribute-specified-p attr)))
+            attributes))
+
+  (defwrapper sax:start-prefix-mapping (prefix uri)
+    (%string prefix)
+    (%string uri))
+
+  (defwrapper sax:characters (data)
+    (%string data))
+
+  (defwrapper sax:processing-instruction (target data)
+    (%string target)
+    (%string data))
+
+  (defwrapper sax:end-prefix-mapping (prefix)
+    (%string prefix))
+
+  (defwrapper sax:end-element (namespace-uri local-name qname)
+    (%string namespace-uri)
+    (%string local-name)
+    (%string qname))
+
+  (defwrapper sax:end-document ())
+
+  (defwrapper sax:comment (data)
+    (%string data))
+
+  (defwrapper sax:start-cdata ())
+
+  (defwrapper sax:end-cdata ())
+
+  (defwrapper sax:start-dtd (name public-id system-id)
+    (%string name)
+    (%string public-id)
+    (%string system-id))
+
+  (defwrapper sax:start-internal-subset ())
+  (defwrapper sax:end-internal-subset ())
+
+  (defwrapper sax:end-dtd ())
+
+  (defwrapper sax:unparsed-entity-declaration
+      (name public-id system-id notation-name)
+    (%string name)
+    (%string public-id)
+    (%string system-id)
+    (%string notation-name))
+
+  (defwrapper sax:external-entity-declaration
+      (kind name public-id system-id)
+    (%string kind)
+    (%string name)
+    (%string public-id)
+    (%string system-id))
+
+  (defwrapper sax:internal-entity-declaration
+      (kind name value)
+    kind
+    (%string name)
+    (%string value))
+
+  (defwrapper sax:notation-declaration
+      (name public-id system-id)
+    (%string name)
+    (%string public-id)
+    (%string system-id))
+
+  (defwrapper sax:element-declaration (name model)
+    (%string name)
+    model)
+
+  (defwrapper sax:attribute-declaration
+      (element-name attribute-name type default)
+    (%string element-name)
+    (%string attribute-name)
+    (%string type)
+    (%string default))
+
+  (defwrapper sax:entity-resolver
+      (resolver)
+    resolver)
+
+  (defwrapper sax::dtd
+      (dtd)
+    dtd))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-handler.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-handler.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,613 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SAX; readtable: runes; Encoding: utf-8; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: A SAX2-like API for the xml parser
+;;;   Created: 2003-06-30
+;;;    Author: Henrik Motakef <hmot at henrik-motakef.de>
+;;;    Author: David Lichteblau
+;;;   License: BSD
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2003 by Henrik Motakef
+;;;  (c) copyright 2004 knowledgeTools Int. GmbH
+;;;  (c) copyright 2005-2007 David Lichteblau
+
+;;; Redistribution and use  in source and binary   forms, with or  without
+;;; modification, are permitted provided that the following conditions are
+;;; met:                                                                  
+;;; 								      
+;;; 1. Redistributions  of  source  code  must retain  the above copyright
+;;;    notice, this list of conditions and the following disclaimer.      
+;;; 								      
+;;; 2. Redistributions in  binary form must reproduce  the above copyright
+;;;    notice, this list of conditions and the following disclaimer in the
+;;;    documentation and/or other materials provided with the distribution
+;;; 								      
+;;; THIS  SOFTWARE   IS PROVIDED ``AS  IS''   AND ANY  EXPRESS  OR IMPLIED
+;;; WARRANTIES, INCLUDING, BUT NOT LIMITED  TO, THE IMPLIED WARRANTIES  OF
+;;; MERCHANTABILITY  AND FITNESS FOR A  PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;;; INDIRECT,  INCIDENTAL,  SPECIAL, EXEMPLARY,  OR CONSEQUENTIAL  DAMAGES
+;;; (INCLUDING, BUT NOT LIMITED TO,   PROCUREMENT OF SUBSTITUTE GOODS   OR
+;;; SERVICES;  LOSS OF  USE,  DATA, OR  PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER  CAUSED AND ON ANY THEORY  OF LIABILITY,  WHETHER IN CONTRACT,
+;;; STRICT LIABILITY, OR  TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+;;; IN ANY WAY  OUT OF THE  USE OF THIS SOFTWARE,  EVEN IF ADVISED OF  THE
+;;; POSSIBILITY OF SUCH DAMAGE.
+
+;;; TODO/ Open Questions:
+
+;; o Missing stuff from Java SAX2:
+;;   * ignorable-whitespace
+;;   * skipped-entity
+;;   * The whole ErrorHandler class, this is better handled using
+;;     conditions (but isn't yet)
+
+(defpackage :sax
+  (:use :common-lisp)
+  (:export #:*namespace-processing*
+	   #:*include-xmlns-attributes*
+	   #:*use-xmlns-namespace*
+
+	   #:abstract-handler
+	   #:content-handler
+	   #:default-handler
+
+           #:make-attribute
+           #:find-attribute
+           #:find-attribute-ns
+           #:attribute-namespace-uri
+           #:attribute-local-name
+           #:attribute-qname
+           #:attribute-value
+           #:attribute-specified-p
+	   
+	   #:start-document
+	   #:start-prefix-mapping
+	   #:start-element
+	   #:characters
+	   #:processing-instruction
+	   #:end-element
+	   #:end-prefix-mapping
+	   #:end-document
+	   #:comment
+	   #:start-cdata
+	   #:end-cdata
+	   #:start-dtd
+	   #:end-dtd
+	   #:start-internal-subset
+	   #:unparsed-internal-subset
+	   #:end-internal-subset
+           #:unparsed-entity-declaration
+           #:external-entity-declaration
+           #:internal-entity-declaration
+           #:notation-declaration
+           #:element-declaration
+           #:attribute-declaration
+           #:entity-resolver
+
+	   #:sax-parser
+	   #:sax-parser-mixin
+	   #:register-sax-parser
+	   #:line-number
+	   #:column-number
+	   #:system-id
+	   #:xml-base))
+
+(in-package :sax)
+
+
+;;;; SAX-PARSER interface 
+
+(defclass sax-parser () ())
+
+(defclass sax-parser-mixin ()		;deprecated
+    ((sax-parser :initform nil :reader sax-parser)))
+
+(defgeneric line-number (sax-parser)
+  (:documentation
+   "Return an approximation of the current line number, or NIL.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(line-number (sax-parser handler))
+	nil)))
+
+(defgeneric column-number (sax-parser)
+  (:documentation
+   "Return an approximation of the current column number, or NIL.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(column-number (sax-parser handler))
+	nil)))
+
+(defgeneric system-id (sax-parser)
+  (:documentation
+   "Return the URI of the document being parsed.  This is either the
+    main document, or the entity's system ID while contents of a parsed
+    general external entity are being processed.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(system-id (sax-parser handler))
+	nil)))
+
+(defgeneric xml-base (sax-parser)
+  (:documentation
+   "Return the [Base URI] of the current element.  This URI can differ from
+   the value returned by SAX:SYSTEM-ID if xml:base attributes are present.")
+  (:method ((handler sax-parser-mixin))
+    (if (sax-parser handler)
+	(xml-base (sax-parser handler))
+	nil)))
+
+
+;;;; Configuration variables
+
+;; The http://xml.org/sax/features/namespaces property
+(defvar *namespace-processing* t
+  "If non-nil (the default), namespace processing is enabled.
+
+See also `start-element' and `end-element' for a detailed description
+of the consequences of modifying this variable, and
+`*include-xmlns-attributes*' and `*use-xmlns-namespace*' for further
+related options.")
+
+;; The http://xml.org/sax/features/namespace-prefixes property.
+(defvar *include-xmlns-attributes* t
+  "If non-nil, namespace declarations are reported as normal
+attributes.
+
+This variable has no effect unless `*namespace-processing*' is
+non-nil.
+
+See also `*use-xmlns-namespace*', and `start-element' for a detailed
+description of the consequences of setting this variable.")
+
+(defvar *use-xmlns-namespace* t
+  "If this variable is nil (the default), attributes with a name like
+'xmlns:x' are not considered to be in a namespace, following the
+'Namespaces in XML' specification.
+
+If it is non-nil, such attributes are considered to be in a namespace
+with the URI 'http://www.w3.org/2000/xmlns/', following an
+incompatible change silently introduced in the errata to that spec,
+and adopted by some W3C standards.
+
+For example, an attribute like xmlns:ex='http://example.com' would be
+reported like this:
+
+*use-xmlns-namespace*: nil
+namespace-uri:         nil
+local-name:            nil
+qname:                 #\"xmlns:ex\"
+
+*use-xmlns-namespace*: t
+namespace-uri:         #\"http://www.w3.org/2000/xmlns/\"
+local-name:            #\"ex\"
+qname:                 #\"xmlns:ex\"
+
+Setting this variable has no effect unless both
+`*namespace-processing*' and `*include-xmlns-attributes*' are non-nil.")
+
+
+;;;; ATTRIBUTE
+
+(defstruct (standard-attribute (:constructor make-attribute))
+  namespace-uri
+  local-name
+  qname
+  value
+  specified-p)
+
+(defmethod (setf attribute-namespace-uri)
+    (newval (attribute standard-attribute))
+  (setf (standard-attribute-namespace-uri attribute) newval))
+
+(defmethod (setf attribute-local-name)
+    (newval (attribute standard-attribute))
+  (setf (standard-attribute-local-name attribute) newval))
+
+(defmethod (setf attribute-qname)
+    (newval (attribute standard-attribute))
+  (setf (standard-attribute-qname attribute) newval))
+
+(defmethod (setf attribute-value)
+    (newval (attribute standard-attribute))
+  (setf (standard-attribute-value attribute) newval))
+
+(defmethod (setf attribute-specified-p)
+    (newval (attribute standard-attribute))
+  (setf (standard-attribute-specified-p attribute) newval))
+
+(defgeneric attribute-namespace-uri (attribute)
+  (:method ((attribute standard-attribute))
+    (standard-attribute-namespace-uri attribute))
+  (:method ((attribute hax:standard-attribute))
+    ""))
+
+(defgeneric attribute-local-name (attribute)
+  (:method ((attribute standard-attribute))
+    (standard-attribute-local-name attribute))
+  (:method ((attribute hax:standard-attribute))
+    (runes:rod-downcase (hax:attribute-name attribute))))
+
+(defgeneric attribute-qname (attribute)
+  (:method ((attribute standard-attribute))
+    (standard-attribute-qname attribute))
+  (:method ((attribute hax:standard-attribute))
+    (runes:rod-downcase (hax:attribute-name attribute))))
+
+(defgeneric attribute-value (attribute)
+  (:method ((attribute standard-attribute))
+    (standard-attribute-value attribute))
+  (:method ((attribute hax:standard-attribute))
+    (hax:attribute-value attribute)))
+
+(defgeneric attribute-specified-p (attribute)
+  (:method ((attribute standard-attribute))
+    (standard-attribute-specified-p attribute))
+  (:method ((attribute hax:standard-attribute))
+    (hax:attribute-specified-p attribute)))
+
+(defmethod hax:attribute-name ((attribute standard-attribute))
+  (attribute-local-name attribute))
+
+(defmethod hax:attribute-value ((attribute standard-attribute))
+  (attribute-value attribute))
+
+(defmethod hax:attribute-specified-p ((attribute standard-attribute))
+  (attribute-specified-p attribute))
+
+(defun %rod= (x y)
+  ;; allow rods *and* strings *and* null
+  (cond
+    ((zerop (length x)) (zerop (length y)))
+    ((zerop (length y)) nil)
+    ((stringp x) (string= x y))
+    (t (runes:rod= x y))))
+
+(defun find-attribute (qname attrs)
+  (find qname attrs :key #'attribute-qname :test #'%rod=))
+
+(defun find-attribute-ns (uri lname attrs)
+  (find-if (lambda (attr)
+	     (and (%rod= uri (sax:attribute-namespace-uri attr))
+		  (%rod= lname (sax:attribute-local-name attr))))
+	   attrs))
+
+
+;;;; ABSTRACT-HANDLER and DEFAULT-HANDLER
+
+(defclass abstract-handler (sax-parser-mixin) ())
+(defclass content-handler (abstract-handler) ())
+(defclass default-handler (content-handler) ())
+
+
+;;;; EVENTS
+
+(macrolet ((define-event ((name default-handler-class)
+			  (&rest args)
+			  &body hax-body)
+	     `(defgeneric ,name (handler , at args)
+		(:method ((handler null) , at args)
+		  (declare (ignore , at args))
+		  nil)
+		(:method ((handler t) , at args)
+		  (declare (ignore , at args))
+		  (warn "deprecated SAX default method used by a handler ~
+                         that is not a subclass of SAX:ABSTRACT-HANDLER ~
+                         or HAX:ABSTRACT-HANDLER")
+		  nil)
+		(:method ((handler abstract-handler) , at args)
+		  (declare (ignore , at args))
+		  (error "SAX event ~A not implemented by this handler"
+			 ',name))
+		(:method ((handler ,default-handler-class) , at args)
+		  (declare (ignore , at args))
+		  nil)
+		(:method ((handler hax:abstract-handler) , at args)
+		  (declare (ignorable , at args))
+		  , at hax-body))))
+  (define-event (start-document default-handler)
+      ()
+    nil)
+
+  (define-event (start-element default-handler)
+      (namespace-uri local-name qname attributes)
+    (setf attributes
+	  (remove "http://www.w3.org/2000/xmlns/"
+		  attributes
+		  :key #'attribute-namespace-uri
+		  :test #'equal))
+    (hax:start-element handler local-name attributes))
+
+  (define-event (start-prefix-mapping content-handler)
+      (prefix uri)
+    nil)
+
+  (define-event (characters default-handler)
+      (data)
+    (hax:characters handler data))
+
+  (define-event (processing-instruction default-handler)
+      (target data)
+    nil)
+
+  (define-event (end-prefix-mapping content-handler)
+      (prefix)
+    nil)
+
+  (define-event (end-element default-handler)
+      (namespace-uri local-name qname)
+    (hax:end-element handler local-name))
+
+  (define-event (end-document default-handler)
+      ()
+    (hax:end-document handler))
+
+  (define-event (comment content-handler)
+      (data)
+    (hax:comment handler data))
+
+  (define-event (start-cdata content-handler)
+      ()
+    nil)
+
+  (define-event (end-cdata content-handler)
+      ()
+    nil)
+
+  (define-event (start-dtd content-handler)
+      (name public-id system-id)
+    (hax:start-document handler name public-id system-id))
+
+  (define-event (end-dtd content-handler)
+      ()
+    nil)
+
+  (define-event (start-internal-subset content-handler)
+      ()
+    nil)
+
+  (define-event (end-internal-subset content-handler)
+      ()
+    nil)
+
+  (define-event (unparsed-internal-subset content-handler)
+      (str)
+    nil)
+
+  (define-event (unparsed-entity-declaration content-handler)
+      (name public-id system-id notation-name)
+    nil)
+
+  (define-event (external-entity-declaration content-handler)
+      (kind name public-id system-id)
+    nil)
+
+  (define-event (internal-entity-declaration content-handler)
+      (kind name value)
+    nil)
+
+  (define-event (notation-declaration content-handler)
+      (name public-id system-id)
+    nil)
+
+  (define-event (element-declaration content-handler)
+      (name model)
+    nil)
+
+  (define-event (attribute-declaration content-handler)
+      (element-name attribute-name type default)
+    nil)
+
+  (define-event (entity-resolver content-handler)
+      (resolver)
+    nil)
+
+  (define-event (dtd content-handler)
+      (dtd)
+    nil))
+
+;;; special case: this method is defined on abstract-handler through
+;;; sax-parser-mixin
+(defgeneric register-sax-parser (handler sax-parser)
+  (:method ((handler null) sax-parser)
+    (declare (ignore sax-parser))
+    nil)
+  (:method ((handler sax-parser-mixin) sax-parser)
+    (setf (slot-value handler 'sax-parser) sax-parser))
+  (:method ((handler t) sax-parser)
+    (declare (ignore sax-parser))
+    (warn "deprecated sax default method used by a handler ~
+                          that is not a subclass of sax:abstract-handler ~
+                          or hax:abstract-handler")
+    nil)
+  (:method ((handler hax:abstract-handler) sax-parser)
+    (declare (ignorable sax-parser)) nil))
+
+
+;;;; HAX to SAX
+
+(defmethod hax:start-document ((handler abstract-handler) name pubid sysid)
+  (sax:start-document handler)
+  (when sysid
+    (sax:start-dtd handler name pubid sysid)
+    (sax:end-dtd handler)))
+
+(defmethod hax:start-element ((handler abstract-handler) name attributes)
+  (setf name (runes:rod-downcase name))
+  (when (equal name "html")
+    (sax:start-prefix-mapping handler "" "http://www.w3.org/1999/xhtml")
+    (when *include-xmlns-attributes*
+      (push (make-attribute :namespace-uri "http://www.w3.org/2000/xmlns/"
+			    :local-name nil
+			    :qname "xmlns"
+			    :value "http://www.w3.org/1999/xhtml"
+			    :specified-p t)
+	    attributes)))
+  (sax:start-element handler
+		     "http://www.w3.org/1999/xhtml"
+		     name
+		     name
+		     attributes))
+
+(defmethod hax:end-element ((handler abstract-handler) name)
+  (setf name (runes:rod-downcase name))
+  (sax:end-element handler
+		   "http://www.w3.org/1999/xhtml"
+		   name
+		   name)
+  (when (equal name "html")
+    (sax:end-prefix-mapping handler "")))
+
+(defmethod hax:characters ((handler abstract-handler) data)
+  (sax:characters handler data))
+
+(defmethod hax:comment ((handler abstract-handler) str)
+  (sax:comment handler str))
+
+(defmethod hax:end-document ((handler abstract-handler))
+  (sax:end-document handler))
+
+
+
+;;;; Documentation
+
+(setf (documentation 'start-document 'function)
+      "Called at the beginning of the parsing process,
+before any element, processing instruction or comment is reported.
+
+Handlers that need to maintain internal state may use this to perform
+any neccessary initializations.")
+
+(setf (documentation 'start-element 'function)
+      "Called to report the beginning of an element.
+
+There will always be a corresponding call to end-element, even in the
+case of an empty element (i.e. <foo/>).
+
+If the value of *namespaces* is non-nil, namespace-uri, local-name and
+qname are rods. If it is nil, namespace-uri and local-name are always
+nil, and it is not an error if the qname is not a well-formed
+qualified element name (for example, if it contains more than one
+colon).
+
+The attributes parameter is a list (in arbitrary order) of instances
+of the `attribute' structure class. The for their namespace-uri and
+local-name properties, the same rules as for the element name
+apply. Additionally, namespace-declaring attributes (those whose name
+is \"xmlns\" or starts with \"xmlns:\") are only included if
+*include-xmlns-attributes* is non-nil.")
+
+(setf (documentation 'start-prefix-mapping 'function)
+      "Called when the scope of a new prefix -> namespace-uri mapping begins.
+
+This will always be called immediatly before the `start-element' event
+for the element on which the namespaces are declared.
+
+Clients don't usually have to implement this except under special
+circumstances, for example when they have to deal with qualified names
+in textual content. The parser will handle namespaces of elements and
+attributes on its own.")
+
+(setf (documentation 'characters 'function)
+      "Called for textual element content.
+
+The data is passed as a rod, with all entity references resolved.
+It is possible that the character content of an element is reported
+via multiple subsequent calls to this generic function.")
+
+(setf (documentation 'processing-instruction 'function)
+      "Called when a processing instruction is read.
+
+Both target and data are rods.")
+
+(setf (documentation 'end-prefix-mapping 'function)
+      "Called when a prefix -> namespace-uri mapping goes out of scope.
+
+This will always be called immediatly after the `end-element' event
+for the element on which the namespace is declared. The order of the
+end-prefix-mapping events is otherwise not guaranteed.
+
+Clients don't usually have to implement this except under special
+circumstances, for example when they have to deal with qualified names
+in textual content. The parser will handle namespaces of elements and
+attributes on its own.")
+
+(setf (documentation 'end-element 'function)
+      "Called to report the end of an element.
+
+See the documentation for `start-element' for a description of the
+parameters.")
+
+(setf (documentation 'end-document 'function)
+      "Called at the end of parsing a document.
+This is always the last function called in the parsing process.
+
+In contrast to all of the other methods, the return value of this gf
+is significant, it will be returned by the parse-file/stream/string function.")
+
+(setf (documentation 'start-cdata 'function)
+      "Called at the beginning of parsing a CDATA section.
+
+Handlers only have to implement this if they are interested in the
+lexical structure of the parsed document. The content of the CDATA
+section is reported via the `characters' generic function like all
+other textual content.")
+
+(setf (documentation 'end-cdata 'function)
+      "Called at the end of parsing a CDATA section.
+
+Handlers only have to implement this if they are interested in the
+lexical structure of the parsed document. The content of the CDATA
+section is reported via the `characters' generic function like all
+other textual content.")
+
+(setf (documentation 'start-dtd 'function)
+      "Called at the beginning of parsing a DTD.")
+
+(setf (documentation 'end-dtd 'function)
+      "Called at the end of parsing a DTD.")
+
+(setf (documentation 'start-internal-subset 'function)
+      "Reports that an internal subset is present.  Called before
+any definition from the internal subset is reported.")
+
+(setf (documentation 'end-internal-subset 'function)
+      "Called after processing of the internal subset has
+finished, if present.")
+
+(setf (documentation 'unparsed-internal-subset 'function)
+      "Reports that an internal subset is present, but has not
+been parsed and is available as a string.")
+
+(setf (documentation 'unparsed-entity-declaration 'function)
+      "Called when an unparsed entity declaration is seen in a DTD.")
+
+(setf (documentation 'external-entity-declaration 'function)
+      "Called when a parsed external entity declaration is seen in a DTD.")
+
+(setf (documentation 'internal-entity-declaration 'function)
+      "Called when an internal entity declaration is seen in a DTD.")
+
+(setf (documentation 'notation-declaration 'function)
+      "Called when a notation declaration is seen while parsing a DTD.")
+
+(setf (documentation 'element-declaration 'function)
+      "Called when a element declaration is seen in a DTD.  Model is not a string,
+    but a nested list, with *, ?, +, OR, and AND being the operators, rods
+    as names, :EMPTY and :PCDATA as special tokens.  (AND represents
+    sequences.)")
+
+(setf (documentation 'attribute-declaration 'function)
+      "Called when an attribute declaration is seen in a DTD.
+    type        one of :CDATA, :ID, :IDREF, :IDREFS,
+                :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS,
+                (:NOTATION <name>*), or (:ENUMERATION <name>*)
+    default     :REQUIRED, :IMPLIED, (:FIXED content), or (:DEFAULT content)")
+
+(setf (documentation 'entity-resolver 'function)
+      "Called between sax:end-dtd and sax:end-document to register an entity
+    resolver, a function of two arguments: An entity name and SAX handler.
+    When called, the resolver function will parse the named entity's data.")
+
+(setf (documentation 'register-sax-parser 'function)
+      "Set the SAX-PARSER instance of this handler.")

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-proxy.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-proxy.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,68 @@
+;;;; sax-proxy.lisp
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Copyright (c) 2004 David Lichteblau
+;;;; Author: David Lichteblau
+
+(in-package :cxml)
+
+(defclass broadcast-handler (sax:abstract-handler)
+  ((handlers :initform nil
+	     :initarg :handlers
+	     :accessor broadcast-handler-handlers)))
+
+(defun make-broadcast-handler (&rest handlers)
+  (make-instance 'broadcast-handler :handlers handlers))
+
+(defclass sax-proxy (broadcast-handler)
+  ())
+
+(defmethod initialize-instance
+    :after ((instance sax-proxy) &key chained-handler)
+  (setf (proxy-chained-handler instance) chained-handler))
+
+(defmethod proxy-chained-handler ((instance sax-proxy))
+  (car (broadcast-handler-handlers instance)))
+
+(defmethod (setf proxy-chained-handler) (newval (instance sax-proxy))
+  (setf (broadcast-handler-handlers instance) (list newval)))
+
+#-rune-is-character
+(defmethod hax:%want-strings-p ((handler broadcast-handler))
+  (hax:%want-strings-p (car (broadcast-handler-handlers instance))))
+
+(macrolet ((define-proxy-method (name (&rest args))
+             `(defmethod ,name ((handler broadcast-handler) , at args)
+                (let (result)
+		  (dolist (next (broadcast-handler-handlers handler))
+		    (setf result (,name next , at args)))
+		  result))))
+  (define-proxy-method sax:start-document ())
+  (define-proxy-method sax:start-element (uri lname qname attributes))
+  (define-proxy-method sax:start-prefix-mapping (prefix uri))
+  (define-proxy-method sax:characters (data))
+  (define-proxy-method sax:processing-instruction (target data))
+  (define-proxy-method sax:end-prefix-mapping (prefix))
+  (define-proxy-method sax:end-element (namespace-uri local-name qname))
+  (define-proxy-method sax:end-document ())
+  (define-proxy-method sax:comment (data))
+  (define-proxy-method sax:start-cdata ())
+  (define-proxy-method sax:end-cdata ())
+  (define-proxy-method sax:start-dtd (name public-id system-id))
+  (define-proxy-method sax:end-dtd ())
+  (define-proxy-method sax:start-internal-subset ())
+  (define-proxy-method sax:end-internal-subset ())
+  (define-proxy-method sax:unparsed-entity-declaration (name pub sys not))
+  (define-proxy-method sax:external-entity-declaration (kind name pub sys))
+  (define-proxy-method sax:internal-entity-declaration (kind name value))
+  (define-proxy-method sax:notation-declaration (name public-id system-id))
+  (define-proxy-method sax:element-declaration (name model))
+  (define-proxy-method sax:attribute-declaration (elt attr type default))
+  (define-proxy-method sax:entity-resolver (resolver))
+  (define-proxy-method sax::dtd (dtd)))
+
+(defmethod sax:register-sax-parser :after ((handler broadcast-handler) parser)
+  (dolist (next (broadcast-handler-handlers handler))
+    (sax:register-sax-parser next parser)))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/event-collecting-handler.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/event-collecting-handler.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,37 @@
+(in-package :sax-tests)
+
+(defclass event-collecting-handler ()
+  ((event-list :initform '() :accessor event-list)))
+
+(defmethod start-document ((handler event-collecting-handler))
+  (push (list :start-document) (event-list handler)))
+
+(defmethod start-element ((handler event-collecting-handler) ns-uri local-name qname attrs)
+  (push (list :start-element ns-uri local-name qname attrs)
+	(event-list handler)))
+
+(defmethod start-prefix-mapping ((handler event-collecting-handler) prefix uri)
+  (push (list :start-prefix-mapping prefix uri)
+	(event-list handler)))
+
+(defmethod characters ((handler event-collecting-handler) data)
+  (push (list :characters data)
+	(event-list handler)))
+
+(defmethod processing-instruction ((handler event-collecting-handler) target data)
+  (push (list :processing-instruction target data)
+	(event-list handler)))
+
+(defmethod end-prefix-mapping ((handler event-collecting-handler) prefix)
+  (push (list :end-prefix-mapping prefix)
+	(event-list handler)))
+
+(defmethod end-element ((handler event-collecting-handler) namespace-uri local-name qname)
+  (push (list :end-element namespace-uri local-name qname)
+	(event-list handler)))
+
+(defmethod end-document ((handler event-collecting-handler))
+  (push (list :end-document)
+	(event-list handler))
+
+  (nreverse (event-list handler)))
\ No newline at end of file

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/package.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/package.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,4 @@
+(defpackage :sax-tests
+  (:use :cl :xml :sax :glisp :rt)
+  (:export #:event-collecting-handler))
+

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/tests.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/sax-tests/tests.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,330 @@
+(in-package :sax-tests)
+
+(defun first-start-element-event (string)
+  (let ((events (cxml:parse-rod string (make-instance 'event-collecting-handler))))
+    (find :start-element events :key #'car)))
+
+
+;;; Attribute handling
+
+(deftest no-default-namespace-for-attributes
+  (let* ((evt (first-start-element-event "<x xmlns='http://example.com' a='b'/>"))
+	 (attr (car (fifth evt))))
+    (values
+     (attribute-namespace-uri attr)
+     (attribute-local-name attr)))
+  nil nil)
+
+(deftest attribute-uniqueness-1
+  (handler-case
+      (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest attribute-uniqueness-2
+  (handler-case
+      (cxml:parse-rod "<x xmlns:a='http://example.com' xmlns='http://example.com' a:a='1' a='1'/>")
+    (error () nil)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      t))
+  t)
+
+(deftest attribute-uniqueness-3
+  (let ((sax:*namespace-processing* nil))
+    (handler-case
+	(cxml:parse-rod "<x xmlns:a='http://example.com' xmlns:b='http://example.com' a:a='1' b:a='1'/>")
+    (error () nil)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      t)))
+  t)
+
+;;; Namespace undeclaring
+
+(deftest undeclare-default-namespace-1
+  (let* ((evts (cxml:parse-rod "<x xmlns='http://example.com'><y xmlns='' a='1'/></x>"
+				   (make-instance 'event-collecting-handler)))
+	 (start-elt-events (remove :start-element evts :test (complement #'eql) :key #'car))
+	 (evt1 (first start-elt-events))
+	 (evt2 (second start-elt-events )))
+    (values
+     (rod= #"http://example.com" (second evt1))
+     (second evt2)
+     (third evt2)))
+  t nil nil)
+
+(deftest undeclare-other-namespace
+  (handler-case
+      (cxml:parse-rod "<x:x xmlns:x='http://example.com'><x:y xmlns:x='' a='1'/></x:x>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+
+;;; Require names otherwise totally out of scope of the xmlns rec to be NcNames for no reason
+
+(deftest pi-names-are-ncnames-when-namespace-processing-1
+  (handler-case
+      (cxml:parse-rod "<?a:b c?><x/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest pi-names-are-ncnames-when-namespace-processing-2
+  (let ((sax:*namespace-processing* nil))
+    (handler-case
+	(cxml:parse-rod "<?a:b c?><x/>")
+      (error () nil)
+      (:no-error (&rest junk)
+	(declare (ignore junk))
+	t)))
+  t)
+
+(deftest entity-names-are-ncnames-when-namespace-processing-1
+  (handler-case
+      (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest entity-names-are-ncnames-when-namespace-processing-2
+  (handler-case
+      (cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest entity-names-are-ncnames-when-namespace-processing-3
+  (let ((sax:*namespace-processing* nil))
+    (handler-case
+	(cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x>&y:z;</x>")
+      (error () nil)
+      (:no-error (&rest junk)
+	(declare (ignore junk))
+	t)))
+  t)
+
+(deftest entity-names-are-ncnames-when-namespace-processing-4
+  (let ((sax:*namespace-processing* nil))
+    (handler-case
+	(cxml:parse-rod "<!DOCTYPE x [ <!ENTITY y:z 'foo'> ]><x/>")
+      (error () nil)
+      (:no-error (&rest junk)
+	(declare (ignore junk))
+	t)))
+  t)
+
+;;; Inclusion of xmlns attributes
+
+(deftest xmlns-attr-include-1
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (length attrs))
+  1)
+
+(deftest xmlns-attr-discard-1
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* nil)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (length attrs))
+  0)
+
+;;; Namespace of xmlns attributes
+
+(deftest xmlns-attr-ns-uri-1
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-namespace-uri (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-uri-2
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-namespace-uri (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-uri-3
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-namespace-uri (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-uri-4
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"http://www.w3.org/2000/xmlns/" (attribute-namespace-uri (car attrs))))
+  t)
+
+(deftest xmlns-attr-ns-local-name-1
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-local-name (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-local-name-2
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-local-name (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-local-name-3
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (attribute-local-name (car attrs)))
+  nil)
+
+(deftest xmlns-attr-ns-local-name-4
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"foo" (attribute-local-name (car attrs))))
+  t)
+
+(deftest xmlns-attr-qname-1
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"xmlns" (attribute-qname (car attrs))))
+  t)
+
+(deftest xmlns-attr-qname-2
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* nil)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"xmlns:foo" (attribute-qname (car attrs))))
+  t)
+
+(deftest xmlns-attr-qname-4
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"xmlns" (attribute-qname (car attrs))))
+  t)
+
+(deftest xmlns-attr-qname-4
+  (let* ((sax:*namespace-processing* t)
+	 (sax:*include-xmlns-attributes* t)
+	 (sax:*use-xmlns-namespace* t)
+	 (evt (first-start-element-event "<x xmlns:foo='http://example.com'/>"))
+	 (attrs (fifth evt)))
+    (rod= #"xmlns:foo" (attribute-qname (car attrs))))
+  t)
+
+
+;;; Predefined Namespaces
+
+(deftest redefine-xml-namespace-1
+  (handler-case
+      (cxml:parse-rod "<x xmlns:xml='http://www.w3.org/XML/1998/namespace'/>")
+    (error () nil)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      t))
+  t)
+
+(deftest redefine-xml-namespace-2
+  (handler-case
+      (cxml:parse-rod "<x xmlns:xml='http://example.com/wrong-uri'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xml-namespace-3
+  (handler-case
+      (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xml-namespace-4
+  (handler-case
+      (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/XML/1998/namespace'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xmlns-namespace-1
+  (handler-case
+      (cxml:parse-rod "<x xmlns:xmlns='http://www.w3.org/2000/xmlns/'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xmlns-namespace-2
+  (handler-case
+      (cxml:parse-rod "<x xmlns:xmlns='http://example.com/wrong-ns'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xmlns-namespace-3
+  (handler-case
+      (cxml:parse-rod "<x xmlns:wrong='http://www.w3.org/2000/xmlns/'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)
+
+(deftest redefine-xmlns-namespace-4
+  (handler-case
+      (cxml:parse-rod "<x xmlns='http://www.w3.org/2000/xmlns/'/>")
+    (error () t)
+    (:no-error (&rest junk)
+      (declare (ignore junk))
+      nil))
+  t)

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/space-normalizer.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/space-normalizer.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,62 @@
+;;;; space-normalizer.lisp -- whitespace removal
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Copyright (c) 2005 David Lichteblau
+
+(in-package :cxml)
+
+(defclass whitespace-normalizer (sax-proxy)
+    ((attributes :initform '(t) :accessor xml-space-attributes)
+     (models :initform nil :accessor xml-space-models)
+     (dtd :initarg :dtd :accessor xml-space-dtd)))
+
+(defun make-whitespace-normalizer (chained-handler &optional dtd)
+  (make-instance 'whitespace-normalizer
+    :dtd dtd
+    :chained-handler chained-handler))
+
+(defmethod sax::dtd ((handler whitespace-normalizer) dtd)
+  (unless (xml-space-dtd handler)
+    (setf (xml-space-dtd handler) dtd)))
+
+(defmethod sax:start-element
+    ((handler whitespace-normalizer) uri lname qname attrs)
+  (declare (ignore uri lname))
+  (let ((dtd (xml-space-dtd handler)))
+    (when dtd
+      (let ((xml-space
+	     (sax:find-attribute (if (stringp qname) "xml:space" #"xml:space")
+				 attrs)))
+	(push (if xml-space
+		  (rod= (rod (sax:attribute-value xml-space)) #"default")
+		  (car (xml-space-attributes handler)))
+	      (xml-space-attributes handler)))
+      (let* ((e (cxml::find-element (rod qname) dtd))
+	     (cspec (when e (cxml::elmdef-content e))))
+	(push (and (consp cspec)
+		   (not (and (eq (car cspec) '*)
+			     (let ((subspec (second cspec)))
+			       (and (eq (car subspec) 'or)
+				    (eq (cadr subspec) :PCDATA))))))
+	      (xml-space-models handler)))))
+  (call-next-method))
+
+(defmethod sax:characters ((handler whitespace-normalizer) data)
+  (cond
+    ((and (xml-space-dtd handler)
+	  (car (xml-space-attributes handler))
+	  (car (xml-space-models handler)))
+      (unless (every #'white-space-rune-p (rod data))
+	(warn "non-whitespace character data in element content")
+	(call-next-method)))
+    (t
+      (call-next-method))))
+
+(defmethod sax:end-element ((handler whitespace-normalizer) uri lname qname)
+  (declare (ignore uri lname qname))
+  (when (xml-space-dtd handler)
+    (pop (xml-space-attributes handler))
+    (pop (xml-space-models handler)))
+  (call-next-method))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/split-sequence.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/split-sequence.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,44 @@
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+
+(in-package :cxml)
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+  (let ((len (length seq))
+        (other-keys (when key-supplied 
+		      (list :key key))))
+    (unless end (setq end len))
+    (if from-end
+        (loop for right = end then left
+              for left = (max (or (apply #'position-if predicate seq 
+					 :end right
+					 :from-end t
+					 other-keys)
+				  -1)
+			      (1- start))
+              unless (and (= right (1+ left))
+                          remove-empty-subseqs) ; empty subseq we don't want
+              if (and count (>= nr-elts count))
+              ;; We can't take any more. Return now.
+              return (values (nreverse subseqs) right)
+              else 
+              collect (subseq seq (1+ left) right) into subseqs
+              and sum 1 into nr-elts
+              until (< left start)
+              finally (return (values (nreverse subseqs) (1+ left))))
+      (loop for left = start then (+ right 1)
+            for right = (min (or (apply #'position-if predicate seq 
+					:start left
+					other-keys)
+				 len)
+			     end)
+            unless (and (= right left) 
+                        remove-empty-subseqs) ; empty subseq we don't want
+            if (and count (>= nr-elts count))
+            ;; We can't take any more. Return now.
+            return (values subseqs left)
+            else
+            collect (subseq seq left right) into subseqs
+            and sum 1 into nr-elts
+            until (>= right end)
+            finally (return (values subseqs right))))))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/unparse.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/unparse.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,684 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; Encoding: utf-8; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Unparse XML
+;;;     Title: (including support for canonic XML according to J.Clark)
+;;;   Created: 1999-09-09
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;    Author: David Lichteblau <david at lichteblau.com>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999 by Gilbert Baumann
+;;;  (c) copyright 2004 by knowledgeTools Int. GmbH
+;;;  (c) copyright 2004 by David Lichteblau (for headcraft.de)
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :cxml)
+
+;; 
+;; | Canonical XML
+;; | =============
+;; |                                      
+;; | This document defines a subset of XML called canonical XML. The
+;; | intended use of canonical XML is in testing XML processors, as a
+;; | representation of the result of parsing an XML document.
+;; | 
+;; | Every well-formed XML document has a unique structurally equivalent
+;; | canonical XML document. Two structurally equivalent XML documents have
+;; | a byte-for-byte identical canonical XML document. Canonicalizing an
+;; | XML document requires only information that an XML processor is
+;; | required to make available to an application.
+;; | 
+;; | A canonical XML document conforms to the following grammar:
+;; |
+;; |    CanonXML    ::= Pi* element Pi*
+;; |    element     ::= Stag (Datachar | Pi | element)* Etag
+;; |    Stag        ::= '<'  Name Atts '>'
+;; |    Etag        ::= '</' Name '>'
+;; |    Pi          ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
+;; |    Atts        ::= (' ' Name '=' '"' Datachar* '"')*
+;; |    Datachar    ::= '&amp;' | '&lt;' | '&gt;' | '&quot;'
+;; |                     | '&#9;'| '&#10;'| '&#13;'
+;; |                     | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
+;; |    Name        ::= (see XML spec)
+;; |    Char        ::= (see XML spec)
+;; |    S           ::= (see XML spec)
+;; |
+;; | Attributes are in lexicographical order (in Unicode bit order).
+;; |  
+;; | A canonical XML document is encoded in UTF-8.
+;; |  
+;; | Ignorable white space is considered significant and is treated
+;; | equivalently to data.
+;;
+;; -- James Clark (jjc at jclark.com)
+
+
+;;;; SINK: an xml output sink
+
+(defclass sink (sax:content-handler)
+    ((ystream :initarg :ystream :accessor sink-ystream)
+     (width :initform 79 :initarg :width :accessor width)
+     (canonical :initform nil :initarg :canonical :accessor canonical)
+     (indentation :initform nil :initarg :indentation :accessor indentation)
+     (current-indentation :initform 0 :accessor current-indentation)
+     (notations :initform (make-buffer :element-type t) :accessor notations)
+     (name-for-dtd :accessor name-for-dtd)
+     (previous-notation :initform nil :accessor previous-notation)
+     (have-doctype :initform nil :accessor have-doctype)
+     (have-internal-subset :initform nil :accessor have-internal-subset)
+     (stack :initform nil :accessor stack)))
+
+#-rune-is-character
+(defmethod hax:%want-strings-p ((handler sink))
+  nil)
+
+(defmethod initialize-instance :after ((instance sink) &key)
+  (when (eq (canonical instance) t)
+    (setf (canonical instance) 1))
+  (unless (member (canonical instance) '(nil 1 2))
+    (error "Invalid canonical form: ~A" (canonical instance)))
+  (when (and (canonical instance) (indentation instance))
+    (error "Cannot indent XML in canonical mode")))
+
+(defun make-buffer (&key (element-type '(unsigned-byte 8)))
+  (make-array 1
+              :element-type element-type
+              :adjustable t
+              :fill-pointer 0))
+
+;; bisschen unschoen hier die ganze api zu duplizieren, aber die
+;; ystreams sind noch undokumentiert
+(macrolet ((define-maker (make-sink make-ystream &rest args)
+	     `(defun ,make-sink (, at args &rest initargs)
+		(apply #'make-instance
+		       'sink
+		       :ystream (,make-ystream , at args)
+		       initargs))))
+  (define-maker make-octet-vector-sink make-octet-vector-ystream)
+  (define-maker make-octet-stream-sink make-octet-stream-ystream stream)
+  (define-maker make-rod-sink make-rod-ystream)
+
+  #+rune-is-character
+  (define-maker make-character-stream-sink make-character-stream-ystream stream)
+
+  #-rune-is-character
+  (define-maker make-string-sink/utf8 make-string-ystream/utf8)
+
+  #-rune-is-character
+  (define-maker make-character-stream-sink/utf8
+      make-character-stream-ystream/utf8
+    stream))
+
+#+rune-is-character
+(defun make-string-sink (&rest args) (apply #'make-rod-sink args))
+
+
+(defmethod sax:end-document ((sink sink))
+  (close-ystream (sink-ystream sink)))
+
+
+;;;; doctype and notations
+
+(defmethod sax:start-document ((sink sink))
+  (unless (canonical sink)
+    (%write-rod #"<?xml version=\"1.0\" encoding=\"UTF-8\"?>" sink)
+    (%write-rune #/U+000A sink)))
+
+(defmethod sax:start-dtd ((sink sink) name public-id system-id)
+  (setf (name-for-dtd sink) name)
+  (unless (canonical sink)
+    (ensure-doctype sink public-id system-id)))
+
+(defun ensure-doctype (sink &optional public-id system-id)
+  (unless (have-doctype sink)
+    (setf (have-doctype sink) t)
+    (%write-rod #"<!DOCTYPE " sink)
+    (%write-rod (name-for-dtd sink) sink)
+    (cond
+      ((not (zerop (length public-id)))
+        (%write-rod #" PUBLIC \"" sink)
+        (unparse-string public-id sink)
+        (%write-rod #"\" \"" sink)
+        (unparse-string system-id sink)
+        (%write-rod #"\"" sink))
+      ((not (zerop (length system-id)))
+        (%write-rod #" SYSTEM \"" sink)
+        (unparse-string system-id sink)
+        (%write-rod #"\"" sink)))))
+
+(defmethod sax:start-internal-subset ((sink sink))
+  (when (have-internal-subset sink)
+    (error "duplicate internal subset"))
+  (setf (have-internal-subset sink) t)
+  (ensure-doctype sink)
+  (%write-rod #" [" sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:end-internal-subset ((sink sink))
+  (ensure-doctype sink)
+  (%write-rod #"]" sink))
+
+(defmethod sax:unparsed-internal-subset ((sink sink) str)
+  (when (have-internal-subset sink)
+    (error "duplicate internal subset"))
+  (setf (have-internal-subset sink) t)
+  (ensure-doctype sink)
+  (%write-rod #" [" sink)
+  (%write-rune #/U+000A sink)
+  (%write-rod str sink)
+  (%write-rod #"]" sink))
+
+;; for the benefit of the XML test suite, prefer ' over "
+(defun write-quoted-rod (x sink)
+  (let ((q (if (find #/' x) #/" #/'
+               ;; '" (thanks you Emacs indentation, the if ends here)
+		     )))
+    (%write-rune q sink)
+    (%write-rod x sink)
+    (%write-rune q sink)))
+
+(defmethod sax:notation-declaration ((sink sink) name public-id system-id)
+  (let ((prev (previous-notation sink)))
+    (when (and (and (canonical sink) (>= (canonical sink) 2))
+	       prev
+	       (not (rod< prev name)))
+      (error "misordered notations; cannot unparse canonically"))
+    (setf (previous-notation sink) name)) 
+  (%write-rod #"<!NOTATION " sink)
+  (%write-rod name sink)
+  (cond
+    ((zerop (length public-id))
+      (%write-rod #" SYSTEM " sink)
+      (write-quoted-rod system-id sink))
+    ((zerop (length system-id))
+      (%write-rod #" PUBLIC " sink)
+      (write-quoted-rod public-id sink))
+    (t 
+      (%write-rod #" PUBLIC " sink)
+      (write-quoted-rod public-id sink)
+      (%write-rod #" " sink)
+      (write-quoted-rod system-id sink)))
+  (%write-rune #/> sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:unparsed-entity-declaration
+    ((sink sink) name public-id system-id notation-name)
+  (unless (and (canonical sink) (< (canonical sink) 3))
+    (%write-rod #"<!ENTITY " sink)
+    (%write-rod name sink)
+    (cond
+      ((zerop (length public-id))
+	(%write-rod #" SYSTEM " sink)
+	(write-quoted-rod system-id sink))
+      ((zerop (length system-id))
+	(%write-rod #" PUBLIC " sink)
+	(write-quoted-rod public-id sink))
+      (t 
+	(%write-rod #" PUBLIC " sink)
+	(write-quoted-rod public-id sink)
+	(%write-rod #" " sink)
+	(write-quoted-rod system-id sink)))
+    (%write-rod #" NDATA " sink)
+    (%write-rod notation-name sink)
+    (%write-rune #/> sink)
+    (%write-rune #/U+000A sink)))
+
+(defmethod sax:external-entity-declaration
+    ((sink sink) kind name public-id system-id)
+  (when (canonical sink)
+    (error "cannot serialize parsed entities in canonical mode"))
+  (%write-rod #"<!ENTITY " sink)
+  (when (eq kind :parameter)
+    (%write-rod #" % " sink))
+  (%write-rod name sink)
+  (cond
+    ((zerop (length public-id))
+      (%write-rod #" SYSTEM " sink)
+      (write-quoted-rod system-id sink))
+    ((zerop (length system-id))
+      (%write-rod #" PUBLIC " sink)
+      (write-quoted-rod public-id sink))
+    (t 
+      (%write-rod #" PUBLIC " sink)
+      (write-quoted-rod public-id sink)
+      (%write-rod #" " sink)
+      (write-quoted-rod system-id sink)))
+  (%write-rune #/> sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:internal-entity-declaration ((sink sink) kind name value)
+  (when (canonical sink)
+    (error "cannot serialize parsed entities in canonical mode"))
+  (%write-rod #"<!ENTITY " sink)
+  (when (eq kind :parameter)
+    (%write-rod #" % " sink))
+  (%write-rod name sink)
+  (%write-rune #/U+0020 sink)
+  (%write-rune #/\" sink)
+  (unparse-dtd-string value sink)
+  (%write-rune #/\" sink)
+  (%write-rune #/> sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:element-declaration ((sink sink) name model)
+  (when (canonical sink)
+    (error "cannot serialize element type declarations in canonical mode"))
+  (%write-rod #"<!ELEMENT " sink)
+  (%write-rod name sink)
+  (%write-rune #/U+0020 sink)
+  (labels ((walk (m)
+	     (cond
+	       ((eq m :EMPTY)
+		 (%write-rod "EMPTY" sink))
+	       ((eq m :PCDATA)
+		 (%write-rod "#PCDATA" sink))
+	       ((atom m)
+		 (unparse-string m sink))
+	       (t
+		 (ecase (car m)
+		   (and
+		     (%write-rune #/\( sink)
+		     (loop for (n . rest) on (cdr m) do
+			   (walk n)
+			   (when rest
+			     (%write-rune #\, sink)))
+		     (%write-rune #/\) sink))
+		   (or
+		     (%write-rune #/\( sink)
+		     (loop for (n . rest) on (cdr m) do
+			   (walk n)
+			   (when rest
+			     (%write-rune #\| sink)))
+		     (%write-rune #/\) sink))
+		   (*
+		     (walk (second m))
+		     (%write-rod #/* sink))
+		   (+
+		     (walk (second m))
+		     (%write-rod #/+ sink))
+		   (?
+		     (walk (second m))
+		     (%write-rod #/? sink)))))))
+    (walk model))
+  (%write-rune #/> sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:attribute-declaration ((sink sink) ename aname type default)
+  (when (canonical sink)
+    (error "cannot serialize attribute type declarations in canonical mode"))
+  (%write-rod #"<!ATTLIST " sink)
+  (%write-rod ename sink)
+  (%write-rune #/U+0020 sink)
+  (%write-rod aname sink)
+  (%write-rune #/U+0020 sink)
+  (cond
+    ((atom type)
+      (%write-rod (rod (string-upcase (symbol-name type))) sink))
+    (t
+      (when (eq :NOTATION (car type))
+	(%write-rod #"NOTATION " sink))
+      (%write-rune #/\( sink)
+      (loop for (n . rest) on (cdr type) do
+	    (%write-rod n sink)
+	    (when rest
+	      (%write-rune #\| sink)))
+      (%write-rune #/\) sink)))
+  (%write-rune #/U+0020 sink)
+  (cond
+    ((atom default)
+      (%write-rune #/# sink)
+      (%write-rod (rod (string-upcase (symbol-name default))) sink))
+    (t
+      (when (eq :FIXED (car default))
+	(%write-rod #"#FIXED " sink))
+      (%write-rune #/\" sink)
+      (unparse-string (second default) sink)
+      (%write-rune #/\" sink)))
+  (%write-rune #/> sink)
+  (%write-rune #/U+000A sink))
+
+(defmethod sax:end-dtd ((sink sink))
+  (when (have-doctype sink)
+    (%write-rod #">" sink)
+    (%write-rune #/U+000A sink)))
+
+
+;;;; elements
+
+(defstruct (tag (:constructor make-tag (name)))
+  name
+  (n-children 0)
+  (have-gt nil))
+
+(defun sink-fresh-line (sink)
+  (unless (zerop (ystream-column (sink-ystream sink)))
+    (%write-rune #/U+000A sink)		;newline
+    (indent sink)))
+
+(defun maybe-close-tag (sink)
+  (let ((tag (car (stack sink))))
+    (when (and (tag-p tag) (not (tag-have-gt tag)))
+      (setf (tag-have-gt tag) t)
+      (%write-rune #/> sink))))
+
+(defmethod sax:start-element
+    ((sink sink) namespace-uri local-name qname attributes)
+  (declare (ignore namespace-uri local-name))
+  (maybe-close-tag sink)
+  (when (stack sink)
+    (incf (tag-n-children (first (stack sink)))))
+  (push (make-tag qname) (stack sink))
+  (when (indentation sink)
+    (sink-fresh-line sink)
+    (start-indentation-block sink))
+  (%write-rune #/< sink)
+  (%write-rod qname sink)
+  (dolist (a (if (canonical sink)
+		 (sort (copy-list attributes)
+		       #'rod<
+		       :key #'sax:attribute-qname)
+		 attributes))
+    (%write-rune #/space sink)
+    (%write-rod (sax:attribute-qname a) sink)
+    (%write-rune #/= sink)
+    (%write-rune #/\" sink)
+    (unparse-string (sax:attribute-value a) sink)
+    (%write-rune #/\" sink))
+  (when (canonical sink)
+    (maybe-close-tag sink)))
+
+(defmethod sax:end-element
+    ((sink sink) namespace-uri local-name qname)
+  (declare (ignore namespace-uri local-name))
+  (let ((tag (pop (stack sink))))
+    (unless (tag-p tag)
+      (error "output does not nest: not in an element"))
+    (unless (rod= (tag-name tag) qname)
+      (error "output does not nest: expected ~A but got ~A"
+             (rod qname) (rod (tag-name tag))))
+    (when (indentation sink)
+      (end-indentation-block sink)
+      (unless (zerop (tag-n-children tag))
+        (sink-fresh-line sink)))
+    (cond
+      ((tag-have-gt tag)
+       (%write-rod '#.(string-rod "</") sink)
+       (%write-rod qname sink)
+       (%write-rod '#.(string-rod ">") sink))
+      (t
+       (%write-rod #"/>" sink)))))
+
+(defmethod sax:processing-instruction ((sink sink) target data)
+  (maybe-close-tag sink)
+  (unless (rod-equal target '#.(string-rod "xml"))
+    (%write-rod '#.(string-rod "<?") sink)
+    (%write-rod target sink)
+    (cond
+      ((plusp (length data))
+       (%write-rune #/space sink)
+       (%write-rod data sink))
+      ((canonical sink)
+       (%write-rune #/space sink)))
+    (%write-rod '#.(string-rod "?>") sink)))
+
+(defmethod sax:start-cdata ((sink sink))
+  (maybe-close-tag sink)
+  (push :cdata (stack sink)))
+
+(defmethod sax:characters ((sink sink) data)
+  (maybe-close-tag sink)
+  (cond
+    ((and (eq (car (stack sink)) :cdata)
+          (not (canonical sink))
+          (not (search #"]]" data)))
+      (when (indentation sink)
+        (sink-fresh-line sink))
+      (%write-rod #"<![CDATA[" sink)
+      ;; XXX signal error if body is unprintable?
+      (map nil (lambda (c) (%write-rune c sink)) data)
+      (%write-rod #"]]>" sink))
+    (t
+      (if (indentation sink)
+          (unparse-indented-text data sink)
+	  (let ((y (sink-ystream sink)))
+	    (if (canonical sink)
+		(loop for c across data do (unparse-datachar c y))
+		(loop for c across data do (unparse-datachar-readable c y))))))))
+
+(defmethod sax:comment ((sink sink) data)
+  (maybe-close-tag sink)
+  (unless (canonical sink)
+    ;; XXX signal error if body is unprintable?
+    (%write-rod #"<!--" sink)
+    (map nil (lambda (c) (%write-rune c sink)) data)
+    (%write-rod #"-->" sink)))
+
+(defmethod sax:end-cdata ((sink sink))
+  (unless (eq (pop (stack sink)) :cdata)
+    (error "output does not nest: not in a cdata section")))
+
+(defun indent (sink)
+  (dotimes (x (current-indentation sink))
+    (%write-rune #/U+0020 sink))) ; space
+
+(defun start-indentation-block (sink)
+  (incf (current-indentation sink) (indentation sink)))
+
+(defun end-indentation-block (sink)
+  (decf (current-indentation sink) (indentation sink)))
+
+(defun unparse-indented-text (data sink)
+  (flet ((whitespacep (x)
+           (or (rune= x #/U+000A) (rune= x #/U+0020))))
+    (let* ((n (length data))
+           (pos (position-if-not #'whitespacep data))
+           (need-whitespace-p nil))
+      (cond
+        ((zerop n))
+        (pos
+          (sink-fresh-line sink)
+          (while (< pos n)
+            (let* ((w (or (position-if #'whitespacep data :start (1+ pos)) n))
+                   (next (or (position-if-not #'whitespacep data :start w) n)))
+              (when need-whitespace-p
+                (if (< (+ (ystream-column (sink-ystream sink)) w (- pos))
+		       (width sink))
+                    (%write-rune #/U+0020 sink)
+                    (sink-fresh-line sink)))
+              (loop
+		  with y = (sink-ystream sink)
+                  for i from pos below w do
+                    (unparse-datachar-readable (elt data i) y))
+              (setf need-whitespace-p (< w n))
+              (setf pos next))))
+        (t
+          (%write-rune #/U+0020 sink))))))
+
+(defun unparse-string (str sink)
+  (let ((y (sink-ystream sink)))
+    (loop for rune across str do (unparse-datachar rune y))))
+
+(defun unparse-datachar (c ystream)
+  (cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
+        ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
+        ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
+        ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
+        ((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") ystream))
+        ((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") ystream))
+        ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
+        (t
+         (write-rune c ystream))))
+
+(defun unparse-datachar-readable (c ystream)
+  (cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
+        ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
+        ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
+        ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
+        ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
+        (t
+          (write-rune c ystream))))
+
+(defun unparse-dtd-string (str sink)
+  (let ((y (sink-ystream sink)))
+    (loop for rune across str do (unparse-dtd-char rune y))))
+
+(defun unparse-dtd-char (c ystream)
+  (cond ((rune= c #/%) (write-rod '#.(string-rod "&#37;") ystream))
+        ((rune= c #/&) (write-rod '#.(string-rod "&amp;") ystream))
+        ((rune= c #/<) (write-rod '#.(string-rod "&lt;") ystream))
+        ((rune= c #/>) (write-rod '#.(string-rod "&gt;") ystream))
+        ((rune= c #/\") (write-rod '#.(string-rod "&quot;") ystream))
+        ((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") ystream))
+        ((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") ystream))
+        ((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") ystream))
+        (t
+         (write-rune c ystream))))
+
+(defun %write-rune (c sink)
+  (write-rune c (sink-ystream sink)))
+
+(defun %write-rod (r sink)
+  (write-rod r (sink-ystream sink)))
+
+
+;;;; convenience functions for DOMless XML serialization
+
+(defvar *current-element*)
+(defvar *sink*)
+(defvar *unparse-namespace-bindings*)
+(defvar *current-namespace-bindings*)
+
+(defmacro with-xml-output (sink &body body)
+  `(invoke-with-xml-output (lambda () , at body) ,sink))
+
+(defmacro with-output-sink ((var) &body body)
+  `(invoke-with-output-sink (lambda (,var) , at body)))
+
+(defun invoke-with-xml-output (fn sink)
+  (let ((*sink* sink)
+        (*current-element* nil)
+	(*unparse-namespace-bindings* *initial-namespace-bindings*)
+	(*current-namespace-bindings* nil))
+    (sax:start-document *sink*)
+    (funcall fn)
+    (sax:end-document *sink*)))
+
+(defun invoke-with-output-sink (fn)
+  (maybe-emit-start-tag)
+  (funcall fn *sink*))
+
+(defmacro with-element (qname &body body)
+  `(invoke-with-element (lambda () , at body) ,qname))
+
+(defmacro with-element* ((prefix lname) &body body)
+  `(invoke-with-element* (lambda () , at body) ,prefix ,lname))
+
+(defmacro with-namespace ((prefix uri) &body body)
+  `(invoke-with-namespace (lambda () , at body) ,prefix ,uri))
+
+(defun doctype (name public-id system-id &optional internal-subset)
+  (sax:start-dtd *sink* name public-id system-id)
+  (when internal-subset
+    (sax:unparsed-internal-subset *sink* internal-subset))
+  (sax:end-dtd *sink*))
+
+(defun maybe-emit-start-tag ()
+  (when *current-element*
+    ;; starting child node, need to emit opening tag of parent first:
+    (destructuring-bind ((uri lname qname) &rest attributes) *current-element*
+      (sax:start-element *sink* uri lname qname (reverse attributes)))
+    (setf *current-element* nil)))
+
+(defun invoke-with-namespace (fn prefix uri)
+  (let ((*unparse-namespace-bindings*
+	 (acons prefix uri *unparse-namespace-bindings*))
+	(*current-namespace-bindings*
+	 (acons prefix uri *current-namespace-bindings*)))
+    (sax:start-prefix-mapping *sink* prefix uri)
+    (multiple-value-prog1
+	(funcall fn)
+      (sax:end-prefix-mapping *sink* prefix))))
+
+(defun invoke-with-element (fn qname)
+  (setf qname (rod qname))
+  (multiple-value-bind (prefix lname)
+      (split-qname qname)
+    (invoke-with-element* fn prefix lname qname)))
+
+(defun find-unparse-namespace (prefix)
+  (cdr (assoc prefix *unparse-namespace-bindings* :test 'equal)))
+
+(defun invoke-with-element* (fn prefix lname &optional qname)
+  (setf prefix (when prefix (rod prefix)))
+  (setf lname (rod lname))
+  (maybe-emit-start-tag)
+  (let* ((qname (or qname
+		    (if prefix (concatenate 'rod prefix #":" lname) lname)))
+	 (uri (find-unparse-namespace (or prefix #"")))
+	 (*current-element*
+	  (cons (list uri lname qname)
+		(mapcar (lambda (x)
+			  (destructuring-bind (prefix &rest uri) x
+			    (sax:make-attribute
+			     :namespace-uri #"http://www.w3.org/2000/xmlns/"
+			     :local-name prefix
+			     :qname (if (zerop (length prefix))
+					#"xmlns"
+					(concatenate 'rod #"xmlns:" prefix))
+			     :value uri)))
+			*current-namespace-bindings*))))
+    (multiple-value-prog1
+        (let ((*current-namespace-bindings* nil))
+	  (funcall fn))
+      (maybe-emit-start-tag)
+      (sax:end-element *sink* uri lname qname))))
+
+(defgeneric unparse-attribute (value))
+(defmethod unparse-attribute ((value string)) value)
+(defmethod unparse-attribute ((value null)) nil)
+(defmethod unparse-attribute ((value integer)) (write-to-string value))
+
+(defun attribute (qname value)
+  (setf qname (rod qname))
+  (multiple-value-bind (prefix lname)
+      (split-qname qname)
+    (attribute* prefix lname value qname)))
+
+(defun attribute* (prefix lname value &optional qname)
+  (setf value (unparse-attribute value))
+  (when value
+    (setf prefix (when prefix (rod prefix)))
+    (setf lname (rod lname))
+    (push (sax:make-attribute
+	   :namespace-uri (find-unparse-namespace prefix)
+	   :local-name lname
+	   :qname (or qname
+		      (if prefix (concatenate 'rod prefix #":" lname) lname))
+	   :value (rod value))
+	  (cdr *current-element*))))
+
+(defun cdata (data)
+  (maybe-emit-start-tag)
+  (sax:start-cdata *sink*)
+  (sax:characters *sink* (rod data))
+  (sax:end-cdata *sink*)
+  data)
+
+(defun text (data)
+  (maybe-emit-start-tag)
+  (sax:characters *sink* (rod data))
+  data)

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/util.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/util.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,73 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Some common utilities for the Closure browser
+;;;   Created: 1997-12-27
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1997-1999 by Gilbert Baumann
+
+;;; This code is free software; you can redistribute it and/or modify it
+;;; under the terms of the version 2.1 of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, as clarified
+;;; by the "Preamble to the Gnu Lesser General Public License" found in
+;;; the file COPYING.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; but without any warranty; without even the implied warranty of
+;;; merchantability or fitness for a particular purpose.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; Version 2.1 of the GNU Lesser General Public License is in the file
+;;; COPYING that was distributed with this file.  If it is not present,
+;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
+;;; superseded by a newer version) or write to the Free Software
+;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;; Changes
+;;
+;;  When        Who     What
+;; ----------------------------------------------------------------------------
+;;  1999-08-24  GB      = fixed MULTIPLE-VALUE-OR it now takes any number of
+;;                        subforms
+;;
+
+(in-package :cxml)
+
+;;; --------------------------------------------------------------------------------
+;;;  Meta functions
+
+(defun curry (fun &rest args)
+  #'(lambda (&rest more)
+      (apply fun (append args more))))
+
+(defun rcurry (fun &rest args)
+  #'(lambda (&rest more)
+      (apply fun (append more args))))
+
+(defun compose (f g)
+  #'(lambda (&rest args)
+      (funcall f (apply g args))))
+
+;;; --------------------------------------------------------------------------------
+;;;  while and until
+
+(defmacro while (test &body body)
+  `(until (not ,test) , at body))
+
+(defmacro until (test &body body)
+  `(do () (,test) , at body))
+
+;; prime numbers
+
+(defun primep (n)
+  "Returns true, iff `n' is prime."
+  (and (> n 2)
+       (do ((i 2 (+ i 1)))
+           ((> (* i i) n) t)
+         (cond ((zerop (mod n i)) (return nil))))))
+
+(defun nearest-greater-prime (n)
+  "Returns the smallest prime number no less than `n'."
+  (cond ((primep n) n)
+        ((nearest-greater-prime (+ n 1)))))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-name-rune-p.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-name-rune-p.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,185 @@
+;;;; xml-name-rune-p -- character class definitions
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+
+(in-package :cxml)
+
+#.(funcall 
+   (compile 
+    nil
+    '(lambda ()
+      (let ((+max+ #xD800)
+	    (base-char-ranges
+	     #((#x0041 #x005A) (#x0061 #x007A) (#x00C0 #x00D6) (#x00D8 #x00F6)
+	       (#x00F8 #x00FF) (#x0100 #x0131) (#x0134 #x013E) (#x0141 #x0148)
+	       (#x014A #x017E) (#x0180 #x01C3) (#x01CD #x01F0) (#x01F4 #x01F5)
+	       (#x01FA #x0217) (#x0250 #x02A8) (#x02BB #x02C1) (#x0386 #x0386)
+	       (#x0388 #x038A) (#x038C #x038C) (#x038E #x03A1) (#x03A3 #x03CE)
+	       (#x03D0 #x03D6) (#x03DA #x03DA) (#x03DC #x03DC) (#x03DE #x03DE)
+	       (#x03E0 #x03E0) (#x03E2 #x03F3) (#x0401 #x040C) (#x040E #x044F)
+	       (#x0451 #x045C) (#x045E #x0481) (#x0490 #x04C4) (#x04C7 #x04C8)
+	       (#x04CB #x04CC) (#x04D0 #x04EB) (#x04EE #x04F5) (#x04F8 #x04F9)
+	       (#x0531 #x0556) (#x0559 #x0559) (#x0561 #x0586) (#x05D0 #x05EA)
+	       (#x05F0 #x05F2) (#x0621 #x063A) (#x0641 #x064A) (#x0671 #x06B7)
+	       (#x06BA #x06BE) (#x06C0 #x06CE) (#x06D0 #x06D3) (#x06D5 #x06D5)
+	       (#x06E5 #x06E6) (#x0905 #x0939) (#x093D #x093D) (#x0958 #x0961)
+	       (#x0985 #x098C) (#x098F #x0990) (#x0993 #x09A8) (#x09AA #x09B0)
+	       (#x09B2 #x09B2) (#x09B6 #x09B9) (#x09DC #x09DD) (#x09DF #x09E1)
+	       (#x09F0 #x09F1) (#x0A05 #x0A0A) (#x0A0F #x0A10) (#x0A13 #x0A28)
+	       (#x0A2A #x0A30) (#x0A32 #x0A33) (#x0A35 #x0A36) (#x0A38 #x0A39)
+	       (#x0A59 #x0A5C) (#x0A5E #x0A5E) (#x0A72 #x0A74) (#x0A85 #x0A8B)
+	       (#x0A8D #x0A8D) (#x0A8F #x0A91) (#x0A93 #x0AA8) (#x0AAA #x0AB0)
+	       (#x0AB2 #x0AB3) (#x0AB5 #x0AB9) (#x0ABD #x0ABD) (#x0AE0 #x0AE0)
+	       (#x0B05 #x0B0C) (#x0B0F #x0B10) (#x0B13 #x0B28) (#x0B2A #x0B30)
+	       (#x0B32 #x0B33) (#x0B36 #x0B39) (#x0B3D #x0B3D) (#x0B5C #x0B5D)
+	       (#x0B5F #x0B61) (#x0B85 #x0B8A) (#x0B8E #x0B90) (#x0B92 #x0B95)
+	       (#x0B99 #x0B9A) (#x0B9C #x0B9C) (#x0B9E #x0B9F) (#x0BA3 #x0BA4)
+	       (#x0BA8 #x0BAA) (#x0BAE #x0BB5) (#x0BB7 #x0BB9) (#x0C05 #x0C0C)
+	       (#x0C0E #x0C10) (#x0C12 #x0C28) (#x0C2A #x0C33) (#x0C35 #x0C39)
+	       (#x0C60 #x0C61) (#x0C85 #x0C8C) (#x0C8E #x0C90) (#x0C92 #x0CA8)
+	       (#x0CAA #x0CB3) (#x0CB5 #x0CB9) (#x0CDE #x0CDE) (#x0CE0 #x0CE1)
+	       (#x0D05 #x0D0C) (#x0D0E #x0D10) (#x0D12 #x0D28) (#x0D2A #x0D39)
+	       (#x0D60 #x0D61) (#x0E01 #x0E2E) (#x0E30 #x0E30) (#x0E32 #x0E33)
+	       (#x0E40 #x0E45) (#x0E81 #x0E82) (#x0E84 #x0E84) (#x0E87 #x0E88)
+	       (#x0E8A #x0E8A) (#x0E8D #x0E8D) (#x0E94 #x0E97) (#x0E99 #x0E9F)
+	       (#x0EA1 #x0EA3) (#x0EA5 #x0EA5) (#x0EA7 #x0EA7) (#x0EAA #x0EAB)
+	       (#x0EAD #x0EAE) (#x0EB0 #x0EB0) (#x0EB2 #x0EB3) (#x0EBD #x0EBD)
+	       (#x0EC0 #x0EC4) (#x0F40 #x0F47) (#x0F49 #x0F69) (#x10A0 #x10C5)
+	       (#x10D0 #x10F6) (#x1100 #x1100) (#x1102 #x1103) (#x1105 #x1107)
+	       (#x1109 #x1109) (#x110B #x110C) (#x110E #x1112) (#x113C #x113C)
+	       (#x113E #x113E) (#x1140 #x1140) (#x114C #x114C) (#x114E #x114E)
+	       (#x1150 #x1150) (#x1154 #x1155) (#x1159 #x1159) (#x115F #x1161)
+	       (#x1163 #x1163) (#x1165 #x1165) (#x1167 #x1167) (#x1169 #x1169)
+	       (#x116D #x116E) (#x1172 #x1173) (#x1175 #x1175) (#x119E #x119E)
+	       (#x11A8 #x11A8) (#x11AB #x11AB) (#x11AE #x11AF) (#x11B7 #x11B8)
+	       (#x11BA #x11BA) (#x11BC #x11C2) (#x11EB #x11EB) (#x11F0 #x11F0)
+	       (#x11F9 #x11F9) (#x1E00 #x1E9B) (#x1EA0 #x1EF9) (#x1F00 #x1F15)
+	       (#x1F18 #x1F1D) (#x1F20 #x1F45) (#x1F48 #x1F4D) (#x1F50 #x1F57)
+	       (#x1F59 #x1F59) (#x1F5B #x1F5B) (#x1F5D #x1F5D) (#x1F5F #x1F7D)
+	       (#x1F80 #x1FB4) (#x1FB6 #x1FBC) (#x1FBE #x1FBE) (#x1FC2 #x1FC4)
+	       (#x1FC6 #x1FCC) (#x1FD0 #x1FD3) (#x1FD6 #x1FDB) (#x1FE0 #x1FEC)
+	       (#x1FF2 #x1FF4) (#x1FF6 #x1FFC) (#x2126 #x2126) (#x212A #x212B)
+	       (#x212E #x212E) (#x2180 #x2182) (#x3041 #x3094) (#x30A1 #x30FA)
+	       (#x3105 #x312C) (#xAC00 #xD7A3)))
+	    (ideographic-ranges #((#x3007 #x3007) (#x3021 #x3029)(#x4E00 #x9FA5)))
+	    (combining-char-ranges
+	     #((#x0300 #x0345) (#x0360 #x0361) (#x0483 #x0486) (#x0591 #x05A1)
+	       (#x05A3 #x05B9) (#x05BB #x05BD) (#x05BF #x05BF) (#x05C1 #x05C2)
+	       (#x05C4 #x05C4) (#x064B #x0652) (#x0670 #x0670) (#x06D6 #x06DC)
+	       (#x06DD #x06DF) (#x06E0 #x06E4) (#x06E7 #x06E8) (#x06EA #x06ED)
+	       (#x0901 #x0903) (#x093C #x093C) (#x093E #x094C) (#x094D #x094D)
+	       (#x0951 #x0954) (#x0962 #x0963) (#x0981 #x0983) (#x09BC #x09BC)
+	       (#x09BE #x09BE) (#x09BF #x09BF) (#x09C0 #x09C4) (#x09C7 #x09C8)
+	       (#x09CB #x09CD) (#x09D7 #x09D7) (#x09E2 #x09E3) (#x0A02 #x0A02)
+	       (#x0A3C #x0A3C) (#x0A3E #x0A3E) (#x0A3F #x0A3F) (#x0A40 #x0A42)
+	       (#x0A47 #x0A48) (#x0A4B #x0A4D) (#x0A70 #x0A71) (#x0A81 #x0A83)
+	       (#x0ABC #x0ABC) (#x0ABE #x0AC5) (#x0AC7 #x0AC9) (#x0ACB #x0ACD)
+	       (#x0B01 #x0B03) (#x0B3C #x0B3C) (#x0B3E #x0B43) (#x0B47 #x0B48)
+	       (#x0B4B #x0B4D) (#x0B56 #x0B57) (#x0B82 #x0B83) (#x0BBE #x0BC2)
+	       (#x0BC6 #x0BC8) (#x0BCA #x0BCD) (#x0BD7 #x0BD7) (#x0C01 #x0C03)
+	       (#x0C3E #x0C44) (#x0C46 #x0C48) (#x0C4A #x0C4D) (#x0C55 #x0C56)
+	       (#x0C82 #x0C83) (#x0CBE #x0CC4) (#x0CC6 #x0CC8) (#x0CCA #x0CCD)
+	       (#x0CD5 #x0CD6) (#x0D02 #x0D03) (#x0D3E #x0D43) (#x0D46 #x0D48)
+	       (#x0D4A #x0D4D) (#x0D57 #x0D57) (#x0E31 #x0E31) (#x0E34 #x0E3A)
+	       (#x0E47 #x0E4E) (#x0EB1 #x0EB1) (#x0EB4 #x0EB9) (#x0EBB #x0EBC)
+	       (#x0EC8 #x0ECD) (#x0F18 #x0F19) (#x0F35 #x0F35) (#x0F37 #x0F37)
+	       (#x0F39 #x0F39) (#x0F3E #x0F3E) (#x0F3F #x0F3F) (#x0F71 #x0F84)
+	       (#x0F86 #x0F8B) (#x0F90 #x0F95) (#x0F97 #x0F97) (#x0F99 #x0FAD)
+	       (#x0FB1 #x0FB7) (#x0FB9 #x0FB9) (#x20D0 #x20DC) (#x20E1 #x20E1)
+	       (#x302A #x302F) (#x3099 #x3099) (#x309A #x309A))
+	      )
+	    (digit-ranges
+	     #((#x0030 #x0039) (#x0660 #x0669) (#x06F0 #x06F9) (#x0966 #x096F)
+	       (#x09E6 #x09EF) (#x0A66 #x0A6F) (#x0AE6 #x0AEF) (#x0B66 #x0B6F)
+	       (#x0BE7 #x0BEF) (#x0C66 #x0C6F) (#x0CE6 #x0CEF) (#x0D66 #x0D6F)
+	       (#x0E50 #x0E59) (#x0ED0 #x0ED9) (#x0F20 #x0F29)))
+	    (extender-ranges
+	     #((#x00B7 #x00B7) (#x02D0 #x02D0) (#x02D1 #x02D1) (#x0387 #x0387)
+	       (#x0640 #x0640) (#x0E46 #x0E46) (#x0EC6 #x0EC6) (#x3005 #x3005)
+	       (#x3031 #x3035) (#x309D #x309E) (#x30FC #x30FE))))
+        (labels
+            ((rune-in-range-p (code range-vector)
+	       (declare (type simple-vector range-vector))
+	       ;;we were always dealing with a sorted vector... bin search it
+ 
+	       (let ((start 0)
+		     (end (length range-vector)))
+		 (while (< start end)
+		   (let ((mid-index (+ start (floor (- end start) 2))))
+		     (destructuring-bind (mid-item-low mid-item-high)
+			 (aref range-vector mid-index)
+		       (cond
+			 ((< mid-item-high code)
+			   (setf start (1+ mid-index)))
+			 ((< code mid-item-low)
+			   (setf end mid-index))
+			 (t
+			   (return t))))))))
+	     
+	     (name-start-rune-p (rune)
+               (or (letter-rune-p rune)
+                   (= #.(char-code #\_) rune)
+                   (= #.(char-code #\:) rune)))
+
+             (name-rune-p (rune)
+               (or (letter-rune-p rune)
+                   (digit-rune-p* rune)
+                   (= rune #.(char-code #\.))
+                   (= rune #.(char-code #\-))
+                   (= rune #.(char-code #\_))
+                   (= rune #.(char-code #\:))
+                   (combining-rune-p rune)
+                   (extender-rune-p rune)))
+
+             (letter-rune-p (rune)
+               (or (base-rune-p rune)
+                   (ideographic-rune-p rune)))
+
+             (digit-rune-p* (rune)
+               (rune-in-range-p rune digit-ranges))
+
+
+             (combining-rune-p (rune)
+               (rune-in-range-p rune combining-char-ranges))
+
+             (extender-rune-p (rune)
+               (rune-in-range-p rune extender-ranges))
+
+             (base-rune-p (rune)
+               (rune-in-range-p rune base-char-ranges))
+
+             (ideographic-rune-p (rune)
+               (rune-in-range-p rune ideographic-ranges))
+
+
+             (predicate-to-bv (p)
+               (let ((r (make-array +max+ :element-type 'bit :initial-element 0)))
+                 (dotimes (i +max+ r)
+                   (when (funcall p i)
+                     (setf (aref r i) 1))))) )
+
+          `(progn
+	    (DEFINLINE NAME-RUNE-P (RUNE)
+	      (SETF RUNE (RUNE-CODE RUNE))
+	      (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))
+				(type fixnum rune))
+		(AND (<= 0 RUNE ,+max+)
+		     (= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
+				RUNE)))))
+	    (DEFINLINE NAME-START-RUNE-P (RUNE)
+	      (SETF RUNE (RUNE-CODE RUNE))
+	      (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))
+				(type fixnum rune))
+		(AND (<= 0 RUNE ,+MAX+)
+		     (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
+				RUNE)))))
+	    (definline valid-name-p (rod)
+	      (and (plusp (length rod))
+		   (name-start-rune-p (elt rod 0))
+		   (every #'name-rune-p rod)))
+	    (definline valid-nmtoken-p (rod)
+	      (and (plusp (length rod))
+		   (every #'name-rune-p rod)))))))))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-parse.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xml-parse.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,3732 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CXML; readtable: runes; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: XML parser
+;;;   Created: 1999-07-17
+;;;    Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
+;;;    Author: Henrik Motakef <hmot at henrik-motakef.de>
+;;;    Author: David Lichteblau <david at lichteblau.com>
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 1999 by Gilbert Baumann
+;;;  (c) copyright 2003 by Henrik Motakef
+;;;  (c) copyright 2004 knowledgeTools Int. GmbH
+;;;  (c) copyright 2004 David Lichteblau
+;;;  (c) copyright 2005 David Lichteblau
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA  02111-1307  USA.
+
+;;; Streams
+
+;;; xstreams
+
+;; For reading runes, I defined my own streams, called xstreams,
+;; because we want to be fast. A function call or even a method call
+;; per character is not acceptable, instead of that we define a
+;; buffered stream with and advertised buffer layout, so that we
+;; could use the trick stdio uses: READ-RUNE and PEEK-RUNE are macros,
+;; directly accessing the buffer and only calling some underflow
+;; handler in case of stream underflows. This will yield to quite a
+;; performance boost vs calling READ-BYTE per character.
+
+;; Also we need to do encoding t conversion on ; this better done at large chunks of data rather than on a character
+;; by character basis. This way we need a dispatch on the active
+;; encoding only once in a while, instead of for each character. This
+;; allows us to use a CLOS interface to do the underflow handling.
+
+;;; zstreams
+
+;; Now, for reading tokens, we define another kind of streams, called
+;; zstreams. These zstreams also maintain an input stack to implement
+;; inclusion of external entities. This input stack contains xstreams
+;; or the special marker :STOP. Such a :STOP marker indicates, that
+;; input should not continue there, but well stop; that is simulate an
+;; EOF. The user is then responsible to pop this marker off the input
+;; stack.
+;;
+;; This input stack is also used to detect circular entity inclusion.
+
+;; The zstream tokenizer recognizes the following types of tokens and
+;; is controlled by the *DATA-BEHAVIOUR* flag. (Which should become a
+;; slot of zstreams instead).
+
+;; Common
+;;    :xml-decl (<target> . <content>)    ;processing-instruction starting with "<?xml"
+;;    :pi (<target> . <content>)        ;processing-instruction
+;;    :stag (<name> . <atts>)           ;start tag
+;;    :etag (<name> . <atts>)           ;end tag
+;;    :ztag (<name> . <atts>)           ;empty tag
+;;    :<!ELEMENT
+;;    :<!ENTITY
+;;    :<!ATTLIST
+;;    :<!NOTATION
+;;    :<!DOCTYPE
+;;    :<![
+;;    :comment <content>
+
+;; *data-behaviour* = :DTD
+;;
+;;    :nmtoken <interned-rod>
+;;    :#required
+;;    :#implied
+;;    :#fixed
+;;    :#pcdata
+;;    :s
+;;    :\[ :\] :\( :\) :|\ :\> :\" :\' :\, :\? :\* :\+
+
+;; *data-behaviour* = :DOC
+;;
+;;    :entity-ref <interned-rod>
+;;    :cdata <rod>
+
+
+;;; TODO
+;;
+;; o provide for a faster DOM
+;;
+;; o morph zstream into a context object and thus also get rid of
+;;   special variables. Put the current DTD there too.
+;;   [partly done]
+
+;; o the *scratch-pad* hack should become something much more
+;;   reentrant, we could either define a system-wide resource
+;;   or allocate some scratch-pads per context.
+;;   [for thread-safety reasons the array are allocated per context now,
+;;   reentrancy is still open]
+
+;; o CR handling in utf-16 deocders
+;;
+;; o UCS-4 reader
+;;
+;; o max depth together with circle detection
+;;   (or proof, that our circle detection is enough).
+;;   [gemeint ist zstream-push--david]
+;;
+;; o better extensibility wrt character representation, one may want to
+;;   have
+;;    - UCS-4  in vectoren
+;;
+;; o xstreams auslagern, documententieren und dann auch in SGML und
+;;   CSS parser verwenden. (halt alles was zeichen liest).
+;;   [ausgelagert sind sie; dokumentiert "so la la"; die Reintegration
+;;   in Closure ist ein ganz anderes Thema]
+;;
+;; o recording of source locations for nodes.
+;;
+;; o based on the DTD and xml:space attribute implement HTML white
+;;   space rules.
+;;
+;; o on a parser option, do not expand external entities.
+
+;;;; Validity constraints:
+;;;; (00) Root Element Type                     like (03), c.f. MAKE-ROOT-MODEL
+;;;; (01) Proper Declaration/PE Nesting         P/MARKUP-DECL
+;;;; (02) Standalone Document Declaration       all over the place [*]
+;;;; (03) Element Valid                         VALIDATE-*-ELEMENT, -CHARACTERS
+;;;; (04) Attribute Value Type                  VALIDATE-ATTRIBUTE
+;;;; (05) Unique Element Type Declaration       DEFINE-ELEMENT
+;;;; (06) Proper Group/PE Nesting               P/CSPEC
+;;;; (07) No Duplicate Types                    LEGAL-CONTENT-MODEL-P
+;;;; (08) ID                                    VALIDATE-ATTRIBUTE
+;;;; (09) One ID per Element Type               DEFINE-ATTRIBUTE
+;;;; (10) ID Attribute Default                  DEFINE-ATTRIBUTE
+;;;; (11) IDREF                                 VALIDATE-ATTRIBUTE, P/DOCUMENT
+;;;; (12) Entity Name                           VALIDATE-ATTRIBUTE
+;;;; (13) Name Token                            VALIDATE-ATTRIBUTE
+;;;; (14) Notation Attributes                   VALIDATE-ATTRIBUTE, P/ATT-TYPE
+;;;; (15) One Notation Per Element Type         DEFINE-ATTRIBUTE
+;;;; (16) No Notation on Empty Element          DEFINE-ELEMENT, -ATTRIBUTE
+;;;; (17) Enumeration                           VALIDATE-ATTRIBUTE
+;;;; (18) Required Attribute                    PROCESS-ATTRIBUTES
+;;;; (19) Attribute Default Legal               DEFINE-ATTRIBUTE
+;;;; (20) Fixed Attribute Default               VALIDATE-ATTRIBUTE
+;;;; (21) Proper Conditional Section/PE Nesting P/CONDITIONAL-SECT, ...
+;;;; (22) Entity Declared                       [**]
+;;;; (23) Notation Declared                     P/ENTITY-DEF, P/DOCUMENT
+;;;; (24) Unique Notation Name                  DEFINE-NOTATION
+;;;;
+;;;; [*] Perhaps we could revert the explicit checks of (02), if we did
+;;;; _not_ read external subsets of standalone documents when parsing in
+;;;; validating mode.  Violations of VC (02) constraints would then appear as
+;;;; wellformedness violations, right?
+;;;;
+;;;; [**] Although I haven't investigated this properly yet, I believe that
+;;;; we check this VC together with the WFC even in non-validating mode.
+
+(in-package :cxml)
+
+#+allegro
+(setf (excl:named-readtable :runes) *readtable*)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *fast* '(optimize (speed 3) (safety 0)))
+  ;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
+  )
+
+;;; parser context
+
+(defvar *ctx* nil)
+
+(defstruct (context (:conc-name nil))
+  handler
+  (dtd nil)
+  model-stack
+  ;; xml:base machen wir fuer klacks mal gleich als expliziten stack:
+  base-stack
+  (referenced-notations '())
+  (id-table (%make-rod-hash-table))
+  ;; FIXME: Wofuer ist name-hashtable da?  Will man das wissen?
+  (name-hashtable (make-rod-hashtable :size 2000))
+  (standalone-p nil)
+  (entity-resolver nil)
+  (disallow-internal-subset nil)
+  main-zstream)
+
+(defvar *expand-pe-p* nil)
+
+(defparameter *initial-namespace-bindings*
+  '((#"" . nil)
+    (#"xmlns" . #"http://www.w3.org/2000/xmlns/")
+    (#"xml" . #"http://www.w3.org/XML/1998/namespace")))
+
+(defparameter *namespace-bindings* *initial-namespace-bindings*)
+
+;;;; ---------------------------------------------------------------------------
+;;;; xstreams
+;;;;
+
+
+(defstruct (stream-name
+	    (:print-function print-stream-name))
+  entity-name
+  entity-kind
+  uri)
+
+(defun print-stream-name (object stream depth)
+  (declare (ignore depth))
+  (format stream "[~A ~S ~A]"
+	  (rod-string (stream-name-entity-name object))
+	  (stream-name-entity-kind object)
+	  (stream-name-uri object)))
+
+(deftype read-element () 'rune)
+
+(defun call-with-open-xstream (fn stream)
+  (unwind-protect
+      (funcall fn stream)
+    (close-xstream stream)))
+
+(defmacro with-open-xstream ((var value) &body body)
+  `(call-with-open-xstream (lambda (,var) , at body) ,value))
+
+(defun call-with-open-xfile (continuation &rest open-args)
+  (let ((input (apply #'open (car open-args) :element-type '(unsigned-byte 8) (cdr open-args))))
+    (unwind-protect
+        (progn
+          (funcall continuation (make-xstream input)))
+      (close input))))
+
+(defmacro with-open-xfile ((stream &rest open-args) &body body)
+  `(call-with-open-xfile (lambda (,stream) .,body) .,open-args))
+
+;;;; -------------------------------------------------------------------
+;;;; Rechnen mit Runen
+;;;;
+
+;; Let us first define fast fixnum arithmetric get rid of type
+;; checks. (After all we know what we do here).
+
+(defmacro fx-op (op &rest xs)
+  `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
+(defmacro fx-pred (op &rest xs)
+  `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
+
+(defmacro %+   (&rest xs) `(fx-op + , at xs))
+(defmacro %-   (&rest xs) `(fx-op - , at xs))
+(defmacro %*   (&rest xs) `(fx-op * , at xs))
+(defmacro %/   (&rest xs) `(fx-op floor , at xs))
+(defmacro %and (&rest xs) `(fx-op logand , at xs))
+(defmacro %ior (&rest xs) `(fx-op logior , at xs))
+(defmacro %xor (&rest xs) `(fx-op logxor , at xs))
+(defmacro %ash (&rest xs) `(fx-op ash , at xs))
+(defmacro %mod (&rest xs) `(fx-op mod , at xs))
+
+(defmacro %=  (&rest xs)  `(fx-pred = , at xs))
+(defmacro %<= (&rest xs)  `(fx-pred <= , at xs))
+(defmacro %>= (&rest xs)  `(fx-pred >= , at xs))
+(defmacro %<  (&rest xs)  `(fx-pred < , at xs))
+(defmacro %>  (&rest xs)  `(fx-pred > , at xs))
+
+;;; XXX Geschwindigkeit dieser Definitionen untersuchen!
+
+(defmacro rune-op (op &rest xs)
+  `(code-rune (,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs))))
+(defmacro rune-pred (op &rest xs)
+  `(,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs)))
+
+(defmacro %rune+   (&rest xs) `(rune-op + , at xs))
+(defmacro %rune-   (&rest xs) `(rune-op - , at xs))
+(defmacro %rune*   (&rest xs) `(rune-op * , at xs))
+(defmacro %rune/   (&rest xs) `(rune-op floor , at xs))
+(defmacro %rune-and (&rest xs) `(rune-op logand , at xs))
+(defmacro %rune-ior (&rest xs) `(rune-op logior , at xs))
+(defmacro %rune-xor (&rest xs) `(rune-op logxor , at xs))
+(defmacro %rune-ash (a b) `(code-rune (ash (rune-code ,a) ,b)))
+(defmacro %rune-mod (&rest xs) `(rune-op mod , at xs))
+
+(defmacro %rune=  (&rest xs)  `(rune-pred = , at xs))
+(defmacro %rune<= (&rest xs)  `(rune-pred <= , at xs))
+(defmacro %rune>= (&rest xs)  `(rune-pred >= , at xs))
+(defmacro %rune<  (&rest xs)  `(rune-pred < , at xs))
+(defmacro %rune>  (&rest xs)  `(rune-pred > , at xs))
+
+;;;; ---------------------------------------------------------------------------
+;;;; rod hashtable
+;;;;
+
+;;; make-rod-hashtable
+;;; rod-hash-get hashtable rod &optional start end -> value ; successp
+;;; (setf (rod-hash-get hashtable rod &optional start end) new-value
+;;;
+
+(defstruct (rod-hashtable (:constructor make-rod-hashtable/low))
+  size          ;size of table
+  table         ;
+  )
+
+(defun make-rod-hashtable (&key (size 200))
+  (setf size (nearest-greater-prime size))
+  (make-rod-hashtable/low
+   :size size
+   :table (make-array size :initial-element nil)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant +fixnum-bits+
+      (1- (integer-length most-positive-fixnum))
+    "Pessimistic approximation of the number of bits of fixnums.")
+
+  (defconstant +fixnum-mask+
+      (1- (expt 2 +fixnum-bits+))
+    "Pessimistic approximation of the largest bit-mask, still being a fixnum."))
+
+(definline stir (a b)
+  (%and +fixnum-mask+
+        (%xor (%ior (%ash (%and a #.(ash +fixnum-mask+ -5)) 5)
+                    (%ash a #.(- 5 +fixnum-bits+)))
+              b)))
+
+(definline rod-hash (rod start end)
+  "Compute a hash code out of a rod."
+  (let ((res (%- end start)))
+    (do ((i start (%+ i 1)))
+        ((%= i end))
+      (declare (type fixnum i))
+      (setf res (stir res (rune-code (%rune rod i)))))
+    res))
+
+(definline rod=* (x y &key (start1 0) (end1 (length x))
+                          (start2 0) (end2 (length y)))
+  (and (%= (%- end1 start1) (%- end2 start2))
+       (do ((i start1 (%+ i 1))
+            (j start2 (%+ j 1)))
+           ((%= i end1)
+            t)
+         (unless (rune= (%rune x i) (%rune y j))
+           (return nil)))))
+
+(definline rod=** (x y start1 end1 start2 end2)
+  (and (%= (%- end1 start1) (%- end2 start2))
+       (do ((i start1 (%+ i 1))
+            (j start2 (%+ j 1)))
+           ((%= i end1)
+            t)
+         (unless (rune= (%rune x i) (%rune y j))
+           (return nil)))))
+
+(defun rod-hash-get (hashtable rod &optional (start 0) (end (length rod)))
+  (declare (type (simple-array rune (*)) rod))
+  (let ((j (%mod (rod-hash rod start end)
+                 (rod-hashtable-size hashtable))))
+    (dolist (q (svref (rod-hashtable-table hashtable) j)
+               (values nil nil nil))
+      (declare (type cons q))
+      (when (rod=** (car q) rod 0 (length (the (simple-array rune (*)) (car q))) start end)
+        (return (values (cdr q) t (car q)))))))
+
+(defun rod-hash-set (new-value hashtable rod &optional (start 0) (end (length rod)))
+  (let ((j (%mod (rod-hash rod start end)
+                 (rod-hashtable-size hashtable)))
+        (key nil))
+    (dolist (q (svref (rod-hashtable-table hashtable) j)
+              (progn
+                (setf key (rod-subseq* rod start end))
+                (push (cons key new-value)
+                      (aref (rod-hashtable-table hashtable) j))))
+      (when (rod=* (car q) rod :start2 start :end2 end)
+        (setf key (car q))
+        (setf (cdr q) new-value)
+        (return)))
+    (values new-value key)))
+
+#-rune-is-character
+(defun rod-subseq* (source start &optional (end (length source)))
+  (unless (and (typep start 'fixnum) (>= start 0))
+    (error "~S is not a non-negative fixnum." start))
+  (unless (and (typep end 'fixnum) (>= end start))
+    (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
+  (when (> start (length source))
+    (error "START argument, ~S, should be no greater than length of rod." start))
+  (when (> end (length source))
+    (error "END argument, ~S, should be no greater than length of rod." end))
+  (locally
+      (declare (type fixnum start end))
+    (let ((res (make-rod (- end start))))
+      (declare (type rod res))
+      (do ((i (- (- end start) 1) (the fixnum (- i 1))))
+          ((< i 0) res)
+        (declare (type fixnum i))
+        (setf (%rune res i) (aref source (the fixnum (+ i start))))))))
+
+#+rune-is-character
+(defun rod-subseq* (source start &optional (end (length source)))
+  (subseq source start end))
+
+(deftype ufixnum () `(unsigned-byte ,(integer-length most-positive-fixnum)))
+
+#-rune-is-character
+(defun rod-subseq** (source start &optional (end (length source)))
+  (declare (type (simple-array rune (*)) source)
+           (type ufixnum start)
+           (type ufixnum end)
+           (optimize (speed 3) (safety 0)))
+  (let ((res (make-array (%- end start) :element-type 'rune)))
+    (declare (type (simple-array rune (*)) res))
+    (let ((i (%- end start)))
+      (declare (type ufixnum i))
+      (loop
+        (setf i (- i 1))
+        (when (= i 0)
+          (return))
+        (setf (%rune res i) (%rune source (the ufixnum (+ i start))))))
+    res))
+
+#+rune-is-character
+(defun rod-subseq** (source start &optional (end (length source)))
+  (subseq source start end))
+
+(defun (setf rod-hash-get) (new-value hashtable rod &optional (start 0) (end (length rod)))
+  (rod-hash-set new-value hashtable rod start end))
+
+(defun intern-name (rod &optional (start 0) (end (length rod)))
+  (multiple-value-bind (value successp key) (rod-hash-get (name-hashtable *ctx*) rod start end)
+    (declare (ignore value))
+    (if successp
+        key
+      (nth-value 1 (rod-hash-set t (name-hashtable *ctx*) rod start end)))))
+
+;;;; ---------------------------------------------------------------------------
+;;;;
+;;;;  rod collector
+;;;;
+
+(defvar *scratch-pad*)
+(defvar *scratch-pad-2*)
+(defvar *scratch-pad-3*)
+(defvar *scratch-pad-4*)
+
+(declaim (type (simple-array rune (*))
+               *scratch-pad* *scratch-pad-2* *scratch-pad-3* *scratch-pad-4*))
+
+(defmacro with-scratch-pads ((&optional) &body body)
+  `(let ((*scratch-pad* (make-array 1024 :element-type 'rune))
+         (*scratch-pad-2* (make-array 1024 :element-type 'rune))
+         (*scratch-pad-3* (make-array 1024 :element-type 'rune))
+         (*scratch-pad-4* (make-array 1024 :element-type 'rune)))
+     , at body))
+
+(defmacro %put-unicode-char (code-var put)
+  `(progn
+     (cond ((%> ,code-var #xFFFF)
+          (,put (the rune (code-rune (%+ #xD7C0 (%ash ,code-var -10)))))
+          (,put (the rune (code-rune (%ior #xDC00 (%and ,code-var #x03FF))))))
+         (t
+          (,put (code-rune ,code-var))))))
+
+(defun adjust-array-by-copying (old-array new-size)
+  "Adjust an array by copying and thus ensures, that result is a SIMPLE-ARRAY."
+  (let ((res (make-array new-size :element-type (array-element-type old-array))))
+    (replace res old-array
+             :start1 0 :end1 (length old-array)
+             :start2 0 :end2 (length old-array))
+    res))
+
+(defmacro with-rune-collector-aux (scratch collect body mode)
+  (let ((rod (gensym))
+        (n (gensym))
+        (i (gensym))
+        (b (gensym)))
+    `(let ((,n (length ,scratch))
+           (,i 0)
+           (,b ,scratch))
+       (declare (type fixnum ,n ,i))
+       (macrolet
+           ((,collect (x)
+              `((lambda (x)
+                  (locally
+                      (declare #.*fast*)
+                    (when (%>= ,',i ,',n)
+                      (setf ,',n (* 2 ,',n))
+                      (setf ,',b
+                            (setf ,',scratch
+                                  (adjust-array-by-copying ,',scratch ,',n))))
+                    (setf (aref (the (simple-array rune (*)) ,',b) ,',i) x)
+                    (incf ,',i)))
+                ,x)))
+         , at body
+         ,(ecase mode
+            (:intern
+             `(intern-name ,b 0 ,i))
+            (:copy
+             `(let ((,rod (make-rod ,i)))
+                (while (not (%= ,i 0))
+                       (setf ,i (%- ,i 1))
+                       (setf (%rune ,rod ,i)
+                         (aref (the (simple-array rune (*)) ,b) ,i)))
+                ,rod))
+            (:raw
+             `(values ,b 0 ,i))
+            )))))
+
+'(defmacro with-rune-collector-aux (scratch collect body mode)
+  (let ((rod (gensym))
+        (n (gensym))
+        (i (gensym))
+        (b (gensym)))
+    `(let ((,n (length ,scratch))
+           (,i 0))
+       (declare (type fixnum ,n ,i))
+       (macrolet
+           ((,collect (x)
+              `((lambda (x)
+                  (locally
+                      (declare #.*fast*)
+                    (when (%>= ,',i ,',n)
+                      (setf ,',n (* 2 ,',n))
+                      (setf ,',scratch
+                            (setf ,',scratch
+                                  (adjust-array-by-copying ,',scratch ,',n))))
+                    (setf (aref (the (simple-array rune (*)) ,',scratch) ,',i) x)
+                    (incf ,',i)))
+                ,x)))
+         , at body
+         ,(ecase mode
+            (:intern
+             `(intern-name ,scratch 0 ,i))
+            (:copy
+             `(let ((,rod (make-rod ,i)))
+                (while (%> ,i 0)
+                       (setf ,i (%- ,i 1))
+                       (setf (%rune ,rod ,i)
+                         (aref (the (simple-array rune (*)) ,scratch) ,i)))
+                ,rod))
+            (:raw
+             `(values ,scratch 0 ,i))
+            )))))
+
+(defmacro with-rune-collector ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad* ,collect ,body :copy))
+
+(defmacro with-rune-collector-2 ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad-2* ,collect ,body :copy))
+
+(defmacro with-rune-collector-3 ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad-3* ,collect ,body :copy))
+
+(defmacro with-rune-collector-4 ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad-4* ,collect ,body :copy))
+
+(defmacro with-rune-collector/intern ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad* ,collect ,body :intern))
+
+(defmacro with-rune-collector/raw ((collect) &body body)
+  `(with-rune-collector-aux *scratch-pad* ,collect ,body :raw))
+
+#|
+(defmacro while-reading-runes ((reader stream-in) &rest body)
+  ;; Thou shalt not leave body via a non local exit
+  (let ((stream (make-symbol "STREAM"))
+        (rptr (make-symbol "RPTR"))
+        (fptr (make-symbol "FPTR"))
+        (buf  (make-symbol "BUF")) )
+    `(let* ((,stream ,stream-in)
+            (,rptr (xstream-read-ptr ,stream))
+            (,fptr (xstream-fill-ptr ,stream))
+            (,buf  (xstream-buffer ,stream)))
+       (declare (type fixnum ,rptr ,fptr)
+                (type xstream ,stream))
+       (macrolet ((,reader (res-var)
+                    `(cond ((%= ,',rptr ,',fptr)
+                            (setf (xstream-read-ptr ,',stream) ,',rptr)
+                            (setf ,res-var (xstream-underflow ,',stream))
+                            (setf ,',rptr (xstream-read-ptr ,',stream))
+                            (setf ,',fptr (xstream-fill-ptr ,',stream))
+                            (setf ,',buf  (xstream-buffer ,',stream)))
+                           (t
+                            (setf ,res-var
+                              (aref (the (simple-array read-element (*)) ,',buf)
+                                    (the fixnum ,',rptr)))
+                            (setf ,',rptr (%+ ,',rptr 1))))))
+         (prog1
+             (let () .,body)
+           (setf (xstream-read-ptr ,stream) ,rptr) )))))
+|#
+
+;;;;  ---------------------------------------------------------------------------
+;;;;  DTD
+;;;;
+
+(define-condition xml-parse-error (simple-error) ())
+(define-condition well-formedness-violation (xml-parse-error) ())
+(define-condition validity-error (xml-parse-error) ())
+
+;; We make some effort to signal end of file as a special condition, but we
+;; don't actually try very hard.  Not sure whether we should.  Right now I
+;; would prefer not to document this class.
+(define-condition end-of-xstream (well-formedness-violation) ())
+
+(defun describe-xstream (x s)
+  (format s "  Line ~D, column ~D in ~A~%"
+	  (xstream-line-number x)
+	  (xstream-column-number x)
+	  (let ((name (xstream-name x)))
+	    (cond
+	      ((null name)
+		"<anonymous stream>")
+	      ((eq :main (stream-name-entity-kind name))
+		(stream-name-uri name))
+	      (t
+		name)))))
+
+(defun %error (class stream message)
+  (let* ((zmain (if *ctx* (main-zstream *ctx*) nil))
+	 (zstream (if (zstream-p stream) stream zmain))
+	 (xstream (if (xstream-p stream) stream nil))
+	 (s (make-string-output-stream)))
+    (write-line message s)
+    (when xstream
+      (write-line "Location:" s)
+      (describe-xstream xstream s))
+    (when zstream
+      (let ((stack
+	     (remove xstream (remove :stop (zstream-input-stack zstream)))))
+	(when stack
+	  (write-line "Context:" s)
+	  (dolist (x stack)
+	    (describe-xstream x s)))))
+    (when (and zmain (not (eq zstream zmain)))
+      (let ((stack
+	     (remove xstream (remove :stop (zstream-input-stack zmain)))))
+	(when stack
+	  (write-line "Context in main document:" s)
+	  (dolist (x stack)
+	    (describe-xstream x s)))))
+    (error class
+	   :format-control "~A"
+	   :format-arguments (list (get-output-stream-string s)))))
+
+(defun validity-error (fmt &rest args)
+  (%error 'validity-error
+	  nil
+	  (format nil "Document not valid: ~?" fmt args)))
+
+(defun wf-error (stream fmt &rest args)
+  (%error 'well-formedness-violation
+	  stream
+	  (format nil "Document not well-formed: ~?" fmt args)))
+
+(defun eox (stream &optional x &rest args)
+  (%error 'end-of-xstream
+	  stream
+	  (format nil "End of file~@[: ~?~]" x args)))
+
+(defclass cxml-parser (sax:sax-parser) ((ctx :initarg :ctx)))
+
+(defun parser-xstream (parser)
+  (car (zstream-input-stack (main-zstream (slot-value parser 'ctx)))))
+
+(defun parser-stream-name (parser)
+  (let ((xstream (parser-xstream parser)))
+    (if xstream
+	(xstream-name xstream)
+	nil)))
+
+(defmethod sax:line-number ((parser cxml-parser))
+  (let ((x (parser-xstream parser)))
+    (if x
+	(xstream-line-number x)
+	nil)))
+
+(defmethod sax:column-number ((parser cxml-parser))
+  (let ((x (parser-xstream parser)))
+    (if x
+	(xstream-column-number x)
+	nil)))
+
+(defmethod sax:system-id ((parser cxml-parser))
+  (let ((name (parser-stream-name parser)))
+    (if name
+	(stream-name-uri name)
+	nil)))
+
+(defmethod sax:xml-base ((parser cxml-parser))
+  (car (base-stack (slot-value parser 'ctx))))
+
+(defvar *validate* t)
+(defvar *external-subset-p* nil)
+
+(defun validate-start-element (ctx name)
+  (when *validate*
+    (let* ((pair (car (model-stack ctx)))
+           (newval (funcall (car pair) name)))
+      (unless newval
+        (validity-error "(03) Element Valid: ~A" (rod-string name)))
+      (setf (car pair) newval)
+      (let ((e (find-element name (dtd ctx))))
+        (unless e
+          (validity-error "(03) Element Valid: no definition for ~A"
+                          (rod-string name)))
+        (maybe-compile-cspec e)
+        (push (copy-cons (elmdef-compiled-cspec e)) (model-stack ctx))))))
+
+(defun copy-cons (x)
+  (cons (car x) (cdr x)))
+
+(defun validate-end-element (ctx name)
+  (when *validate*
+    (let ((pair (car (model-stack ctx))))
+      (unless (eq (funcall (car pair) nil) t)
+        (validity-error "(03) Element Valid: ~A" (rod-string name)))
+      (pop (model-stack ctx)))))
+
+(defun validate-characters (ctx rod)
+  (when *validate*
+    (let ((pair (car (model-stack ctx))))
+      (unless (funcall (cdr pair) rod)
+        (validity-error "(03) Element Valid: unexpected PCDATA")))))
+
+(defun standalone-check-necessary-p (def)
+  (and *validate*
+       (standalone-p *ctx*)
+       (etypecase def
+         (elmdef (elmdef-external-p def))
+         (attdef (attdef-external-p def)))))
+
+;; attribute validation, defaulting, and normalization -- except for for
+;; uniqueness checks, which are done after namespaces have been declared
+(defun process-attributes (ctx name attlist)
+  (let ((e (find-element name (dtd ctx))))
+    (cond
+      (e
+        (dolist (ad (elmdef-attributes e)) ;handle default values
+          (unless (get-attribute (attdef-name ad) attlist)
+            (case (attdef-default ad)
+              (:IMPLIED)
+              (:REQUIRED
+                (when *validate*
+                  (validity-error "(18) Required Attribute: ~S not specified"
+                                  (rod-string (attdef-name ad)))))
+              (t
+                (when (standalone-check-necessary-p ad)
+                  (validity-error "(02) Standalone Document Declaration: missing attribute value"))
+                (push (sax:make-attribute :qname (attdef-name ad)
+					  :value (cadr (attdef-default ad))
+					  :specified-p nil)
+                      attlist)))))
+        (dolist (a attlist)		;normalize non-CDATA values
+          (let* ((qname (sax:attribute-qname a))
+                 (adef (find-attribute e qname)))
+	    (when adef
+	      (when (and *validate*
+			 sax:*namespace-processing*
+			 (eq (attdef-type adef) :ID)
+			 (find #/: (sax:attribute-value a)))
+		(validity-error "colon in ID attribute"))
+	      (unless (eq (attdef-type adef) :CDATA)
+		(let ((canon (canon-not-cdata-attval (sax:attribute-value a))))
+		  (when (and (standalone-check-necessary-p adef)
+			     (not (rod= (sax:attribute-value a) canon)))
+		    (validity-error "(02) Standalone Document Declaration: attribute value not normalized"))
+		  (setf (sax:attribute-value a) canon))))))
+        (when *validate*		;maybe validate attribute values
+          (dolist (a attlist)
+            (validate-attribute ctx e a))))
+      ((and *validate* attlist)
+        (validity-error "(04) Attribute Value Type: no definition for element ~A"
+                        (rod-string name)))))
+  attlist)
+
+(defun get-attribute (name attributes)
+  (member name attributes :key #'sax:attribute-qname :test #'rod=))
+
+(defun validate-attribute (ctx e a)
+  (when (sax:attribute-specified-p a)   ;defaults checked by DEFINE-ATTRIBUTE
+    (let* ((qname (sax:attribute-qname a))
+           (adef
+            (or (find-attribute e qname)
+                (validity-error "(04) Attribute Value Type: not declared: ~A"
+                                (rod-string qname)))))
+      (validate-attribute* ctx adef (sax:attribute-value a)))))
+
+(defun validate-attribute* (ctx adef value)
+  (let ((type (attdef-type adef))
+        (default (attdef-default adef)))
+    (when (and (listp default)
+               (eq (car default) :FIXED)
+               (not (rod= value (cadr default))))
+      (validity-error "(20) Fixed Attribute Default: expected ~S but got ~S"
+                      (rod-string (cadr default))
+                      (rod-string value)))
+    (ecase (if (listp type) (car type) type)
+      (:ID
+        (unless (valid-name-p value)
+          (validity-error "(08) ID: not a name: ~S" (rod-string value)))
+        (when (eq (gethash value (id-table ctx)) t)
+          (validity-error "(08) ID: ~S not unique" (rod-string value)))
+        (setf (gethash value (id-table ctx)) t))
+      (:IDREF
+        (validate-idref ctx value))
+      (:IDREFS
+        (let ((names (split-names value)))
+          (unless names
+            (validity-error "(11) IDREF: malformed names"))
+          (mapc (curry #'validate-idref ctx) names)))
+      (:NMTOKEN
+        (validate-nmtoken value))
+      (:NMTOKENS
+        (let ((tokens (split-names value)))
+          (unless tokens
+            (validity-error "(13) Name Token: malformed NMTOKENS"))
+          (mapc #'validate-nmtoken tokens)))
+      (:ENUMERATION
+        (unless (member value (cdr type) :test #'rod=)
+          (validity-error "(17) Enumeration: value not declared: ~S"
+                          (rod-string value))))
+      (:NOTATION
+        (unless (member value (cdr type) :test #'rod=)
+          (validity-error "(14) Notation Attributes: ~S" (rod-string value))))
+      (:ENTITY
+        (validate-entity value))
+      (:ENTITIES
+        (let ((names (split-names value)))
+          (unless names
+            (validity-error "(13) Name Token: malformed NMTOKENS"))
+          (mapc #'validate-entity names)))
+      (:CDATA))))
+
+(defun validate-idref (ctx value)
+  (unless (valid-name-p value)
+    (validity-error "(11) IDREF: not a name: ~S" (rod-string value)))
+  (unless (gethash value (id-table ctx))
+    (setf (gethash value (id-table ctx)) nil)))
+
+(defun validate-nmtoken (value)
+  (unless (valid-nmtoken-p value)
+    (validity-error "(13) Name Token: not a NMTOKEN: ~S"
+                    (rod-string value))))
+
+(defstruct (entdef (:constructor)))
+
+(defstruct (internal-entdef
+            (:include entdef)
+            (:constructor make-internal-entdef (value))
+            (:conc-name #:entdef-))
+  (value (error "missing argument") :type rod)
+  (expansion nil)
+  (external-subset-p *external-subset-p*))
+
+(defstruct (external-entdef
+            (:include entdef)
+            (:constructor make-external-entdef (extid ndata))
+            (:conc-name #:entdef-))
+  (extid (error "missing argument") :type extid)
+  (ndata nil :type (or rod null)))
+
+(defun validate-entity (value)
+  (unless (valid-name-p value)
+    (validity-error "(12) Entity Name: not a name: ~S" (rod-string value)))
+  (let ((def (let ((*validate*
+                    ;; Similarly the entity refs are internal and
+                    ;; don't need normalization ... the unparsed
+                    ;; entities (and entities) aren't "references"
+                    ;;   -- sun/valid/sa03.xml
+                    nil))
+               (get-entity-definition value :general (dtd *ctx*)))))
+    (unless (and (typep def 'external-entdef) (entdef-ndata def))
+      ;; unparsed entity
+      (validity-error "(12) Entity Name: ~S" (rod-string value)))))
+
+(defun split-names (rod)
+  (flet ((whitespacep (x)
+           (or (rune= x #/U+0009)
+               (rune= x #/U+000A)
+               (rune= x #/U+000D)
+               (rune= x #/U+0020))))
+    (if (let ((n (length rod)))
+          (and (not (zerop n))
+               (or (whitespacep (rune rod 0))
+                   (whitespacep (rune rod (1- n))))))
+        nil
+        (split-sequence-if #'whitespacep rod :remove-empty-subseqs t))))
+
+(defun zstream-base-sysid (zstream)
+  (let ((base-sysid
+         (dolist (k (zstream-input-stack zstream))
+           (let ((base-sysid (stream-name-uri (xstream-name k))))
+             (when base-sysid (return base-sysid))))))
+    base-sysid))
+
+(defun absolute-uri (sysid source-stream)
+  (let ((base-sysid (zstream-base-sysid source-stream)))
+    ;; XXX is the IF correct?
+    (if base-sysid
+        (puri:merge-uris sysid base-sysid)
+        sysid)))
+
+(defstruct (extid (:constructor make-extid (public system)))
+  (public nil :type (or rod null))
+  (system (error "missing argument") :type (or puri:uri null)))
+
+(defun absolute-extid (source-stream extid)
+  (let ((sysid (extid-system extid))
+        (result (copy-extid extid)))
+    (setf (extid-system result) (absolute-uri sysid source-stream))
+    result))
+
+(defun define-entity (source-stream name kind def)
+  (setf name (intern-name name))
+  (when (and sax:*namespace-processing* (find #/: name))
+    (wf-error source-stream "colon in entity name"))
+  (let ((table
+         (ecase kind
+           (:general (dtd-gentities (dtd *ctx*)))
+           (:parameter (dtd-pentities (dtd *ctx*))))))
+    (unless (gethash name table)
+      (when (and source-stream (handler *ctx*))
+        (report-entity (handler *ctx*) kind name def))
+      (when (typep def 'external-entdef)
+        (setf (entdef-extid def)
+              (absolute-extid source-stream (entdef-extid def))))
+      (setf (gethash name table)
+            (cons *external-subset-p* def)))))
+
+(defun get-entity-definition (entity-name kind dtd)
+  (unless dtd
+    (wf-error nil "entity not defined: ~A" (rod-string entity-name)))
+  (destructuring-bind (extp &rest def)
+      (gethash entity-name
+               (ecase kind
+                 (:general (dtd-gentities dtd))
+                 (:parameter (dtd-pentities dtd)))
+               '(nil))
+    (when (and *validate* (standalone-p *ctx*) extp)
+      (validity-error "(02) Standalone Document Declaration: entity reference: ~S"
+                      (rod-string entity-name)))
+    def))
+
+(defun entity->xstream (zstream entity-name kind &optional internalp)
+  ;; `zstream' is for error messages
+  (let ((def (get-entity-definition entity-name kind (dtd *ctx*))))
+    (unless def
+      (wf-error zstream "Entity '~A' is not defined." (rod-string entity-name)))
+    (let (r)
+      (etypecase def
+        (internal-entdef
+	 (when (and (standalone-p *ctx*)
+		    (entdef-external-subset-p def))
+	   (wf-error
+	    zstream
+	    "entity declared in external subset, but document is standalone"))
+         (setf r (make-rod-xstream (entdef-value def)))
+         (setf (xstream-name r)
+           (make-stream-name :entity-name entity-name
+                             :entity-kind kind
+                             :uri nil)))
+        (external-entdef
+         (when internalp
+	   (wf-error zstream
+		     "entity not internal: ~A" (rod-string entity-name)))
+         (when (entdef-ndata def)
+	   (wf-error zstream
+		     "reference to unparsed entity: ~A"
+		     (rod-string entity-name)))
+         (setf r (xstream-open-extid (extid-using-catalog (entdef-extid def))))
+         (setf (stream-name-entity-name (xstream-name r)) entity-name
+               (stream-name-entity-kind (xstream-name r)) kind)))
+      r)))
+
+(defun checked-get-entdef (name type)
+  (let ((def (get-entity-definition name type (dtd *ctx*))))
+    (unless def
+      (wf-error nil "Entity '~A' is not defined." (rod-string name)))
+    def))
+
+(defun xstream-open-extid* (entity-resolver pubid sysid)
+  (let* ((stream
+          (or (funcall (or entity-resolver (constantly nil)) pubid sysid)
+              (open (uri-to-pathname sysid)
+                    :element-type '(unsigned-byte 8)
+                    :direction :input))))
+    (make-xstream stream
+                  :name (make-stream-name :uri sysid)
+                  :initial-speed 1)))
+
+(defun xstream-open-extid (extid)
+  (xstream-open-extid* (entity-resolver *ctx*)
+		       (extid-public extid)
+		       (extid-system extid)))
+
+(defun call-with-entity-expansion-as-stream (zstream cont name kind internalp)
+  ;; `zstream' is for error messages
+  (let ((in (entity->xstream zstream name kind internalp)))
+    (push (stream-name-uri (xstream-name in)) (base-stack *ctx*))
+    (unwind-protect
+        (funcall cont in)
+      (pop (base-stack *ctx*))
+      (close-xstream in))))
+
+(defun ensure-dtd ()
+  (unless (dtd *ctx*)
+    (setf (dtd *ctx*) (make-dtd))
+    (define-default-entities)))
+
+(defun define-default-entities ()
+  (define-entity nil #"lt"   :general (make-internal-entdef #"&#60;"))
+  (define-entity nil #"gt"   :general (make-internal-entdef #">"))
+  (define-entity nil #"amp"  :general (make-internal-entdef #"&#38;"))
+  (define-entity nil #"apos" :general (make-internal-entdef #"'"))
+  (define-entity nil #"quot" :general (make-internal-entdef #"\"")))
+
+(defstruct attdef
+  ;; an attribute definition
+  element       ;name of element this attribute belongs to
+  name          ;name of attribute
+  type          ;type of attribute; either one of :CDATA, :ID, :IDREF, :IDREFS,
+                ; :ENTITY, :ENTITIES, :NMTOKEN, :NMTOKENS, or
+                ; (:NOTATION <name>*)
+                ; (:ENUMERATION <name>*)
+  default       ;default value of attribute:
+                ; :REQUIRED, :IMPLIED, (:FIXED content) or (:DEFAULT content)
+  (external-p *external-subset-p*)
+  )
+
+(defstruct elmdef
+  ;; an element definition
+  name          ;name of the element
+  content       ;content model            [*]
+  attributes    ;list of defined attributes
+  compiled-cspec ;cons of validation function for contentspec
+  (external-p *external-subset-p*)
+  )
+
+;; [*] in XML it is possible to define attributes before the element
+;; itself is defined and since we hang attribute definitions into the
+;; relevant element definitions, the `content' slot indicates whether an
+;; element was actually defined.  It is NIL until set to a content model
+;; when the element type declaration is processed.
+
+(defun %make-rod-hash-table ()
+  ;; XXX with portable hash tables, this is the only way to case-sensitively
+  ;; use rods.  However, EQUALP often has horrible performance!  Most Lisps
+  ;; provide extensions for user-defined equality, we should use them!  There
+  ;; is also a home-made hash table for rods defined below, written by
+  ;; Gilbert (I think).  We could also use that one, but I would prefer the
+  ;; first method, even if it's unportable.
+  (make-hash-table :test
+                   #+rune-is-character 'equal
+                   #-rune-is-character 'equalp))
+
+(defstruct dtd
+  (elements (%make-rod-hash-table))     ;elmdefs
+  (gentities (%make-rod-hash-table))    ;general entities
+  (pentities (%make-rod-hash-table))    ;parameter entities
+  (notations (%make-rod-hash-table)))
+
+(defun make-dtd-cache ()
+  (puri:make-uri-space))
+
+(defvar *cache-all-dtds* nil)
+(defvar *dtd-cache* (make-dtd-cache))
+
+(defun remdtd (uri dtd-cache)
+  (setf uri (puri:intern-uri uri dtd-cache))
+  (prog1
+      (and (getf (puri:uri-plist uri) 'dtd) t)
+    (puri:unintern-uri uri dtd-cache)))
+
+(defun clear-dtd-cache (dtd-cache)
+  (puri:unintern-uri t dtd-cache))
+
+(defun getdtd (uri dtd-cache)
+  (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd))
+
+(defun (setf getdtd) (newval uri dtd-cache)
+  (setf (getf (puri:uri-plist (puri:intern-uri uri dtd-cache)) 'dtd) newval)
+  newval)
+
+
+;;;;
+
+(defun find-element (name dtd)
+  (gethash name (dtd-elements dtd)))
+
+(defun define-element (dtd element-name &optional content-model)
+  (let ((e (find-element element-name dtd)))
+    (cond
+      ((null e)
+       (prog1
+	   (setf (gethash element-name (dtd-elements dtd))
+		 (make-elmdef :name element-name :content content-model))
+	 (sax:element-declaration (handler *ctx*) element-name content-model)))
+      ((null content-model)
+        e)
+      (t
+        (when *validate*
+          (when (elmdef-content e)
+            (validity-error "(05) Unique Element Type Declaration"))
+          (when (eq content-model :EMPTY)
+            (dolist (ad (elmdef-attributes e))
+              (let ((type (attdef-type ad)))
+                (when (and (listp type) (eq (car type) :NOTATION))
+                  (validity-error "(16) No Notation on Empty Element: ~S"
+                                  (rod-string element-name)))))))
+        (sax:element-declaration (handler *ctx*) element-name content-model)
+        (setf (elmdef-content e) content-model)
+        (setf (elmdef-external-p e) *external-subset-p*)
+        e))))
+
+(defvar *redefinition-warning* nil)
+
+(defun define-attribute (dtd element name type default)
+  (let ((adef (make-attdef :element element
+                           :name name
+                           :type type
+                           :default default))
+        (e (or (find-element element dtd)
+               (define-element dtd element))))
+    (when (and *validate* (listp default))
+      (unless (eq (attdef-type adef) :CDATA)
+        (setf (second default) (canon-not-cdata-attval (second default))))
+      (validate-attribute* *ctx* adef (second default)))
+    (cond ((find-attribute e name)
+           (when *redefinition-warning*
+             (warn "Attribute \"~A\" of \"~A\" not redefined."
+                   (rod-string name)
+                   (rod-string element))))
+          (t
+           (when *validate*
+             (when (eq type :ID)
+               (when (find :ID (elmdef-attributes e) :key #'attdef-type)
+                 (validity-error "(09) One ID per Element Type: element ~A"
+                                 (rod-string element)))
+               (unless (member default '(:REQUIRED :IMPLIED))
+                 (validity-error "(10) ID Attribute Default: ~A"
+                                 (rod-string element))))
+             (flet ((notationp (type)
+                      (and (listp type) (eq (car type) :NOTATION))))
+               (when (notationp type)
+                 (when (find-if #'notationp (elmdef-attributes e)
+                                :key #'attdef-type)
+                   (validity-error "(15) One Notation Per Element Type: ~S"
+                                   (rod-string element)))
+                 (when (eq (elmdef-content e) :EMPTY)
+                   (validity-error "(16) No Notation on Empty Element: ~S"
+                                   (rod-string element))))))
+           (sax:attribute-declaration (handler *ctx*) element name type default)
+           (push adef (elmdef-attributes e))))))
+
+(defun find-attribute (elmdef name)
+  (find name (elmdef-attributes elmdef) :key #'attdef-name :test #'rod=))
+
+(defun define-notation (dtd name id)
+  (let ((ns (dtd-notations dtd)))
+    (when (gethash name ns)
+      (validity-error "(24) Unique Notation Name: ~S" (rod-string name)))
+    (setf (gethash name ns) id)))
+
+(defun find-notation (name dtd)
+  (gethash name (dtd-notations dtd)))
+
+;;;; ---------------------------------------------------------------------------
+;;;;  z streams and lexer
+;;;;
+
+(defstruct zstream
+  token-category
+  token-semantic
+  input-stack)
+
+(defun call-with-zstream (fn zstream)
+  (unwind-protect
+      (funcall fn zstream)
+    (dolist (input (zstream-input-stack zstream))
+      (cond #-x&y-streams-are-stream
+	    ((xstream-p input)
+	     (close-xstream input))
+	    #+x&y-streams-are-stream
+	    ((streamp input)
+	     (close input))))))
+
+(defmacro with-zstream ((zstream &rest args) &body body)
+  `(call-with-zstream (lambda (,zstream) , at body)
+		      (make-zstream , at args)))
+
+(defun read-token (input)
+  (cond ((zstream-token-category input)
+         (multiple-value-prog1
+             (values (zstream-token-category input)
+                     (zstream-token-semantic input))
+           (setf (zstream-token-category input) nil
+                 (zstream-token-semantic input) nil)))
+        (t
+         (read-token-2 input))))
+
+(defun peek-token (input)
+  (cond ((zstream-token-category input)
+         (values
+          (zstream-token-category input)
+          (zstream-token-semantic input)))
+        (t
+         (multiple-value-bind (c s) (read-token input)
+           (setf (zstream-token-category input) c
+                 (zstream-token-semantic input) s))
+         (values (zstream-token-category input)
+                 (zstream-token-semantic input)))))
+
+(defun read-token-2 (input)
+  (cond ((null (zstream-input-stack input))
+         (values :eof nil))
+        (t
+         (let ((c (peek-rune (car (zstream-input-stack input)))))
+           (cond ((eq c :eof)
+                  (cond ((eq (cadr (zstream-input-stack input)) :stop)
+                         (values :eof nil))
+                        (t
+                         (close-xstream (pop (zstream-input-stack input)))
+                         (if (null (zstream-input-stack input))
+                             (values :eof nil)
+                           (values :S nil) ;fake #x20 after PE expansion
+                           ))))
+                 (t
+                  (read-token-3 input)))))))
+
+(defvar *data-behaviour*
+    )           ;either :DTD or :DOC
+
+(defun read-token-3 (zinput)
+  (let ((input (car (zstream-input-stack zinput))))
+    ;; PI Comment
+    (let ((c (read-rune input)))
+      (cond
+       ;; first the common tokens
+       ((rune= #/< c)
+        (read-token-after-|<| zinput input))
+       ;; now dispatch
+       (t
+        (ecase *data-behaviour*
+          (:DTD
+           (cond ((rune= #/\[ c) :\[)
+                 ((rune= #/\] c) :\])
+                 ((rune= #/\( c) :\()
+                 ((rune= #/\) c) :\))
+                 ((rune= #/\| c) :\|)
+                 ((rune= #/\> c) :\>)
+                 ((rune= #/\" c) :\")
+                 ((rune= #/\' c) :\')
+                 ((rune= #/\, c) :\,)
+                 ((rune= #/\? c) :\?)
+                 ((rune= #/\* c) :\*)
+                 ((rune= #/\+ c) :\+)
+                 ((name-rune-p c)
+                  (unread-rune c input)
+                  (values :nmtoken (read-name-token input)))
+                 ((rune= #/# c)
+                  (let ((q (read-name-token input)))
+                    (cond ((rod= q '#.(string-rod "REQUIRED")) :|#REQUIRED|)
+                          ((rod= q '#.(string-rod "IMPLIED")) :|#IMPLIED|)
+                          ((rod= q '#.(string-rod "FIXED"))   :|#FIXED|)
+                          ((rod= q '#.(string-rod "PCDATA"))  :|#PCDATA|)
+                          (t
+                           (wf-error zinput "Unknown token: ~S." q)))))
+                 ((or (rune= c #/U+0020)
+                      (rune= c #/U+0009)
+                      (rune= c #/U+000D)
+                      (rune= c #/U+000A))
+                  (values :S nil))
+                 ((rune= #/% c)
+                  (cond ((name-start-rune-p (peek-rune input))
+                         ;; an entity reference
+                         (read-pe-reference zinput))
+                        (t
+                         (values :%))))
+                 (t
+                  (wf-error zinput "Unexpected character ~S." c))))
+          (:DOC
+           (cond
+            ((rune= c #/&)
+             (multiple-value-bind (kind data) (read-entity-like input)
+               (cond ((eq kind :ENTITY-REFERENCE)
+                      (values :ENTITY-REF data))
+                     ((eq kind :CHARACTER-REFERENCE)
+                      (values :CDATA
+                              (with-rune-collector (collect)
+                                (%put-unicode-char data collect)))))))
+            (t
+             (unread-rune c input)
+             (values :CDATA (read-cdata input)))))))))))
+
+(definline check-rune (input actual expected)
+  (unless (eql actual expected)
+    (wf-error input "expected #/~A but found #/~A"
+	      (rune-char expected)
+	      (rune-char actual))))
+
+(defun read-pe-reference (zinput)
+  (let* ((input (car (zstream-input-stack zinput)))
+         (nam (read-name-token input)))
+    (check-rune input #/\; (read-rune input))
+    (cond (*expand-pe-p*
+           ;; no external entities here!
+           (let ((i2 (entity->xstream  zinput nam :parameter)))
+             (zstream-push i2 zinput))
+           (values :S nil) ;space before inserted PE expansion.
+           )
+          (t
+           (values :PE-REFERENCE nam)) )))
+
+(defun read-token-after-|<| (zinput input)
+  (let ((d (read-rune input)))
+    (cond ((eq d :eof)
+           (eox input "EOF after '<'"))
+          ((rune= #/! d)
+           (read-token-after-|<!| input))
+          ((rune= #/? d)
+           (multiple-value-bind (target content) (read-pi input)
+             (cond ((rod= target '#.(string-rod "xml"))
+                    (values :xml-decl (cons target content)))
+                   ((rod-equal target '#.(string-rod "XML"))
+                    (wf-error zinput
+			      "You lost -- no XML processing instructions."))
+		   ((and sax:*namespace-processing* (position #/: target))
+		    (wf-error zinput
+			      "Processing instruction target ~S is not a ~
+                               valid NcName."
+			      (mu target)))
+                   (t
+                    (values :PI (cons target content))))))
+          ((eq *data-behaviour* :DTD)
+	    (unread-rune d input)
+	    (unless (or (rune= #// d) (name-start-rune-p d))
+	      (wf-error zinput "Expected '!' or '?' after '<' in DTD."))
+	    (values :seen-< nil))
+          ((rune= #// d)
+           (let ((c (peek-rune input)))
+             (cond ((name-start-rune-p c)
+                    (read-tag-2 zinput input :etag))
+                   (t
+                    (wf-error zinput
+			      "Expecting name start rune after \"</\".")))))
+          ((name-start-rune-p d)
+           (unread-rune d input)
+           (read-tag-2 zinput input :stag))
+          (t
+           (wf-error zinput "Expected '!' or '?' after '<' in DTD.")))))
+
+(defun read-token-after-|<!| (input)
+  (let ((d (read-rune input)))
+    (cond ((eq d :eof)
+           (eox input "EOF after \"<!\"."))
+          ((name-start-rune-p d)
+           (unread-rune d input)
+           (let ((name (read-name-token input)))
+             (cond ((rod= name '#.(string-rod "ELEMENT")) :|<!ELEMENT|)
+                   ((rod= name '#.(string-rod "ENTITY")) :|<!ENTITY|)
+                   ((rod= name '#.(string-rod "ATTLIST")) :|<!ATTLIST|)
+                   ((rod= name '#.(string-rod "NOTATION")) :|<!NOTATION|)
+                   ((rod= name '#.(string-rod "DOCTYPE")) :|<!DOCTYPE|)
+                   (t
+                    (wf-error  input"`<!~A' unknown." (rod-string name))))))
+          ((rune= #/\[ d)
+           (values :|<![| nil))
+          ((rune= #/- d)
+           (setf d (read-rune input))
+           (cond ((rune= #/- d)
+                  (values
+                   :COMMENT
+                   (read-comment-content input)))
+                 (t
+                  (wf-error input"Bad character ~S after \"<!-\"" d))))
+          (t
+           (wf-error input "Bad character ~S after \"<!\"" d)))))
+
+(definline read-S? (input)
+  (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D)
+                 :test #'eql)
+    (consume-rune input)))
+
+(defun read-attribute-list (zinput input imagine-space-p)
+  (cond ((or imagine-space-p
+             (let ((c (peek-rune input)))
+               (and (not (eq c :eof))
+                    (space-rune-p c))))
+         (read-S? input)
+         (cond ((eq (peek-rune input) :eof)
+                nil)
+               ((name-start-rune-p (peek-rune input))
+                (cons (read-attribute zinput input)
+                      (read-attribute-list zinput input nil)))
+               (t
+                nil)))
+        (t
+         nil)))
+
+(defun read-entity-like (input)
+  "Read an entity reference off the xstream `input'. Returns two values:
+   either :ENTITY-REFERENCE <interned-rod> in case of a named entity
+   or     :CHARACTER-REFERENCE <integer> in case of character references.
+   The initial #\\& is considered to be consumed already."
+  (let ((c (peek-rune input)))
+    (cond ((eq c :eof)
+           (eox input "EOF after '&'"))
+          ((rune= c #/#)
+           (values :CHARACTER-REFERENCE (read-character-reference input)))
+          (t
+           (unless (name-start-rune-p (peek-rune input))
+             (wf-error input "Expecting name after &."))
+           (let ((name (read-name-token input)))
+             (setf c (read-rune input))
+             (unless (rune= c #/\;)
+               (wf-error input "Expected \";\"."))
+             (values :ENTITY-REFERENCE name))))))
+
+(defun read-tag-2 (zinput input kind)
+  (let ((name (read-name-token input))
+        (atts nil))
+    (setf atts (read-attribute-list zinput input nil))
+
+    ;; check for double attributes
+    (do ((q atts (cdr q)))
+        ((null q))
+      (cond ((find (caar q) (cdr q) :key #'car)
+             (wf-error zinput "Attribute ~S has two definitions in element ~S."
+		       (rod-string (caar q))
+		       (rod-string name)))))
+
+    (cond ((eq (peek-rune input) #/>)
+           (consume-rune input)
+           (values kind (cons name atts)))
+          ((eq (peek-rune input) #//)
+           (consume-rune input)
+           (check-rune input #/> (read-rune input))
+           (values :ztag (cons name atts)))
+          (t
+           (wf-error zinput "syntax error in read-tag-2.")) )))
+
+(defun read-attribute (zinput input)
+  (unless (name-start-rune-p (peek-rune input))
+    (wf-error zinput "Expected name."))
+  ;; arg thanks to the post mortem nature of name space declarations,
+  ;; we could only process the attribute values post mortem.
+  (let ((name (read-name-token input)))
+    (while (let ((c (peek-rune input)))
+             (and (not (eq c :eof))
+                  (or (rune= c #/U+0020)
+                      (rune= c #/U+0009)
+                      (rune= c #/U+000A)
+                      (rune= c #/U+000D))))
+      (consume-rune input))
+    (unless (eq (read-rune input) #/=)
+      (wf-error zinput "Expected \"=\"."))
+    (while (let ((c (peek-rune input)))
+             (and (not (eq c :eof))
+                  (or (rune= c #/U+0020)
+                      (rune= c #/U+0009)
+                      (rune= c #/U+000A)
+                      (rune= c #/U+000D))))
+      (consume-rune input))
+    (cons name (read-att-value-2 input))))
+
+(defun canon-not-cdata-attval (value)
+  ;; | If the declared value is not CDATA, then the XML processor must
+  ;; | further process the normalized attribute value by discarding any
+  ;; | leading and trailing space (#x20) characters, and by replacing
+  ;; | sequences of space (#x20) characters by a single space (#x20)
+  ;; | character.
+  (with-rune-collector (collect)
+    (let ((gimme-20 nil)
+          (anything-seen-p nil))
+      (map nil (lambda (c)
+                 (cond ((rune= c #/u+0020)
+                        (setf gimme-20 t))
+                       (t
+                        (when (and anything-seen-p gimme-20)
+                          (collect #/u+0020))
+                        (setf gimme-20 nil)
+                        (setf anything-seen-p t)
+                        (collect c))))
+           value))))
+
+(definline data-rune-p (rune)
+  ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF.
+  ;;
+  ;; FIXME: das halte ich fuer verkehrt.  Surrogates als Unicode-Zeichen
+  ;; sind verboten.  Das liegt hier aber nicht vor, denn wir arbeiten
+  ;; ja tatsaechlich mit UTF-16.  Verboten ist es nur, wenn wir ein
+  ;; solches Zeichen beim Dekodieren finden, das wird aber eben
+  ;; in encodings.lisp bereits geprueft.  --david
+  (let ((c (rune-code rune)))
+    (or (= c #x9) (= c #xA) (= c #xD)
+        (<= #x20 c #xD7FF)
+        (<= #xE000 c #xFFFD)
+        (<= #xD800 c #xDBFF)
+        (<= #xDC00 c #xDFFF))))
+
+(defun read-att-value (zinput input mode &optional canon-space-p (delim nil))
+  (with-rune-collector-2 (collect)
+    (labels ((muffle (input delim)
+               (let (c)
+                 (loop
+                   (setf c (read-rune input))
+                   (cond ((eql delim c)
+                          (return))
+                         ((eq c :eof)
+                          (eox input "EOF"))
+                         ((rune= c #/&)
+                          (setf c (peek-rune input))
+                          (cond ((eql c :eof)
+			         (eox input))
+			        ((rune= c #/#)
+                                 (let ((c (read-character-reference input)))
+                                   (%put-unicode-char c collect)))
+                                (t
+                                 (unless (name-start-rune-p (peek-rune input))
+                                   (wf-error zinput "Expecting name after &."))
+                                 (let ((name (read-name-token input)))
+                                   (setf c (read-rune input))
+                                   (check-rune input c #/\;)
+                                   (ecase mode
+                                     (:ATT
+                                      (recurse-on-entity
+                                       zinput name :general
+                                       (lambda (zinput)
+                                         (muffle (car (zstream-input-stack zinput))
+                                                 :eof))
+				       t))
+                                     (:ENT
+                                      ;; bypass, but never the less we
+                                      ;; need to check for legal
+                                      ;; syntax.
+                                      ;; Must it be defined?
+                                      ;; allerdings: unparsed sind verboten
+                                      (collect #/&)
+                                      (map nil (lambda (x) (collect x)) name)
+                                      (collect #/\; )))))))
+                         ((and (eq mode :ENT) (rune= c #/%))
+                          (let ((d (peek-rune input)))
+			    (when (eq d :eof)
+			      (eox input))
+			    (unless (name-start-rune-p d)
+			      (wf-error zinput "Expecting name after %.")))
+                          (let ((name (read-name-token input)))
+                            (setf c (read-rune input))
+                            (check-rune input c #/\;)
+                            (cond (*expand-pe-p*
+                                   (recurse-on-entity
+                                    zinput name :parameter
+                                    (lambda (zinput)
+                                      (muffle (car (zstream-input-stack zinput))
+                                              :eof))))
+                                  (t
+                                   (wf-error zinput "No PE here.")))))
+                         ((and (eq mode :ATT) (rune= c #/<))
+			   (wf-error zinput "unexpected #\/<"))
+                         ((and canon-space-p (space-rune-p c))
+                          (collect #/space))
+                         ((not (data-rune-p c))
+                          (wf-error zinput "illegal char: ~S." c))
+                         (t
+                          (collect c)))))))
+      (declare (dynamic-extent #'muffle))
+      (muffle input (or delim
+                        (let ((delim (read-rune input)))
+                          (unless (member delim '(#/\" #/\') :test #'eql)
+			    (wf-error zinput "invalid attribute delimiter"))
+                          delim))))))
+
+(defun read-character-reference (input)
+  ;; The #/& is already read
+  (let ((res
+         (let ((c (read-rune input)))
+           (check-rune input c #/#)
+           (setq c (read-rune input))
+           (cond ((eql c :eof)
+		  (eox input))
+	         ((eql c #/x)
+                  ;; hexadecimal
+                  (setq c (read-rune input))
+		  (when (eql c :eof)
+		    (eox input))
+                  (unless (digit-rune-p c 16)
+		    (wf-error input "garbage in character reference"))
+                  (prog1
+                      (parse-integer
+                       (with-output-to-string (sink)
+                         (write-char (rune-char c) sink)
+                         (while (progn
+				  (setq c (read-rune input))
+				  (when (eql c :eof)
+				    (eox input))
+				  (digit-rune-p c 16))
+                           (write-char (rune-char c) sink)))
+                       :radix 16)
+                    (check-rune input c #/\;)))
+                 ((rune<= #/0 c #/9)
+                  ;; decimal
+                  (prog1
+                      (parse-integer
+                       (with-output-to-string (sink)
+                         (write-char (rune-char c) sink)
+                         (while (progn
+				  (setq c (read-rune input))
+				  (when (eql c :eof)
+				    (eox input))
+				  (rune<= #/0 c #/9))
+                           (write-char (rune-char c) sink)))
+                       :radix 10)
+                    (check-rune input c #/\;)))
+                 (t
+                  (wf-error input "Bad char in numeric character entity."))))))
+    (unless (code-data-char-p res)
+      (wf-error
+       input
+       "expansion of numeric character reference (#x~X) is no data char."
+       res))
+    res))
+
+(defun read-pi (input)
+  ;; "<?" is already read
+  (let (name)
+    (let ((c (peek-rune input)))
+      (unless (name-start-rune-p c)
+        (wf-error input "Expecting name after '<?'"))
+      (setf name (read-name-token input)))
+    (cond
+      ((member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D)
+	       :test #'eql)
+	(values name (read-pi-content input)))
+      (t
+	(unless (and (eql (read-rune input) #/?)
+		     (eql (read-rune input) #/>))
+	  (wf-error input "malformed processing instruction"))
+	(values name "")))))
+
+(defun read-pi-content (input)
+  (read-S? input)
+  (let (d)
+    (with-rune-collector (collect)
+      (block nil
+	(tagbody
+	 state-1
+	  (setf d (read-rune input))
+	  (when (eq d :eof)
+	    (eox input))
+	  (unless (data-rune-p d)
+	    (wf-error input "Illegal char: ~S." d))
+	  (when (rune= d #/?) (go state-2))
+	  (collect d)
+	  (go state-1)
+	 state-2 ;; #/? seen
+	  (setf d (read-rune input))
+	  (when (eq d :eof)
+	    (eox input))
+	  (unless (data-rune-p d)
+	    (wf-error input "Illegal char: ~S." d))
+	  (when (rune= d #/>) (return))
+	  (when (rune= d #/?)
+	    (collect #/?)
+	    (go state-2))
+	  (collect #/?)
+	  (collect d)
+	  (go state-1))))))
+
+(defun read-comment-content (input &aux d)
+  (with-rune-collector (collect)
+    (block nil
+      (tagbody
+       state-1
+	(setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+	(unless (data-rune-p d)
+	  (wf-error input "Illegal char: ~S." d))
+	(when (rune= d #/-) (go state-2))
+	(collect d)
+	(go state-1)
+       state-2 ;; #/- seen
+	(setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+	(unless (data-rune-p d)
+	  (wf-error input "Illegal char: ~S." d))
+	(when (rune= d #/-) (go state-3))
+	(collect #/-)
+	(collect d)
+	(go state-1)
+       state-3 ;; #/- #/- seen
+	(setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+	(unless (data-rune-p d)
+	  (wf-error input "Illegal char: ~S." d))
+	(when (rune= d #/>) (return))
+	(wf-error input "'--' not allowed in a comment")
+	(when (rune= d #/-)
+	  (collect #/-)
+	  (go state-3))
+	(collect #/-)
+	(collect #/-)
+	(collect d)
+	(go state-1)))))
+
+(defun read-cdata-sect (input &aux d)
+  ;; <![CDATA[ is already read
+  ;; read anything up to ]]>
+  (with-rune-collector (collect)
+    (block nil
+      (tagbody
+       state-1
+        (setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+        (unless (data-rune-p d)
+          (wf-error input "Illegal char: ~S." d))
+        (when (rune= d #/\]) (go state-2))
+        (collect d)
+        (go state-1)
+       state-2 ;; #/] seen
+        (setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+        (unless (data-rune-p d)
+          (wf-error input "Illegal char: ~S." d))
+        (when (rune= d #/\]) (go state-3))
+        (collect #/\])
+        (collect d)
+        (go state-1)
+       state-3 ;; #/\] #/\] seen
+        (setf d (read-rune input))
+	(when (eq d :eof)
+	  (eox input))
+        (unless (data-rune-p d)
+          (wf-error input "Illegal char: ~S." d))
+        (when (rune= d #/>)
+          (return))
+        (when (rune= d #/\])
+          (collect #/\])
+          (go state-3))
+        (collect #/\])
+        (collect #/\])
+        (collect d)
+        (go state-1)))))
+
+;; some character categories
+
+(defun space-rune-p (rune)
+  (declare (type rune rune))
+  (or (rune= rune #/U+0020)
+      (rune= rune #/U+0009)
+      (rune= rune #/U+000A)
+      (rune= rune #/U+000D)))
+
+(defun code-data-char-p (c)
+  ;; any Unicode character, excluding the surrogate blocks, FFFE, and FFFF.
+  (or (= c #x9) (= c #xA) (= c #xD)
+      (<= #x20 c #xD7FF)
+      (<= #xE000 c #xFFFD)
+      (<= #x10000 c #x10FFFF)))
+
+(defun pubid-char-p (c)
+  (or (rune= c #/u+0020) (rune= c #/u+000D) (rune= c #/u+000A)
+      (rune<= #/a c #/z)
+      (rune<= #/A c #/Z)
+      (rune<= #/0 c #/9)
+      (member c '(#/- #/' #/\( #/\) #/+ #/, #/. #//
+                  #/: #/= #/? #/\; #/! #/* #/#
+                  #/@ #/$ #/_ #/%))))
+
+
+(defun expect (input category)
+  (multiple-value-bind (cat sem) (read-token input)
+    (unless (eq cat category)
+      (wf-error input "Expected ~S saw ~S [~S]" category cat sem))
+    (values cat sem)))
+
+(defun consume-token (input)
+  (read-token input))
+
+;;;; ---------------------------------------------------------------------------
+;;;;  Parser
+;;;;
+
+(defun p/S (input)
+  ;; S ::= (#x20 | #x9 | #xD | #xA)+
+  (expect input :S)
+  (while (eq (peek-token input) :S)
+    (consume-token input)))
+
+(defun p/S? (input)
+  ;; S ::= (#x20 | #x9 | #xD | #xA)+
+  (while (eq (peek-token input) :S)
+    (consume-token input)))
+
+(defun p/nmtoken (input)
+  (nth-value 1 (expect input :nmtoken)))
+
+(defun p/name (input)
+  (let ((result (p/nmtoken input)))
+    (unless (name-start-rune-p (elt result 0))
+      (wf-error input "Expected name."))
+    result))
+
+(defun p/attlist-decl (input)
+  ;; [52] AttlistDecl ::= '<!ATTLIST' S Name (S AttDef)* S? '>'
+  (let (elm-name)
+    (expect input :|<!ATTLIST|)
+    (p/S input)
+    (setf elm-name (p/nmtoken input))
+    (loop
+      (let ((tok (read-token input)))
+        (case tok
+          (:S
+           (p/S? input)
+           (cond ((eq (peek-token input) :>)
+                  (consume-token input)
+                  (return))
+                 (t
+                  (multiple-value-bind (name type default) (p/attdef input)
+                    (define-attribute (dtd *ctx*) elm-name name type default)) )))
+          (:>
+           (return))
+          (otherwise
+           (wf-error input
+		     "Expected either another AttDef or end of \"<!ATTLIST\". -- saw ~S."
+		     tok)))))))
+
+(defun p/attdef (input)
+  ;; [53] AttDef ::= Name S AttType S DefaultDecl
+  (let (name type default)
+    (setf name (p/nmtoken input))
+    (p/S input)
+    (setf type (p/att-type input))
+    (p/S input)
+    (setf default (p/default-decl input))
+    (values name type default)))
+
+(defun p/list (input item-parser delimiter)
+  ;; Parse something like S? <item> (S? <delimiter> <item>)* S?
+  ;;
+  (declare (type function item-parser))
+  (let (res)
+    (p/S? input)
+    (setf res (list (funcall item-parser input)))
+    (loop
+      (p/S? input)
+      (cond ((eq (peek-token input) delimiter)
+             (consume-token input)
+             (p/S? input)
+             (push (funcall item-parser input) res))
+            (t
+             (return))))
+    (p/S? input)
+    (reverse res)))
+
+(defun p/att-type (input)
+  ;; [54] AttType ::= StringType | TokenizedType | EnumeratedType
+  ;; [55] StringType ::= 'CDATA'
+  ;; [56] TokenizedType ::= 'ID'                          /*VC: ID */
+  ;;                                                        /*VC: One ID per Element Type */
+  ;;                                                        /*VC: ID Attribute Default */
+  ;;                          | 'IDREF'                     /*VC: IDREF */
+  ;;                          | 'IDREFS'                    /*VC: IDREF */
+  ;;                          | 'ENTITY'                    /*VC: Entity Name */
+  ;;                          | 'ENTITIES'                  /*VC: Entity Name */
+  ;;                          | 'NMTOKEN'                   /*VC: Name Token */
+  ;;                          | 'NMTOKENS'                  /*VC: Name Token */
+  ;; [57] EnumeratedType ::= NotationType | Enumeration
+  ;; [58]   NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')'
+  ;; /* VC: Notation Attributes */
+  ;; [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' /* VC: Enumeration */
+  (multiple-value-bind (cat sem) (read-token input)
+    (cond ((eq cat :nmtoken)
+           (cond ((rod= sem '#.(string-rod "CDATA"))    :CDATA)
+                 ((rod= sem '#.(string-rod "ID"))       :ID)
+                 ((rod= sem '#.(string-rod "IDREF"))    :IDREFS)
+                 ((rod= sem '#.(string-rod "IDREFS"))   :IDREFS)
+                 ((rod= sem '#.(string-rod "ENTITY"))   :ENTITY)
+                 ((rod= sem '#.(string-rod "ENTITIES")) :ENTITIES)
+                 ((rod= sem '#.(string-rod "NMTOKEN"))  :NMTOKEN)
+                 ((rod= sem '#.(string-rod "NMTOKENS")) :NMTOKENS)
+                 ((rod= sem '#.(string-rod "NOTATION"))
+                  (let (names)
+                    (p/S input)
+                    (expect input :\()
+                    (setf names (p/list input #'p/nmtoken :\| ))
+                    (expect input :\))
+                    (when *validate*
+                      (setf (referenced-notations *ctx*)
+                            (append names (referenced-notations *ctx*))))
+                    (cons :NOTATION names)))
+                 (t
+                  (wf-error input "In p/att-type: ~S ~S." cat sem))))
+          ((eq cat :\()
+           ;; XXX Die Nmtoken-Syntax pruefen wir derzeit nur beim Validieren.
+           (let (names)
+             ;;(expect input :\()
+             (setf names (p/list input #'p/nmtoken :\| ))
+             (expect input :\))
+             (cons :ENUMERATION names)))
+          (t
+           (wf-error input "In p/att-type: ~S ~S." cat sem)) )))
+
+(defun p/default-decl (input)
+  ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED'
+  ;;                       | (('#FIXED' S)? AttValue) /* VC: Required Attribute */
+  ;;
+  ;; /* VC: Attribute Default Legal */
+  ;; /* WFC: No < in Attribute Values */
+  ;; /* VC: Fixed Attribute Default */
+  (multiple-value-bind (cat sem) (peek-token input)
+    (cond ((eq cat :|#REQUIRED|)
+           (consume-token input) :REQUIRED)
+          ((eq cat :|#IMPLIED|)
+           (consume-token input) :IMPLIED)
+          ((eq cat :|#FIXED|)
+           (consume-token input)
+           (p/S input)
+           (list :FIXED (p/att-value input)))
+          ((or (eq cat :\') (eq cat :\"))
+           (list :DEFAULT (p/att-value input)))
+          (t
+           (wf-error input "p/default-decl: ~S ~S." cat sem)) )))
+;;;;
+
+;;  [70] EntityDecl ::= GEDecl | PEDecl
+;;  [71]     GEDecl ::= '<!ENTITY' S Name S EntityDef S? '>'
+;;  [72]     PEDecl ::= '<!ENTITY' S '%' S Name S PEDef S? '>'
+;;  [73]  EntityDef ::= EntityValue | (ExternalID NDataDecl?)
+;;  [74]      PEDef ::= EntityValue | ExternalID
+;;  [75] ExternalID ::= 'SYSTEM' S SystemLiteral
+;;                      | 'PUBLIC' S PubidLiteral S SystemLiteral
+;;  [76]  NDataDecl ::= S 'NDATA' S Name                /* VC: Notation Declared */
+
+(defun p/entity-decl (input)
+  (let (name def kind)
+    (expect input :|<!ENTITY|)
+    (p/S input)
+    (cond ((eq (peek-token input) :%)
+           (setf kind :parameter)
+           (consume-token input)
+           (p/S input))
+          (t
+           (setf kind :general)))
+    (setf name (p/name input))
+    (p/S input)
+    (setf def (p/entity-def input kind))
+    (define-entity input name kind def)
+    (p/S? input)
+    (expect input :\>)))
+
+(defun report-entity (h kind name def)
+  (etypecase def
+    (external-entdef
+      (let ((extid (entdef-extid def))
+            (ndata (entdef-ndata def)))
+        (if ndata
+            (sax:unparsed-entity-declaration h
+                                             name
+                                             (extid-public extid)
+                                             (uri-rod (extid-system extid))
+                                             ndata)
+            (sax:external-entity-declaration h
+                                             kind
+                                             name
+                                             (extid-public extid)
+                                             (uri-rod (extid-system extid))))))
+    (internal-entdef
+      (sax:internal-entity-declaration h kind name (entdef-value def)))))
+
+(defun p/entity-def (input kind)
+  (multiple-value-bind (cat sem) (peek-token input)
+    (cond ((member cat '(:\" :\'))
+           (make-internal-entdef (p/entity-value input)))
+          ((and (eq cat :nmtoken)
+                (or (rod= sem '#.(string-rod "SYSTEM"))
+                    (rod= sem '#.(string-rod "PUBLIC"))))
+           (let (extid ndata)
+             (setf extid (p/external-id input nil))
+             (when (eq kind :general)   ;NDATA allowed at all?
+               (cond ((eq (peek-token input) :S)
+                      (p/S? input)
+                      (when (and (eq (peek-token input) :nmtoken)
+                                 (rod= (nth-value 1 (peek-token input))
+                                         '#.(string-rod "NDATA")))
+                        (consume-token input)
+                        (p/S input)
+                        (setf ndata (p/nmtoken input))
+                        (when *validate*
+                          (push ndata (referenced-notations *ctx*)))))))
+             (make-external-entdef extid ndata)))
+          (t
+           (wf-error input "p/entity-def: ~S / ~S." cat sem)) )))
+
+(defun p/entity-value (input)
+  (let ((delim (if (eq (read-token input) :\") #/\" #/\')))
+    (read-att-value input
+                    (car (zstream-input-stack input))
+                    :ENT
+                    nil
+                    delim)))
+
+(defun p/att-value (input)
+  (let ((delim (if (eq (read-token input) :\") #/\" #/\')))
+    (read-att-value input
+                    (car (zstream-input-stack input))
+                    :ATT
+                    t
+                    delim)))
+
+(defun p/external-id (input &optional (public-only-ok-p nil))
+  ;; xxx public-only-ok-p
+  (multiple-value-bind (cat sem) (read-token input)
+    (cond ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "SYSTEM")))
+           (p/S input)
+           (make-extid nil (p/system-literal input)))
+          ((and (eq cat :nmtoken) (rod= sem '#.(string-rod "PUBLIC")))
+           (let (pub sys)
+             (p/S input)
+             (setf pub (p/pubid-literal input))
+             (when (eq (peek-token input) :S)
+               (p/S input)
+               (when (member (peek-token input) '(:\" :\'))
+                 (setf sys (p/system-literal input))))
+             (when (and (not public-only-ok-p)
+                        (null sys))
+               (wf-error input "System identifier needed for this PUBLIC external identifier."))
+             (make-extid pub sys)))
+          (t
+           (wf-error input "Expected external-id: ~S / ~S." cat sem)))))
+
+
+;;  [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'")
+;;  [12]  PubidLiteral ::= '"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
+;;  [13]     PubidChar ::= #x20 | #xD | #xA | [a-zA-Z0-9]
+;;                         | [-'()+,./:=?;!*#@$_%]
+
+(defun p/id (input)
+  (multiple-value-bind (cat) (read-token input)
+    (cond ((member cat '(:\" :\'))
+           (let ((delim (if (eq cat :\") #/\" #/\')))
+             (with-rune-collector (collect)
+               (loop
+                 (let ((c (read-rune (car (zstream-input-stack input)))))
+                   (cond ((eq c :eof)
+                          (eox input "EOF in system literal."))
+                         ((rune= c delim)
+                          (return))
+                         (t
+                          (collect c))))))))
+          (t
+           (wf-error input "Expect either \" or \'.")))))
+
+;; it is important to cache the orginal URI rod, since the re-serialized
+;; uri-string can be different from the one parsed originally.
+(defun uri-rod (uri)
+  (if uri
+      (or (getf (puri:uri-plist uri) 'original-rod)
+          (rod (puri:render-uri uri nil)))
+      nil))
+
+(defun safe-parse-uri (str)
+  ;; puri doesn't like strings starting with file:///, although that is a very
+  ;; common is practise.  Cut it away, we don't distinguish between scheme
+  ;; :FILE and NIL anway.
+  (when (eql (search "file://" str) 0)
+    (setf str (subseq str (length "file://"))))
+  (puri:parse-uri (coerce str 'simple-string)))
+
+(defun p/system-literal (input)
+  (let* ((rod (p/id input))
+         (result (safe-parse-uri (rod-string rod))))
+    (setf (getf (puri:uri-plist result) 'original-rod) rod)
+    result))
+
+(defun p/pubid-literal (input)
+  (let ((result (p/id input)))
+    (unless (every #'pubid-char-p result)
+      (wf-error input "Illegal pubid: ~S." (rod-string result)))
+    result))
+
+
+;;;;
+
+(defun p/element-decl (input)
+  (let (name content)
+    (expect input :|<!ELEMENT|)
+    (p/S input)
+    (setf name (p/nmtoken input))
+    (p/S input)
+    (setf content (normalize-mixed-cspec (p/cspec input)))
+    (unless (legal-content-model-p content *validate*)
+      (wf-error input "Malformed or invalid content model: ~S." (mu content)))
+    (p/S? input)
+    (expect input :\>)
+    (when *validate*
+      (define-element (dtd *ctx*) name content))
+    (list :element name content)))
+
+(defun maybe-compile-cspec (e)
+  (or (elmdef-compiled-cspec e)
+      (setf (elmdef-compiled-cspec e)
+            (let ((cspec (elmdef-content e)))
+              (unless cspec
+                (validity-error "(03) Element Valid: no definition for ~A"
+                                (rod-string (elmdef-name e))))
+              (multiple-value-call #'cons
+                (compile-cspec cspec (standalone-check-necessary-p e)))))))
+
+(defun make-root-model (name)
+  (cons (lambda (actual-name)
+          (if (rod= actual-name name)
+              (constantly :dummy)
+              nil))
+        (constantly t)))
+
+;;; content spec validation:
+;;;
+;;; Given a `contentspec', COMPILE-CSPEC returns as multiple values two
+;;; functions A and B of one argument to be called for every
+;;;   A. child element
+;;;   B. text child node
+;;;
+;;; Function A will be called with
+;;;   - the element name rod as its argument.  If that element may appear
+;;;     at the current position, a new function to be called for the next
+;;;     child is returned.  Otherwise NIL is returned.
+;;;   - argument NIL at the end of the element, it must then return T or NIL
+;;;     to indicate whether the end tag is valid.
+;;;
+;;; Function B will be called with the character data rod as its argument, it
+;;; returns a boolean indicating whether this text node is allowed.
+;;;
+;;; That is, if one of the functions ever returns NIL, the node is
+;;; rejected as invalid.
+
+(defun cmodel-done (actual-value)
+  (null actual-value))
+
+(defun compile-cspec (cspec &optional standalone-check)
+  (cond
+    ((atom cspec)
+      (ecase cspec
+        (:EMPTY (values #'cmodel-done (constantly nil)))
+        (:PCDATA (values #'cmodel-done (constantly t)))
+        (:ANY
+          (values (labels ((doit (name) (if name #'doit t))) #'doit)
+                  (constantly t)))))
+    ((and (eq (car cspec) '*)
+          (let ((subspec (second cspec)))
+            (and (eq (car subspec) 'or) (eq (cadr subspec) :PCDATA))))
+      (values (compile-mixed (second cspec))
+              (constantly t)))
+    (t
+      (values (compile-content-model cspec)
+              (lambda (rod)
+                (when standalone-check
+                  (validity-error "(02) Standalone Document Declaration: whitespace"))
+                (every #'white-space-rune-p rod))))))
+
+(defun compile-mixed (cspec)
+  ;; das koennten wir theoretisch auch COMPILE-CONTENT-MODEL erledigen lassen
+  (let ((allowed-names (cddr cspec)))
+    (labels ((doit (actual-name)
+               (cond
+                 ((null actual-name) t)
+                 ((member actual-name allowed-names :test #'rod=) #'doit)
+                 (t nil))))
+      #'doit)))
+
+(defun compile-content-model (cspec &optional (continuation #'cmodel-done))
+  (if (vectorp cspec)
+      (lambda (actual-name)
+        (if (and actual-name (rod= cspec actual-name))
+            continuation
+            nil))
+      (ecase (car cspec)
+        (and
+          (labels ((traverse (seq)
+                     (compile-content-model (car seq)
+                                            (if (cdr seq)
+                                                (traverse (cdr seq))
+                                                continuation))))
+            (traverse (cdr cspec))))
+        (or
+          (let ((options (mapcar (rcurry #'compile-content-model continuation)
+                                 (cdr cspec))))
+            (lambda (actual-name)
+              (some (rcurry #'funcall actual-name) options))))
+        (?
+          (let ((maybe (compile-content-model (second cspec) continuation)))
+            (lambda (actual-name)
+              (or (funcall maybe actual-name)
+                  (funcall continuation actual-name)))))
+        (*
+          (let (maybe-continuation)
+            (labels ((recurse (actual-name)
+                       (if (null actual-name)
+                           (funcall continuation actual-name)
+                           (or (funcall maybe-continuation actual-name)
+                               (funcall continuation actual-name)))))
+              (setf maybe-continuation
+                    (compile-content-model (second cspec) #'recurse))
+              #'recurse)))
+        (+
+          (let ((it (cadr cspec)))
+            (compile-content-model `(and ,it (* ,it)) continuation))))))
+
+(defun setp (list &key (test 'eql))
+  (equal list (remove-duplicates list :test test)))
+
+(defun legal-content-model-p (cspec &optional validate)
+  (or (eq cspec :PCDATA)
+      (eq cspec :ANY)
+      (eq cspec :EMPTY)
+      (and (consp cspec)
+           (eq (car cspec) '*)
+           (consp (cadr cspec))
+           (eq (car (cadr cspec)) 'or)
+           (eq (cadr (cadr cspec)) :PCDATA)
+           (every #'vectorp (cddr (cadr cspec)))
+           (if (and validate (not (setp (cddr (cadr cspec)) :test #'rod=)))
+               (validity-error "VC: No Duplicate Types (07)")
+               t))
+      (labels ((walk (x)
+                 (cond ((member x '(:PCDATA :ANY :EMPTY))
+                        nil)
+                       ((atom x) t)
+                       ((and (walk (car x))
+                             (walk (cdr x)))))))
+        (walk cspec))))
+
+;; wir fahren besser, wenn wir machen:
+
+;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA'
+;;         | Name
+;;         | cs
+;;    cs ::= '(' S? cspec ( S? '|' S? cspec)* S? ')' ('?' | '*' | '+')?
+;; und eine post factum analyse
+
+(defun p/cspec (input &optional recursivep)
+  (let ((term
+         (let ((names nil) op-cat op res stream)
+           (multiple-value-bind (cat sem) (peek-token input)
+             (cond ((eq cat :nmtoken)
+                    (consume-token input)
+                    (cond ((rod= sem '#.(string-rod "EMPTY"))
+                           :EMPTY)
+                          ((rod= sem '#.(string-rod "ANY"))
+                           :ANY)
+                          ((not recursivep)
+			   (wf-error input "invalid content spec"))
+		          (t
+			   sem)))
+                   ((eq cat :\#PCDATA)
+                    (consume-token input)
+                    :PCDATA)
+                   ((eq cat :\()
+                    (setf stream (car (zstream-input-stack input)))
+                    (consume-token input)
+                    (p/S? input)
+                    (setq names (list (p/cspec input t)))
+                    (p/S? input)
+                    (cond ((member (peek-token input) '(:\| :\,))
+                            (setf op-cat (peek-token input))
+                            (setf op (if (eq op-cat :\,) 'and 'or))
+                            (while (eq (peek-token input) op-cat)
+                              (consume-token input)
+                              (p/S? input)
+                              (push (p/cspec input t) names)
+                              (p/S? input))
+                            (setf res (cons op (reverse names))))
+                      (t
+                        (setf res (cons 'and names))))
+                    (p/S? input)
+                    (expect input :\))
+                    (when *validate*
+                      (unless (eq stream (car (zstream-input-stack input)))
+                        (validity-error "(06) Proper Group/PE Nesting")))
+                    res)
+                   (t
+                    (wf-error input "p/cspec - ~s / ~s" cat sem)))))))
+    (cond ((eq (peek-token input) :?) (consume-token input) (list '? term))
+          ((eq (peek-token input) :+) (consume-token input) (list '+ term))
+          ((eq (peek-token input) :*) (consume-token input) (list '* term))
+          (t
+           term))))
+
+(defun normalize-mixed-cspec (cspec)
+  ;; der Parser oben funktioniert huebsch fuer die children-Regel, aber
+  ;; fuer Mixed ist das Ergebnis nicht praktisch, denn dort wollen wir
+  ;; eigentlich auf eine Liste von Namen in einheitlichem Format hinaus.
+  ;; Dazu normalisieren wir einfach in eine der beiden folgenden Formen:
+  ;;   (* (or :PCDATA ...rods...))     -- und zwar exakt so!
+  ;;   :PCDATA                         -- sonst ganz trivial
+  (flet ((trivialp (c)
+           (and (consp c)
+                (and (eq (car c) 'and)
+                     (eq (cadr c) :PCDATA)
+                     (null (cddr c))))))
+    (if (or (trivialp cspec)            ;(and PCDATA)
+            (and (consp cspec)          ;(* (and PCDATA))
+                 (and (eq (car cspec) '*)
+                      (null (cddr cspec))
+                      (trivialp (cadr cspec)))))
+        :PCDATA
+        cspec)))
+
+;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>'
+
+
+;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDefs S? '>'
+;; [52] AttlistDecl ::= '<!ATTLIST' S Name S? '>'
+;; [53] AttDefs ::= S Name S AttType S DefaultDecl AttDefs
+;; [53] AttDefs ::=
+
+(defun p/notation-decl (input)
+  (let (name id)
+    (expect input :|<!NOTATION|)
+    (p/S input)
+    (setf name (p/name input))
+    (p/S input)
+    (setf id (p/external-id input t))
+    (p/S? input)
+    (expect input :\>)
+    (sax:notation-declaration (handler *ctx*)
+                              name
+                              (if (extid-public id)
+                                  (normalize-public-id (extid-public id))
+                                  nil)
+                              (uri-rod (extid-system id)))
+    (when (and sax:*namespace-processing* (find #/: name))
+      (wf-error input "colon in notation name"))
+    (when *validate*
+      (define-notation (dtd *ctx*) name id))
+    (list :notation-decl name id)))
+
+(defun normalize-public-id (rod)
+  (with-rune-collector (collect)
+    (let ((gimme-20 nil)
+          (anything-seen-p nil))
+      (map nil (lambda (c)
+                 (cond
+                   ((or (rune= c #/u+0009)
+                        (rune= c #/u+000A)
+                        (rune= c #/u+000D)
+                        (rune= c #/u+0020))
+                     (setf gimme-20 t))
+                   (t
+                     (when (and anything-seen-p gimme-20)
+                       (collect #/u+0020))
+                     (setf gimme-20 nil)
+                     (setf anything-seen-p t)
+                     (collect c))))
+           rod))))
+
+;;;
+
+(defun p/conditional-sect (input)
+  (expect input :<!\[ )
+  (let ((stream (car (zstream-input-stack input))))
+    (p/S? input)
+    (multiple-value-bind (cat sem) (read-token input)
+      (cond ((and (eq cat :nmtoken)
+                  (rod= sem '#.(string-rod "INCLUDE")))
+             (p/include-sect input stream))
+            ((and (eq cat :nmtoken)
+                  (rod= sem '#.(string-rod "IGNORE")))
+             (p/ignore-sect input stream))
+            (t
+             (wf-error input "Expected INCLUDE or IGNORE after \"<![\"."))))))
+
+(defun p/cond-expect (input cat initial-stream)
+  (expect input cat)
+  (when *validate*
+    (unless (eq (car (zstream-input-stack input)) initial-stream)
+      (validity-error "(21) Proper Conditional Section/PE Nesting"))))
+
+(defun p/include-sect (input initial-stream)
+  ;; <![INCLUDE is already read.
+  (p/S? input)
+  (p/cond-expect input :\[ initial-stream)
+  (p/ext-subset-decl input)
+  (p/cond-expect input :\] initial-stream)
+  (p/cond-expect input :\] initial-stream)
+  (p/cond-expect input :\> initial-stream))
+
+(defun p/ignore-sect (input initial-stream)
+  ;; <![IGNORE is already read.
+  ;; XXX Is VC 21 being checked for nested sections?
+  (p/S? input)
+  (p/cond-expect input :\[ initial-stream)
+  (let ((input (car (zstream-input-stack input))))
+    (let ((level 0))
+      (do ((c1 (read-rune input) (read-rune input))
+           (c2 #/U+0000 c1)
+           (c3 #/U+0000 c2))
+          ((= level -1))
+        (declare (type fixnum level))
+        (cond ((eq c1 :eof)
+               (eox input "EOF in <![IGNORE ... >")))
+        (cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[))
+               (incf level)))
+        (cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>))
+               (decf level))) )))
+  (unless (eq (car (zstream-input-stack input)) initial-stream)
+    (validity-error "(21) Proper Conditional Section/PE Nesting")))
+
+(defun p/ext-subset-decl (input)
+  ;; ( markupdecl | conditionalSect | S )*
+  (loop
+    (case (let ((*expand-pe-p* nil)) (peek-token input))
+      (:|<![| (let ((*expand-pe-p* t)) (p/conditional-sect input)))
+      (:S     (consume-token input))
+      (:eof   (return))
+      ((:|<!ELEMENT| :|<!ATTLIST| :|<!ENTITY| :|<!NOTATION| :PI :COMMENT)
+       (let ((*expand-pe-p* t)
+             (*external-subset-p* t))
+         (p/markup-decl input)))
+      ((:PE-REFERENCE)
+       (let ((name (nth-value 1 (read-token input))))
+         (recurse-on-entity input name :parameter
+                            (lambda (input)
+                              (etypecase (checked-get-entdef name :parameter)
+                                (external-entdef
+                                 (p/ext-subset input))
+                                (internal-entdef
+                                 (p/ext-subset-decl input)))
+                              (unless (eq :eof (peek-token input))
+                                (wf-error input "Trailing garbage."))))))
+      (otherwise (return)))) )
+
+(defun p/markup-decl (input)
+  (peek-token input)
+  (let ((stream (car (zstream-input-stack input))))
+    (multiple-value-prog1
+        (p/markup-decl-unsafe input)
+      (when *validate*
+        (unless (eq stream (car (zstream-input-stack input)))
+          (validity-error "(01) Proper Declaration/PE Nesting"))))))
+
+(defun p/markup-decl-unsafe (input)
+  ;; markupdecl ::= elementdecl | AttlistDecl       /* VC: Proper Declaration/PE Nesting */
+  ;;              | EntityDecl | NotationDecl
+  ;;              | PI | Comment               /* WFC: PEs in Internal Subset */
+  (let ((token (peek-token input))
+	(*expand-pe-p* (and *expand-pe-p* *external-subset-p*)))
+    (case token
+      (:|<!ELEMENT|  (p/element-decl input))
+      (:|<!ATTLIST|  (p/attlist-decl input))
+      (:|<!ENTITY|   (p/entity-decl input))
+      (:|<!NOTATION| (p/notation-decl input))
+      (:PI
+	(let ((sem (nth-value 1 (read-token input))))
+	  (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem))))
+      (:COMMENT      (consume-token input))
+      (otherwise
+	(wf-error input "p/markup-decl ~S" (peek-token input))))))
+
+(defun setup-encoding (input xml-header)
+  (when (xml-header-encoding xml-header)
+    (let ((enc (find-encoding (xml-header-encoding xml-header))))
+      (cond (enc
+             (setf (xstream-encoding (car (zstream-input-stack input)))
+               enc))
+            (t
+             (warn "There is no such encoding: ~S." (xml-header-encoding xml-header)))))))
+
+(defun set-full-speed (input)
+  (let ((xstream (car (zstream-input-stack input))))
+    (when xstream
+      (set-to-full-speed xstream))))
+
+(defun p/ext-subset (input)
+  (cond ((eq (peek-token input) :xml-decl)
+         (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input))))))
+           (setup-encoding input hd))
+         (consume-token input)))
+  (set-full-speed input)
+  (p/ext-subset-decl input)
+  (unless (eq (peek-token input) :eof)
+    (wf-error input "Trailing garbage - ~S." (peek-token input))))
+
+(defvar *catalog* nil)
+
+(defun extid-using-catalog (extid)
+  (if *catalog*
+      (let ((sysid
+             (resolve-extid (extid-public extid)
+                            (extid-system extid)
+                            *catalog*)))
+        (if sysid
+            (make-extid nil sysid)
+            extid))
+      extid))
+
+(defun p/doctype-decl (input &optional dtd-extid)
+  (let ()
+    (let ((*expand-pe-p* nil)
+          name extid)
+      (expect input :|<!DOCTYPE|)
+      (p/S input)
+      (setq name (p/nmtoken input))
+      (when *validate*
+        (setf (model-stack *ctx*) (list (make-root-model name))))
+      (when (eq (peek-token input) :S)
+        (p/S input)
+        (unless (or (eq (peek-token input) :\[ )
+                    (eq (peek-token input) :\> ))
+          (setf extid (p/external-id input t))))
+      (when dtd-extid
+        (setf extid dtd-extid))
+      (p/S? input)
+      (sax:start-dtd (handler *ctx*)
+                     name
+                     (and extid (extid-public extid))
+                     (and extid (uri-rod (extid-system extid))))
+      (when (eq (peek-token input) :\[ )
+        (when (disallow-internal-subset *ctx*)
+          (wf-error input "document includes an internal subset"))
+        (ensure-dtd)
+        (consume-token input)
+	(sax:start-internal-subset (handler *ctx*))
+        (while (progn (p/S? input)
+                      (not (eq (peek-token input) :\] )))
+          (if (eq (peek-token input) :PE-REFERENCE)
+              (let ((name (nth-value 1 (read-token input))))
+                (recurse-on-entity input name :parameter
+                                   (lambda (input)
+                                     (etypecase (checked-get-entdef name :parameter)
+                                       (external-entdef
+                                        (p/ext-subset input))
+                                       (internal-entdef
+                                        (p/ext-subset-decl input)))
+                                     (unless (eq :eof (peek-token input))
+                                       (wf-error input "Trailing garbage.")))))
+              (let ((*expand-pe-p* t))
+                (p/markup-decl input))))
+        (consume-token input)
+	(sax:end-internal-subset (handler *ctx*))
+        (p/S? input))
+      (expect input :>)
+      (when extid
+        (let* ((effective-extid
+                (extid-using-catalog (absolute-extid input extid)))
+               (sysid (extid-system effective-extid))
+               (fresh-dtd-p (null (dtd *ctx*)))
+               (cached-dtd
+                (and fresh-dtd-p
+                     (not (standalone-p *ctx*))
+                     (getdtd sysid *dtd-cache*))))
+          (cond
+            (cached-dtd
+              (setf (dtd *ctx*) cached-dtd)
+              (report-cached-dtd cached-dtd))
+            (t
+              (let ((xi2 (xstream-open-extid effective-extid)))
+		(with-zstream (zi2 :input-stack (list xi2))
+		  (ensure-dtd)
+		  (p/ext-subset zi2)
+		  (when (and fresh-dtd-p
+			     *cache-all-dtds*
+			     *validate*
+			     (not (standalone-p *ctx*)))
+		    (setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))))))))
+      (sax:end-dtd (handler *ctx*))
+      (let ((dtd (dtd *ctx*)))
+        (sax:entity-resolver
+         (handler *ctx*)
+         (lambda (name handler) (resolve-entity name handler dtd)))
+        (sax::dtd (handler *ctx*) dtd))
+      (list :DOCTYPE name extid))))
+
+(defun report-cached-dtd (dtd)
+  (maphash (lambda (k v)
+             (report-entity (handler *ctx*) :general k (cdr v)))
+           (dtd-gentities dtd))
+  (maphash (lambda (k v)
+             (report-entity (handler *ctx*) :parameter k (cdr v)))
+           (dtd-pentities dtd))
+  (maphash (lambda (k v)
+             (sax:notation-declaration
+              (handler *ctx*)
+              k
+              (if (extid-public v)
+                  (normalize-public-id (extid-public v))
+                  nil)
+              (uri-rod (extid-system v))))
+           (dtd-notations dtd)))
+
+(defun p/misc*-2 (input)
+  ;; Misc*
+  (while (member (peek-token input) '(:COMMENT :PI :S))
+    (case (peek-token input)
+      (:COMMENT
+        (sax:comment (handler *ctx*) (nth-value 1 (peek-token input))))
+      (:PI
+        (sax:processing-instruction
+         (handler *ctx*)
+         (car (nth-value 1 (peek-token input)))
+         (cdr (nth-value 1 (peek-token input))))))
+    (consume-token input)))
+
+(defun p/document
+    (input handler
+     &key validate dtd root entity-resolver disallow-internal-subset
+	  (recode t))
+  ;; check types of user-supplied arguments for better error messages:
+  (check-type validate boolean)
+  (check-type recode boolean)
+  (check-type dtd (or null extid))
+  (check-type root (or null rod))
+  (check-type entity-resolver (or null function symbol))
+  (check-type disallow-internal-subset boolean)
+  #+rune-is-integer
+  (when recode
+    (setf handler (make-recoder handler #'rod-to-utf8-string)))
+  (let* ((xstream (car (zstream-input-stack input)))
+	 (name (xstream-name xstream))
+	 (base (when name (stream-name-uri name)))
+	 (*ctx*
+	  (make-context :handler handler
+			:main-zstream input
+			:entity-resolver entity-resolver
+			:base-stack (list (or base ""))
+			:disallow-internal-subset disallow-internal-subset))
+	 (*validate* validate)
+	 (*namespace-bindings* *initial-namespace-bindings*))
+    (sax:register-sax-parser handler (make-instance 'cxml-parser :ctx *ctx*))
+    (sax:start-document handler)
+    ;; document ::= XMLDecl? Misc* (doctypedecl Misc*)? element Misc*
+    ;; Misc ::= Comment | PI |  S
+    ;; xmldecl::='<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'
+    ;; sddecl::= S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"'))
+    (let ((*data-behaviour* :DTD))
+      ;; optional XMLDecl?
+      (p/xmldecl input)
+      ;; Misc*
+      (p/misc*-2 input)
+      ;; (doctypedecl Misc*)?
+      (cond
+        ((eq (peek-token input) :<!DOCTYPE)
+          (p/doctype-decl input dtd)
+          (p/misc*-2 input))
+        (dtd
+	  (synthesize-doctype dtd input))
+        ((and validate (not dtd))
+          (validity-error "invalid document: no doctype")))
+      (ensure-dtd)
+      ;; Override expected root element if asked to
+      (when root
+        (setf (model-stack *ctx*) (list (make-root-model root))))
+      ;; element
+      (let ((*data-behaviour* :DOC))
+	(fix-seen-< input)
+        (p/element input))
+      ;; optional Misc*
+      (p/misc*-2 input)
+      (p/eof input)
+      (sax:end-document handler))))
+
+(defun synthesize-doctype (dtd input)
+  (let ((dummy (string->xstream "<!DOCTYPE dummy>")))
+    (setf (xstream-name dummy)
+	  (make-stream-name
+	   :entity-name "dummy doctype"
+	   :entity-kind :main
+	   :uri (zstream-base-sysid input)))
+    (with-zstream (zstream :input-stack (list dummy))
+      (p/doctype-decl zstream dtd))))
+
+(defun fix-seen-< (input)
+  (when (eq (peek-token input) :seen-<)
+    (multiple-value-bind (c s)
+	(read-token-after-|<| input (car (zstream-input-stack input)))
+      (setf (zstream-token-category input) c
+	    (zstream-token-semantic input) s))))
+
+(defun p/xmldecl (input)
+  ;; we will use the attribute-value parser for the xml decl.
+  (prog1
+      (when (eq (peek-token input) :xml-decl)
+	(let ((hd (parse-xml-decl (cdr (nth-value 1 (peek-token input))))))
+	  (setf (standalone-p *ctx*) (eq (xml-header-standalone-p hd) :yes))
+	  (setup-encoding input hd)
+	  (read-token input)
+	  hd))
+    (set-full-speed input)))
+
+(defun p/eof (input)
+  (unless (eq (peek-token input) :eof)
+    (wf-error input "Garbage at end of document."))
+  (when *validate*
+    (maphash (lambda (k v)
+	       (unless v
+		 (validity-error "(11) IDREF: ~S not defined" (rod-string k))))
+	     (id-table *ctx*))
+
+    (dolist (name (referenced-notations *ctx*))
+      (unless (find-notation name (dtd *ctx*))
+	(validity-error "(23) Notation Declared: ~S" (rod-string name))))))
+
+(defun p/element (input)
+  (multiple-value-bind (cat n-b new-b uri lname qname attrs) (p/sztag input)
+    (sax:start-element (handler *ctx*) uri lname qname attrs)
+    (when (eq cat :stag)
+      (let ((*namespace-bindings* n-b))
+	(p/content input))
+      (p/etag input qname))
+    (sax:end-element (handler *ctx*) uri lname qname)
+    (undeclare-namespaces new-b)
+    (pop (base-stack *ctx*))
+    (validate-end-element *ctx* qname)))
+
+(defun p/sztag (input)
+  (multiple-value-bind (cat sem) (read-token input)
+    (case cat
+      ((:stag :ztag))
+      (:eof (eox input))
+      (t (wf-error input "element expected")))
+    (destructuring-bind (&optional name &rest raw-attrs) sem
+      (validate-start-element *ctx* name)
+      (let* ((attrs
+	      (process-attributes *ctx* name (build-attribute-list raw-attrs)))
+	     (*namespace-bindings* *namespace-bindings*)
+	     new-namespaces)
+	(when sax:*namespace-processing*
+	  (setf new-namespaces (declare-namespaces attrs))
+	  (mapc #'set-attribute-namespace attrs))
+	(push (compute-base attrs) (base-stack *ctx*))
+	(multiple-value-bind (uri prefix local-name)
+	    (if sax:*namespace-processing*
+		(decode-qname name)
+		(values nil nil nil))
+	  (declare (ignore prefix))
+	  (check-attribute-uniqueness attrs)
+	  (unless (or sax:*include-xmlns-attributes*
+		      (null sax:*namespace-processing*))
+	    (setf attrs
+		  (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname)
+			     attrs))) 
+	  (values cat
+		  *namespace-bindings*
+		  new-namespaces
+		  uri local-name name attrs))))))
+
+(defun p/etag (input qname)
+  (multiple-value-bind (cat2 sem2) (read-token input)
+    (unless (and (eq cat2 :etag)
+		 (eq (car sem2) qname))
+      (wf-error input "Bad nesting. ~S / ~S"
+		(mu qname)
+		(mu (cons cat2 sem2))))
+    (when (cdr sem2)
+      (wf-error input "no attributes allowed in end tag"))))
+
+;; copy&paste from cxml-rng
+(defun escape-uri (string)
+  (with-output-to-string (out)
+    (loop for c across (cxml::rod-to-utf8-string string) do
+	  (let ((code (char-code c)))
+	    ;; http://www.w3.org/TR/xlink/#link-locators
+	    (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
+		(format out "%~2,'0X" code)
+		(write-char c out))))))
+
+(defun compute-base (attrs)
+  (let ((new (sax:find-attribute #"xml:base" attrs))
+	(current (car (base-stack *ctx*))))
+    (if new
+	(puri:merge-uris (escape-uri (sax:attribute-value new)) current)
+	current)))
+
+(defun process-characters (input sem)
+  (consume-token input)
+  (when (search #"]]>" sem)
+    (wf-error input "']]>' not allowed in CharData"))
+  (validate-characters *ctx* sem))
+
+(defun process-cdata-section (input)
+  (consume-token input)
+  (let ((input (car (zstream-input-stack input))))
+    (unless (and (rune= #/C (read-rune input))
+		 (rune= #/D (read-rune input))
+		 (rune= #/A (read-rune input))
+		 (rune= #/T (read-rune input))
+		 (rune= #/A (read-rune input))
+		 (rune= #/\[ (read-rune input)))
+      (wf-error input "After '<![', 'CDATA[' is expected."))
+    (validate-characters *ctx* #"hack")	;anything other than whitespace
+    (read-cdata-sect input)))
+
+(defun p/content (input)
+  ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)*
+  (loop
+     (multiple-value-bind (cat sem) (peek-token input)
+       (case cat
+	 ((:stag :ztag)
+	  (p/element input))
+	 ((:CDATA)
+	  (process-characters input sem)
+	  (sax:characters (handler *ctx*) sem))
+	 ((:ENTITY-REF)
+	  (let ((name sem))
+	    (consume-token input)
+	    (recurse-on-entity input name :general
+			       (lambda (input)
+				 (prog1
+				     (etypecase (checked-get-entdef name :general)
+				       (internal-entdef (p/content input))
+				       (external-entdef (p/ext-parsed-ent input)))
+				   (unless (eq (peek-token input) :eof)
+				     (wf-error input "Trailing garbage. - ~S"
+					       (peek-token input))))))))
+	 ((:<!\[)
+	  (let ((data (process-cdata-section input)))
+	    (sax:start-cdata (handler *ctx*))
+	    (sax:characters (handler *ctx*) data)
+	    (sax:end-cdata (handler *ctx*))))
+	 ((:PI)
+	  (consume-token input)
+	  (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)))
+	 ((:COMMENT)
+	  (consume-token input)
+	  (sax:comment (handler *ctx*) sem))
+	 (otherwise
+	  (return))))))
+
+;; [78] extParsedEnt ::= TextDecl? contentw
+;; [79]        extPE ::= TextDecl? extSubsetDecl
+
+(defstruct xml-header
+  version
+  encoding
+  (standalone-p nil))
+
+(defun p/ext-parsed-ent (input)
+  ;; [78] extParsedEnt ::= '<?xml' VersionInfo? EncodingDecl S? '?>' content
+  (when (eq (peek-token input) :xml-decl)
+    (let ((hd (parse-text-decl (cdr (nth-value 1 (peek-token input))))))
+      (setup-encoding input hd))
+    (consume-token input))
+  (set-full-speed input)
+  (p/content input))
+
+(defun parse-xml-decl (content)
+  (let* ((res (make-xml-header))
+	 (i (make-rod-xstream content)))
+    (with-zstream (z :input-stack (list i))
+      (let ((atts (read-attribute-list z i t)))
+	(unless (eq (peek-rune i) :eof)
+	  (wf-error i "Garbage at end of XMLDecl."))
+	;; versioninfo muss da sein
+	;; dann ? encodingdecl
+	;; dann ? sddecl
+	;; dann ende
+	(unless (eq (caar atts) (intern-name '#.(string-rod "version")))
+	  (wf-error i "XMLDecl needs version."))
+	(unless (and (>= (length (cdar atts)) 1)
+		     (every (lambda (x)
+			      (or (rune<= #/a x #/z)
+				  (rune<= #/A x #/Z)
+				  (rune<= #/0 x #/9)
+				  (rune= x #/_)
+				  (rune= x #/.)
+				  (rune= x #/:)
+				  (rune= x #/-)))
+			    (cdar atts)))
+	  (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts))))
+	(setf (xml-header-version res) (rod-string (cdar atts)))
+	(pop atts)
+	(when (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+	  (unless (and (>= (length (cdar atts)) 1)
+		       (every (lambda (x)
+				(or (rune<= #/a x #/z)
+				    (rune<= #/A x #/Z)
+				    (rune<= #/0 x #/9)
+				    (rune= x #/_)
+				    (rune= x #/.)
+				    (rune= x #/-)))
+			      (cdar atts))
+		       ((lambda (x)
+			  (or (rune<= #/a x #/z)
+			      (rune<= #/A x #/Z)))
+			(aref (cdar atts) 0)))
+	    (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+	  (setf (xml-header-encoding res) (rod-string (cdar atts)))
+	  (pop atts))
+	(when (eq (caar atts) (intern-name '#.(string-rod "standalone")))
+	  (unless (or (rod= (cdar atts) '#.(string-rod "yes"))
+		      (rod= (cdar atts) '#.(string-rod "no")))
+	    (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S."
+		      (rod-string (cdar atts))))
+	  (setf (xml-header-standalone-p res)
+		(if (rod-equal '#.(string-rod "yes") (cdar atts))
+		    :yes
+		    :no))
+	  (pop atts))
+	(when atts
+	  (wf-error i "Garbage in XMLDecl: ~A" (rod-string content)))
+	res))))
+
+(defun parse-text-decl (content)
+  (let* ((res (make-xml-header))
+         (i (make-rod-xstream content)))
+    (with-zstream (z :input-stack (list i))
+      (let ((atts (read-attribute-list z i t)))
+	(unless (eq (peek-rune i) :eof)
+	  (wf-error i "Garbage at end of TextDecl"))
+	;; versioninfo optional
+	;; encodingdecl muss da sein
+	;; dann ende
+	(when (eq (caar atts) (intern-name '#.(string-rod "version")))
+	  (unless (and (>= (length (cdar atts)) 1)
+		       (every (lambda (x)
+				(or (rune<= #/a x #/z)
+				    (rune<= #/A x #/Z)
+				    (rune<= #/0 x #/9)
+				    (rune= x #/_)
+				    (rune= x #/.)
+				    (rune= x #/:)
+				    (rune= x #/-)))
+			      (cdar atts)))
+	    (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts))))
+	  (setf (xml-header-version res) (rod-string (cdar atts)))
+	  (pop atts)) 
+	(unless (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+	  (wf-error i "TextDecl needs encoding."))
+	(unless (and (>= (length (cdar atts)) 1)
+		     (every (lambda (x)
+			      (or (rune<= #/a x #/z)
+				  (rune<= #/A x #/Z)
+				  (rune<= #/0 x #/9)
+				  (rune= x #/_)
+				  (rune= x #/.)
+				  (rune= x #/-)))
+			    (cdar atts))
+		     ((lambda (x)
+			(or (rune<= #/a x #/z)
+			    (rune<= #/A x #/Z)
+			    (rune<= #/0 x #/9)))
+		      (aref (cdar atts) 0)))
+	  (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+	(setf (xml-header-encoding res) (rod-string (cdar atts)))
+	(pop atts)
+	(when atts
+	  (wf-error i "Garbage in TextDecl: ~A" (rod-string content)))))
+    res))
+
+;;;; ---------------------------------------------------------------------------
+;;;;  mu
+;;;;
+
+(defun mu (x)
+  (cond ((stringp x) x)
+        ((vectorp x) (rod-string x))
+        ((consp x)
+         (cons (mu (car x)) (mu (cdr x))))
+        (x)))
+
+;;;; ---------------------------------------------------------------------------
+;;;; User interface ;;;;
+
+#-cxml-system::uri-is-namestring
+(defun specific-or (component &optional (alternative nil))
+  (if (eq component :unspecific)
+      alternative
+      component))
+
+(defun string-or (str &optional (alternative nil))
+  (if (zerop (length str))
+      alternative
+      str))
+
+#-cxml-system::uri-is-namestring
+(defun make-uri (&rest initargs &key path query &allow-other-keys)
+  (apply #'make-instance
+         'puri:uri
+         :path (and path (escape-path path))
+         :query (and query (escape-query query))
+         initargs))
+
+#-cxml-system::uri-is-namestring
+(defun escape-path (list)
+  (puri::render-parsed-path list t))
+
+#-cxml-system::uri-is-namestring
+(defun escape-query (pairs)
+  (flet ((escape (str)
+           (puri::encode-escaped-encoding str puri::*reserved-characters* t)))
+    (let ((first t))
+      (with-output-to-string (s)
+        (dolist (pair pairs)
+          (if first
+              (setf first nil)
+              (write-char #\& s))
+          (write-string (escape (car pair)) s)
+          (write-char #\= s)
+          (write-string (escape (cdr pair)) s))))))
+
+#-cxml-system::uri-is-namestring
+(defun uri-parsed-query (uri)
+  (flet ((unescape (str)
+           (puri::decode-escaped-encoding str t puri::*reserved-characters*)))
+    (let ((str (puri:uri-query uri)))
+      (cond
+        (str
+          (let ((pairs '()))
+            (dolist (s (split-sequence-if (lambda (x) (eql x #\&)) str))
+              (destructuring-bind (name value)
+                  (split-sequence-if (lambda (x) (eql x #\=)) s)
+                (push (cons (unescape name) (unescape value)) pairs)))
+            (reverse pairs)))
+        (t
+          nil)))))
+
+#-cxml-system::uri-is-namestring
+(defun query-value (name alist)
+  (cdr (assoc name alist :test #'equal)))
+
+#-cxml-system::uri-is-namestring
+(defun pathname-to-uri (pathname)
+  (let ((path
+         (append (pathname-directory pathname)
+                 (list
+                  (if (specific-or (pathname-type pathname))
+                      (concatenate 'string
+                        (pathname-name pathname)
+                        "."
+                        (pathname-type pathname))
+                      (pathname-name pathname))))))
+    (if (eq (car path) :relative)
+        (make-uri :path path)
+        (make-uri :scheme :file
+                  :host (concatenate 'string
+                          (string-or (host-namestring pathname))
+                          "+"
+                          (specific-or (pathname-device pathname)))
+                  :path path))))
+
+#+cxml-system::uri-is-namestring
+(defun pathname-to-uri (pathname)
+  (puri:parse-uri (namestring pathname)))
+
+#-cxml-system::uri-is-namestring
+(defun parse-name.type (str)
+  (if str
+      (let ((i (position #\. str :from-end t)))
+        (if i
+            (values (subseq str 0 i) (subseq str (1+ i)))
+            (values str nil)))
+      (values nil nil)))
+
+#-cxml-system::uri-is-namestring
+(defun uri-to-pathname (uri)
+  (let ((scheme (puri:uri-scheme uri))
+        (path (puri:uri-parsed-path uri)))
+    (unless (member scheme '(nil :file))
+      (error 'xml-parse-error
+             :format-control "URI scheme ~S not supported"
+             :format-arguments (list scheme)))
+    (if (eq (car path) :relative)
+        (multiple-value-bind (name type)
+            (parse-name.type (car (last path)))
+          (make-pathname :directory (butlast path)
+                         :name name
+                         :type type))
+        (multiple-value-bind (name type)
+            (parse-name.type (car (last (cdr path))))
+          (destructuring-bind (host device)
+              (split-sequence-if (lambda (x) (eql x #\+))
+                                 (or (puri:uri-host uri) "+"))
+            (make-pathname :host (string-or host)
+                           :device (string-or device)
+                           :directory (cons :absolute (butlast (cdr path)))
+                           :name name
+                           :type type))))))
+#+cxml-system::uri-is-namestring
+(defun uri-to-pathname (uri)
+  (let ((pathname (puri:render-uri uri nil)))
+    (when (equalp (pathname-host pathname) "+")
+      (setf (slot-value pathname 'lisp::host) "localhost"))
+    pathname))
+
+(defun parse
+    (input handler &rest args
+     &key validate dtd root entity-resolver disallow-internal-subset
+          recode pathname)
+  (declare (ignore validate dtd root entity-resolver disallow-internal-subset
+		   recode))
+  (let ((args
+	 (loop
+	    for (name value) on args by #'cddr
+	    unless (eq name :pathname)
+	    append (list name value))))
+    (etypecase input
+      (xstream  (apply #'parse-xstream input handler args))
+      (pathname (apply #'parse-file input handler args))
+      (rod      (apply #'parse-rod input handler args))
+      (array    (apply #'parse-octets input handler args))
+      (stream 
+       (let ((xstream (make-xstream input :speed 8192)))
+	 (setf (xstream-name xstream)
+	       (make-stream-name
+		:entity-name "main document"
+		:entity-kind :main
+		:uri (pathname-to-uri
+		      (merge-pathnames (or pathname (pathname input))))))
+	 (apply #'parse-xstream xstream handler args))))))
+
+(defun parse-xstream (xstream handler &rest args)
+  (let ((*ctx* nil))
+    (handler-case
+	(with-zstream (zstream :input-stack (list xstream))
+	  (peek-rune xstream)
+	  (with-scratch-pads ()
+	    (apply #'p/document zstream handler args)))
+      (runes-encoding:encoding-error (c)
+	(wf-error xstream "~A" c)))))
+
+(defun parse-file (filename handler &rest args)
+  (with-open-xfile (input filename)
+    (setf (xstream-name input)
+      (make-stream-name
+       :entity-name "main document"
+       :entity-kind :main
+       :uri (pathname-to-uri (merge-pathnames filename))))
+    (apply #'parse-xstream input handler args)))
+
+(defun resolve-synonym-stream (stream)
+  (while (typep stream 'synonym-stream)
+    (setf stream (symbol-value (synonym-stream-symbol stream))))
+  stream)
+
+(defun safe-stream-sysid (stream)
+  (if (and (typep (resolve-synonym-stream stream) 'file-stream)
+	   ;; ignore-errors, because sb-bsd-sockets creates instances of
+	   ;; FILE-STREAMs that aren't
+           (ignore-errors (pathname stream)))
+      (pathname-to-uri (merge-pathnames (pathname stream)))
+      nil))
+
+(defun parse-stream (stream handler &rest args)
+  (let ((xstream
+         (make-xstream
+          stream
+          :name (make-stream-name
+                 :entity-name "main document"
+                 :entity-kind :main
+                 :uri (safe-stream-sysid stream))
+          :initial-speed 1)))
+    (apply #'parse-xstream xstream handler args)))
+
+(defun parse-empty-document
+    (uri qname handler &key public-id system-id entity-resolver (recode t))
+  (check-type uri (or null rod))
+  (check-type qname (or null rod))
+  (check-type public-id (or null rod))
+  (check-type system-id (or null puri:uri))
+  (check-type entity-resolver (or null function symbol))
+  (check-type recode boolean)
+  #+rune-is-integer
+  (when recode
+    (setf handler (make-recoder handler #'rod-to-utf8-string)))
+  (let ((*ctx*
+         (make-context :handler handler :entity-resolver entity-resolver))
+        (*validate* nil)
+	(extid
+	 (when (or public-id system-id)
+	   (extid-using-catalog (make-extid public-id system-id)))))
+    (sax:start-document handler)
+    (when extid
+      (sax:start-dtd handler
+                     qname
+                     (and public-id)
+                     (and system-id (uri-rod system-id)))
+      (setf (dtd *ctx*) (getdtd (extid-system extid) *dtd-cache*))
+      (unless (dtd *ctx*)
+	(with-scratch-pads ()
+	  (let ((*data-behaviour* :DTD))
+	    (let ((xi2 (xstream-open-extid extid)))
+	      (with-zstream (zi2 :input-stack (list xi2))
+		(ensure-dtd)
+		(p/ext-subset zi2))))))
+      (sax:end-dtd handler)
+      (let ((dtd (dtd *ctx*)))
+        (sax:entity-resolver handler (lambda (n h) (resolve-entity n h dtd)))
+        (sax::dtd handler dtd)))
+    (ensure-dtd)
+    (when (or uri qname)
+      (let* ((attrs
+	      (when uri
+		(list (sax:make-attribute :qname #"xmlns"
+					  :value (rod uri)
+					  :specified-p t))))
+	     (*namespace-bindings* *namespace-bindings*)
+	     new-namespaces)
+	(when sax:*namespace-processing*
+	  (setf new-namespaces (declare-namespaces attrs))
+	  (mapc #'set-attribute-namespace attrs))
+	(multiple-value-bind (uri prefix local-name)
+	    (if sax:*namespace-processing* (decode-qname qname) nil)
+	  (declare (ignore prefix))
+	  (unless (or sax:*include-xmlns-attributes*
+		      (null sax:*namespace-processing*))
+	    (setf attrs nil)) 
+	  (sax:start-element (handler *ctx*) uri local-name qname attrs)
+	  (sax:end-element (handler *ctx*) uri local-name qname))
+	(undeclare-namespaces new-namespaces)))
+    (sax:end-document handler)))
+
+(defun parse-dtd-file (filename &optional handler)
+  (with-open-file (s filename :element-type '(unsigned-byte 8))
+    (parse-dtd-stream s handler)))
+
+(defun parse-dtd-stream (stream &optional handler)
+  (let ((input (make-xstream stream)))
+    (setf (xstream-name input)
+          (make-stream-name
+           :entity-name "dtd"
+           :entity-kind :main
+           :uri (safe-stream-sysid stream)))
+    (let ((*ctx* (make-context :handler handler))
+          (*validate* t)
+          (*data-behaviour* :DTD))
+      (with-zstream (zstream :input-stack (list input))
+	(with-scratch-pads ()
+	  (ensure-dtd)
+	  (peek-rune input)
+	  (p/ext-subset zstream)
+	  (dtd *ctx*))))))
+
+(defun parse-rod (string handler &rest args)
+  (let ((xstream (string->xstream string)))
+    (setf (xstream-name xstream)
+	  (make-stream-name
+	   :entity-name "main document"
+	   :entity-kind :main
+	   :uri nil))
+    (apply #'parse-xstream xstream handler args)))
+
+(defun string->xstream (string)
+  (make-rod-xstream (string-rod string)))
+
+(defun parse-octets (octets handler &rest args)
+  (apply #'parse-stream (make-octet-input-stream octets) handler args))
+
+;;;;
+
+(defun zstream-push (new-xstream zstream)
+  (cond ((find-if (lambda (x)
+                    (and (xstream-p x)
+                         (eql (stream-name-entity-name (xstream-name x))
+                              (stream-name-entity-name (xstream-name new-xstream)))
+                         (eql (stream-name-entity-kind (xstream-name x))
+                              (stream-name-entity-kind (xstream-name new-xstream)))))
+                  (zstream-input-stack zstream))
+         (wf-error zstream "Infinite recursion.")))
+  (push new-xstream (zstream-input-stack zstream))
+  zstream)
+
+(defun recurse-on-entity (zstream name kind continuation &optional internalp)
+  (assert (not (zstream-token-category zstream)))
+  (call-with-entity-expansion-as-stream
+   zstream
+   (lambda (new-xstream)
+     (push :stop (zstream-input-stack zstream))
+     (zstream-push new-xstream zstream)
+     (prog1
+         (funcall continuation zstream)
+       (assert (eq (peek-token zstream) :eof))
+       (assert (eq (pop (zstream-input-stack zstream)) new-xstream))
+       (close-xstream new-xstream)
+       (assert (eq (pop (zstream-input-stack zstream)) :stop))
+       (setf (zstream-token-category zstream) nil)
+       '(consume-token zstream)) )
+   name
+   kind
+   internalp))
+
+#||
+(defmacro read-data-until* ((predicate input res res-start res-end) &body body)
+  ;; fast variant -- for now disabled for no apparent reason
+  ;; -> res, res-start, res-end
+  `(let* ((rptr (xstream-read-ptr ,input))
+          (p0   rptr)
+          (fptr (xstream-fill-ptr ,input))
+          (buf  (xstream-buffer ,input))
+          ,res ,res-start ,res-end)
+    (declare (type fixnum rptr fptr p0)
+             (type (simple-array read-element (*)) buf))
+    (loop
+      (cond ((%= rptr fptr)
+             ;; underflow -- hmm inject the scratch-pad with what we
+             ;; read and continue, while using read-rune and collecting
+             ;; d.h. besser waere hier auch while-reading zu benutzen.
+             (setf (xstream-read-ptr ,input) rptr)
+             (multiple-value-setq (,res ,res-start ,res-end)
+               (with-rune-collector/raw (collect)
+                 (do ((i p0 (%+ i 1)))
+                     ((%= i rptr))
+                   (collect (%rune buf i)))
+                 (let (c)
+                   (loop
+                     (cond ((%= rptr fptr)
+                            (setf (xstream-read-ptr ,input) rptr)
+                            (setf c (peek-rune input))
+                            (cond ((eq c :eof)
+                                   (return)))
+                            (setf rptr (xstream-read-ptr ,input)
+                                  fptr (xstream-fill-ptr ,input)
+                                  buf  (xstream-buffer ,input)))
+                           (t
+                            (setf c (%rune buf rptr))))
+                     (cond ((,predicate c)
+                            ;; we stop
+                            (setf (xstream-read-ptr ,input) rptr)
+                            (return))
+                           (t
+                            ;; we continue
+                            (collect c)
+                            (setf rptr (%+ rptr 1))) )))))
+             (return))
+            ((,predicate (%rune buf rptr))
+             ;; we stop
+             (setf (xstream-read-ptr ,input) rptr)
+             (setf ,res buf ,res-start p0 ,res-end rptr)
+             (return) )
+            (t
+            we continue
+             (sf rptr (%+ rptr 1))) ))
+    , at body ))
+||#
+
+(defmacro read-data-until* ((predicate input res res-start res-end) &body body)
+  "Read data from `input' until `predicate' applied to the read char
+   turns true. Then execute `body' with `res', `res-start', `res-end'
+   bound to denote a subsequence (of RUNEs) containing the read portion.
+   The rune upon which `predicate' turned true is neither consumed from
+   the stream, nor included in `res'.
+
+   Keep the predicate short, this it may be included more than once into
+   the macro's expansion."
+  ;;
+  (let ((input-var (gensym))
+        (collect (gensym))
+        (c (gensym)))
+    `(LET ((,input-var ,input))
+       (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end)
+           (WITH-RUNE-COLLECTOR/RAW (,collect)
+             (LOOP
+               (LET ((,c (PEEK-RUNE ,input-var)))
+                 (COND ((EQ ,c :EOF)
+                        ;; xxx error message
+                        (RETURN))
+                       ((FUNCALL ,predicate ,c)
+                        (RETURN))
+                       (t
+                        (,collect ,c)
+                        (CONSUME-RUNE ,input-var))))))
+         (LOCALLY
+           , at body)))))
+
+(defun read-name-token (input)
+  (read-data-until* ((lambda (rune)
+                       (declare (type rune rune))
+                       (not (name-rune-p rune)))
+                     input
+                     r rs re)
+                    (intern-name r rs re)))
+
+(defun read-cdata (input)
+  (read-data-until* ((lambda (rune)
+                       (declare (type rune rune))
+		       (when (and (%rune< rune #/U+0020)
+				  (not (or (%rune= rune #/U+0009)
+					   (%rune= rune #/U+000a)
+					   (%rune= rune #/U+000d))))
+			 (wf-error input "code point invalid: ~A" rune))
+                       (or (%rune= rune #/<) (%rune= rune #/&)))
+                     input
+                     source start end)
+                    (locally
+                     (declare (type (simple-array rune (*)) source)
+                              (type ufixnum start)
+                              (type ufixnum end)
+                              (optimize (speed 3) (safety 0)))
+                     (let ((res (make-array (%- end start) :element-type 'rune)))
+                       (declare (type (simple-array rune (*)) res))
+                       (let ((i (%- end start)))
+                         (declare (type ufixnum i))
+                         (loop
+                           (setf i (- i 1))
+                           (setf (%rune res i) (%rune source (the ufixnum (+ i start))))
+                           (when (= i 0)
+                             (return))))
+                       res))))
+
+;; used only by read-att-value-2
+(defun internal-entity-expansion (name)
+  (let ((def (get-entity-definition name :general (dtd *ctx*))))
+    (unless def
+      (wf-error nil "Entity '~A' is not defined." (rod-string name)))
+    (unless (typep def 'internal-entdef)
+      (wf-error nil "Entity '~A' is not an internal entity." name))
+    (or (entdef-expansion def)
+        (setf (entdef-expansion def) (find-internal-entity-expansion name)))))
+
+;; used only by read-att-value-2
+(defun find-internal-entity-expansion (name)
+  (with-zstream (zinput)
+    (with-rune-collector-3 (collect)
+      (labels ((muffle (input)
+		 (let (c)
+		   (loop
+		    (setf c (read-rune input))
+		    (cond ((eq c :eof)
+			   (return))
+			  ((rune= c #/&)
+			   (setf c (peek-rune input))
+			   (cond ((eql c :eof)
+				  (eox input))
+				 ((rune= c #/#)
+				  (let ((c (read-character-reference input)))
+				    (%put-unicode-char c collect)))
+				 (t
+				  (unless (name-start-rune-p c)
+				    (wf-error zinput "Expecting name after &."))
+				  (let ((name (read-name-token input)))
+				    (setf c (read-rune input))
+				    (check-rune input c #/\;)
+				    (recurse-on-entity
+				     zinput name :general
+				     (lambda (zinput)
+				       (muffle (car (zstream-input-stack zinput)))))))))
+			  ((rune= c #/<)
+			   (wf-error zinput "unexpected #\/<"))
+			  ((space-rune-p c)
+			   (collect #/space))
+			  ((not (data-rune-p c))
+			   (wf-error zinput "illegal char: ~S." c))
+			  (t
+			   (collect c)))))))
+	(declare (dynamic-extent #'muffle))
+	(recurse-on-entity
+	 zinput name :general
+	 (lambda (zinput)
+	   (muffle (car (zstream-input-stack zinput)))))))))
+
+;; callback for DOM
+(defun resolve-entity (name handler dtd)
+  (let ((*validate* nil))
+    (if (get-entity-definition name :general dtd)
+        (let* ((*ctx* (make-context :handler handler :dtd dtd))
+               (*data-behaviour* :DOC))
+	  (with-zstream (input)
+	    (with-scratch-pads ()
+	      (recurse-on-entity
+	       input name :general
+	       (lambda (input)
+		 (prog1
+		     (etypecase (checked-get-entdef name :general)
+		       (internal-entdef (p/content input))
+		       (external-entdef (p/ext-parsed-ent input)))
+		   (unless (eq (peek-token input) :eof)
+		     (wf-error input "Trailing garbage. - ~S"
+			       (peek-token input)))))))))
+        nil)))
+
+(defun read-att-value-2 (input)
+  (let ((delim (read-rune input)))
+    (when (eql delim :eof)
+      (eox input))
+    (unless (member delim '(#/\" #/\') :test #'eql)
+      (wf-error input
+		"Bad attribute value delimiter ~S, must be either #\\\" or #\\\'."
+		(rune-char delim)))
+    (with-rune-collector-4 (collect)
+      (loop
+        (let ((c (read-rune input)))
+          (cond ((eq c :eof)
+                 (eox input "EOF"))
+                ((rune= c delim)
+                 (return))
+                ((rune= c #/<)
+		 (wf-error input "'<' not allowed in attribute values"))
+                ((rune= #/& c)
+                 (multiple-value-bind (kind sem) (read-entity-like input)
+                   (ecase kind
+                     (:CHARACTER-REFERENCE
+                      (%put-unicode-char sem collect))
+                     (:ENTITY-REFERENCE
+                      (let* ((exp (internal-entity-expansion sem))
+                             (n (length exp)))
+                        (declare (type (simple-array rune (*)) exp))
+                        (do ((i 0 (%+ i 1)))
+                            ((%= i n))
+                          (collect (%rune exp i))))))))
+                ((space-rune-p c)
+                 (collect #/u+0020))
+                (t
+                 (collect c))))))))
+
+;;;;;;;;;;;;;;;;;
+
+;;; Namespace stuff
+
+;; We already know that name is part of a valid XML name, so all we
+;; have to check is that the first rune is a name-start-rune and that
+;; there is not colon in it.
+(defun nc-name-p (name)
+  (and (plusp (length name))
+       (name-start-rune-p (rune name 0))
+       (notany #'(lambda (rune) (rune= #/: rune)) name)))
+
+(defun split-qname (qname)
+  (declare (type runes:simple-rod qname))
+  (let ((pos (position  #/: qname)))
+    (if pos
+	(let ((prefix (subseq qname 0 pos))
+	      (local-name (subseq qname (1+ pos))))
+	  (when (zerop pos)
+	    (wf-error nil "empty namespace prefix"))
+	  (if (nc-name-p local-name)
+	      (values prefix local-name)
+	      (wf-error nil "~S is not a valid NcName."
+			(rod-string local-name))))
+	(values () qname))))
+		
+(defun decode-qname (qname)
+  "decode-qname name => namespace-uri, prefix, local-name"
+  (declare (type runes:simple-rod qname))
+  (multiple-value-bind (prefix local-name) (split-qname qname)
+    (let ((uri (find-namespace-binding prefix)))
+      (if uri
+	  (values uri prefix local-name)
+	  (values nil nil qname)))))
+
+
+(defun find-namespace-binding (prefix)
+  (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=)
+	   (wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix)))))
+
+;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal
+(defun rod-starts-with (prefix rod)
+  (and (<= (length prefix) (length rod))
+       (dotimes (i (length prefix) t)
+         (unless (rune= (rune prefix i) (rune rod i))
+           (return nil)))))
+
+(defun xmlns-attr-p (attr-name)
+  (rod-starts-with #.(string-rod "xmlns") attr-name))
+
+(defun attrname->prefix (attrname)
+  (if (< 5 (length attrname))
+      (subseq attrname 6)
+      nil))
+
+(defun find-namespace-declarations (attributes)
+  (loop
+      for attribute in attributes
+      for qname = (sax:attribute-qname attribute)
+      when (xmlns-attr-p qname)
+      collect (cons (attrname->prefix qname) (sax:attribute-value attribute))))
+
+(defun declare-namespaces (attributes)
+  (let ((ns-decls (find-namespace-declarations attributes)))
+    (dolist (ns-decl ns-decls)
+      ;; check some namespace validity constraints
+      (let ((prefix (car ns-decl))
+	    (uri (cdr ns-decl)))
+	(cond
+	  ((and (rod= prefix #"xml")
+		(not (rod= uri #"http://www.w3.org/XML/1998/namespace")))
+	   (wf-error nil
+		     "Attempt to rebind the prefix \"xml\" to ~S." (mu uri)))
+	  ((and (rod= uri #"http://www.w3.org/XML/1998/namespace")
+		(not (rod= prefix #"xml")))
+	   (wf-error nil
+		     "The namespace ~
+                      URI \"http://www.w3.org/XML/1998/namespace\" may not ~
+                      be bound to the prefix ~S, only \"xml\" is legal."
+		     (mu prefix)))
+	  ((and (rod= prefix #"xmlns")
+		(rod= uri #"http://www.w3.org/2000/xmlns/"))
+	   (wf-error nil
+		     "Attempt to bind the prefix \"xmlns\" to its predefined ~
+                      URI \"http://www.w3.org/2000/xmlns/\", which is ~
+                      forbidden for no good reason."))
+	  ((rod= prefix #"xmlns")
+	   (wf-error nil
+		     "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~
+                      but it may not be declared." (mu uri)))
+	  ((rod= uri #"http://www.w3.org/2000/xmlns/")
+	   (wf-error nil
+		     "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~
+                      not be bound to prefix ~S (or any other)." (mu prefix)))
+	  ((and (rod= uri #"") prefix)
+	   (wf-error nil
+		     "Only the default namespace (the one without a prefix) ~
+                      may be bound to an empty namespace URI, thus ~
+                      undeclaring it."))
+	  (t
+	   (push (cons prefix (if (rod= #"" uri) nil uri))
+		 *namespace-bindings*)
+	   (sax:start-prefix-mapping (handler *ctx*)
+				     (car ns-decl)
+				     (cdr ns-decl))))))
+    ns-decls))
+
+(defun undeclare-namespaces (ns-decls)
+  (dolist (ns-decl ns-decls)
+    (sax:end-prefix-mapping (handler *ctx*) (car ns-decl))))
+
+(defun build-attribute-list (attr-alist)
+  ;; fixme: if there is a reason this function reverses attribute order,
+  ;; it should be documented.
+  (let (attributes)
+    (dolist (pair attr-alist)
+      (push (sax:make-attribute :qname (car pair)
+				:value (cdr pair)
+				:specified-p t)
+	    attributes))
+    attributes))
+
+(defun check-attribute-uniqueness (attributes)
+  ;; 5.3 Uniqueness of Attributes
+  ;; In XML documents conforming to [the xmlns] specification, no
+  ;; tag may contain two attributes which:
+  ;; 1. have identical names, or
+  ;; 2. have qualified names with the same local part and with
+  ;; prefixes which have been bound to namespace names that are
+  ;; identical.
+  ;;
+  ;; 1. is checked by read-tag-2, so we only deal with 2 here
+  (loop for (attr-1 . rest) on attributes do
+	(when (and (sax:attribute-namespace-uri attr-1)
+		   (find-if (lambda (attr-2)
+			      (and (rod= (sax:attribute-namespace-uri attr-1)
+					 (sax:attribute-namespace-uri attr-2))
+				   (rod= (sax:attribute-local-name attr-1)
+					 (sax:attribute-local-name attr-2))))
+			    rest))
+	  (wf-error nil
+		    "Multiple definitions of attribute ~S in namespace ~S."
+		    (mu (sax:attribute-local-name attr-1))
+		    (mu (sax:attribute-namespace-uri attr-1))))))
+
+(defun set-attribute-namespace (attribute)
+  (let ((qname (sax:attribute-qname attribute)))
+    (if (and sax:*use-xmlns-namespace* (rod= qname #"xmlns"))
+	(setf (sax:attribute-namespace-uri attribute)
+	      #"http://www.w3.org/2000/xmlns/")
+	(multiple-value-bind (prefix local-name) (split-qname qname)
+	  (when (and prefix ;; default namespace doesn't apply to attributes
+		     (or (not (rod= #"xmlns" prefix))
+			 sax:*use-xmlns-namespace*))
+	    (setf (sax:attribute-namespace-uri attribute)
+		  (decode-qname qname)))
+	  (setf (sax:attribute-local-name attribute) local-name)))))
+
+;;;;;;;;;;;;;;;;;
+
+;; System Identifier Protocol
+
+;; A system identifier is an object obeying to the system identifier
+;; protocol. Often something like an URL or a pathname.
+
+;; OPEN-SYS-ID sys-id                                   [generic function]
+;;
+;; Opens the resource associated with the system identifier `sys-id'
+;; for reading and returns a stream. For now it is expected, that the
+;; stream is an octet stream (one of element type (unsigned-byte 8)).
+;;
+;; More precisely: The returned object only has to obey to the xstream
+;; controller protocol. (That is it has to provide implementations for
+;; READ-OCTETS and XSTREAM-CONTROLLER-CLOSE).
+
+;; MERGE-SYS-ID sys-id base                             [generic function]
+;;
+;; Merges two system identifiers. That is resolve `sys-id' relative to
+;; `base' yielding an absolute system identifier suitable for
+;; OPEN-SYS-ID.
+
+
+;;;;;;;;;;;;;;;;;
+;;; SAX validation handler
+
+(defclass validator ()
+    ((context :initarg :context :accessor context)
+     (cdatap :initform nil :accessor cdatap)))
+
+(defun make-validator (dtd root)
+  (make-instance 'validator
+    :context (make-context
+              :handler nil
+              :dtd dtd
+              :model-stack (list (make-root-model root)))))
+
+(macrolet ((with-context ((validator) &body body)
+             `(let ((*ctx* (context ,validator))
+                    (*validate* t))
+                (with-scratch-pads ()   ;nicht schoen
+                  , at body))))
+  (defmethod sax:start-element ((handler validator) uri lname qname attributes)
+    uri lname
+    (with-context (handler)
+      (validate-start-element *ctx* qname)
+      (process-attributes *ctx* qname attributes)))
+
+  (defmethod sax:start-cdata ((handler validator))
+    (setf (cdatap handler) t))
+
+  (defmethod sax:characters ((handler validator) data)
+    (with-context (handler)
+      (validate-characters *ctx* (if (cdatap handler) #"hack" data))))
+
+  (defmethod sax:end-cdata ((handler validator))
+    (setf (cdatap handler) nil))
+
+  (defmethod sax:end-element ((handler validator) uri lname qname)
+    uri lname
+    (with-context (handler)
+      (validate-end-element *ctx* qname))))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmlns-normalizer.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmlns-normalizer.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,136 @@
+;;;; xmlns-normalizer.lisp -- DOM 3-style namespace normalization
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Copyright (c) 2005 David Lichteblau
+
+;;;; Hier eine Variante des reichlich furchtbaren Algorithmus zur
+;;;; Namespace-Normalisierung aus DOM 3 Core.[1]
+;;;;
+;;;; Gebraucht wir die Sache, weil Element- und Attributknoten in DOM
+;;;; zwar ein Prefix-Attribut speichern, massgeblich fuer ihren Namespace
+;;;; aber nur die URI sein soll.  Und eine Anpassung der zugehoerigen
+;;;; xmlns-Attribute findet bei Veraenderungen im DOM-Baum nicht statt,
+;;;; bzw. wird dem Nutzer ueberlassen.
+;;;;
+;;;; Daher muss letztlich spaetestens beim Serialisieren eine
+;;;; Namespace-Deklaration fuer die angegebene URI nachgetragen und das
+;;;; Praefix ggf. umbenannt werden, damit am Ende doch etwas
+;;;; Namespace-konformes heraus kommt.
+;;;;
+;;;; Und das nennen sie dann Namespace-Support.
+;;;;
+;;;; [1] http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/namespaces-algorithms.html#normalizeDocumentAlgo
+
+(in-package :cxml)
+
+(defclass namespace-normalizer (sax-proxy)
+    ((xmlns-stack :initarg :xmlns-stack :accessor xmlns-stack)))
+
+(defvar *xmlns-namespace* #"http://www.w3.org/2000/xmlns/")
+
+(defun make-namespace-normalizer (chained-handler)
+  (make-instance 'namespace-normalizer
+    :xmlns-stack (list (mapcar (lambda (cons)
+				 (make-xmlns-attribute (car cons) (cdr cons)))
+			       *initial-namespace-bindings*))
+    :chained-handler chained-handler))
+
+(defun normalizer-find-prefix (handler prefix)
+  (when (zerop (length prefix))
+    (setf prefix #"xmlns"))
+  (block t
+    (dolist (bindings (xmlns-stack handler))
+      (dolist (attribute bindings)
+	(when (rod= (sax:attribute-local-name attribute) prefix)
+	  (return-from t attribute))))))
+
+(defun normalizer-find-uri (handler uri)
+  (block t
+    (dolist (bindings (xmlns-stack handler))
+      (dolist (attribute bindings)
+	(when (and (rod= (sax:attribute-value attribute) uri)
+		   ;; default-namespace interessiert uns nicht
+		   (not (rod= (sax:attribute-qname attribute) #"xmlns")))
+	  (return-from t attribute))))))
+
+(defun make-xmlns-attribute (prefix uri)
+  (if (and (plusp (length prefix)) (not (equal prefix #"xmlns")))
+      (sax:make-attribute
+       :qname (concatenate 'rod #"xmlns:" prefix)
+       :namespace-uri *xmlns-namespace*
+       :local-name prefix
+       :value uri)
+      (sax:make-attribute
+       :qname #"xmlns"
+       :namespace-uri *xmlns-namespace*
+       :local-name #"xmlns"
+       :value uri)))
+
+(defun rename-attribute (a new-prefix)
+  (setf (sax:attribute-qname a)
+	(concatenate 'rod new-prefix #":" (sax:attribute-local-name a))))
+
+(defmethod sax:start-element
+    ((handler namespace-normalizer) uri lname qname attrs)
+  (when (null uri)
+    (setf uri #""))
+  (let ((normal-attrs '()))
+    (push nil (xmlns-stack handler))
+    (dolist (a attrs)
+      (if (rod= *xmlns-namespace* (sax:attribute-namespace-uri a))
+	  (push a (car (xmlns-stack handler)))
+	  (push a normal-attrs)))
+    (flet ((push-namespace (prefix uri)
+	     (let ((new (make-xmlns-attribute prefix uri)))
+	       (unless (find (sax:attribute-qname new)
+			     attrs
+			     :test #'rod=
+			     :key #'sax:attribute-qname)
+		 (push new (car (xmlns-stack handler)))
+		 (push new attrs)))))
+      (multiple-value-bind (prefix local-name) (split-qname qname)
+	(setf lname local-name)
+	(let ((binding (normalizer-find-prefix handler prefix)))
+	  (cond
+	    ((null binding)
+	      (unless (and (null prefix) (zerop (length uri)))
+		(push-namespace prefix uri)))
+	    ((rod= (sax:attribute-value binding) uri))
+	    ((member binding (car (xmlns-stack handler)))
+	      (setf (sax:attribute-value binding) uri))
+	    (t
+	      (push-namespace prefix uri)))))
+      (dolist (a normal-attrs)
+	(let ((u (sax:attribute-namespace-uri a)))
+	  (when u
+	    (let* ((prefix (split-qname (sax:attribute-qname a)))
+		   (prefix-binding
+		    (when prefix
+		      (normalizer-find-prefix handler prefix))))
+	      (when (or (null prefix-binding)
+			(not (rod= (sax:attribute-value prefix-binding) u)))
+		(let ((uri-binding (normalizer-find-uri handler u)))
+		  (cond
+		    (uri-binding
+		      (rename-attribute
+		       a
+		       (sax:attribute-local-name uri-binding)))
+		    ((and prefix (null prefix-binding))
+		      (push-namespace prefix u))
+		    (t
+		      (loop
+			  for i from 1
+			  for prefix = (rod (format nil "NS~D" i))
+			  unless (normalizer-find-prefix handler prefix)
+			  do
+			    (push-namespace prefix u)
+			    (rename-attribute a prefix)
+			    (return))))))))))))
+  (sax:start-element (proxy-chained-handler handler) uri lname qname attrs))
+
+(defmethod sax:end-element ((handler namespace-normalizer) uri lname qname)
+  (declare (ignore qname))
+  (pop (xmlns-stack handler))
+  (sax:end-element (proxy-chained-handler handler) (or uri #"") lname qname))

Added: branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmls-compat.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/cxml-2007-10-21/xml/xmls-compat.lisp	Sun Feb 17 09:26:33 2008
@@ -0,0 +1,243 @@
+;;;; xml-compat.lisp -- XMLS-compatible data structures
+;;;;
+;;;; This file is part of the CXML parser, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Developed 2004 for headcraft - http://headcraft.de/
+;;;; Copyright: David Lichteblau
+
+(defpackage cxml-xmls
+  (:use :cl :runes)
+  (:export #:make-node #:node-name #:node-ns #:node-attrs #:node-children
+           #:make-xmls-builder #:map-node))
+
+(in-package :cxml-xmls)
+
+
+;;;; Knoten
+
+(defun make-node (&key name ns attrs children)
+  `(,(if ns (cons name ns) name)
+       ,attrs
+       , at children))
+
+(defun node-name (node)
+  (let ((car (car node)))
+    (if (consp car)
+        (car car)
+        car)))
+
+(defun (setf node-name) (newval node)
+  (let ((car (car node)))
+    (if (consp car)
+        (setf (car car) newval)
+        (setf (car node) newval))))
+
+(defun node-ns (node)
+  (let ((car (car node)))
+    (if (consp car)
+        (cdr car)
+        nil)))
+
+(defun (setf node-ns) (newval node)
+  (let ((car (car node)))
+    (if (consp car)
+        (setf (cdr car) newval)
+        (setf (car node) (cons car newval)))
+    newval))
+
+(defun node-attrs (node)
+  (cadr node))
+
+(defun (setf node-attrs) (newval node)
+  (setf (cadr node) newval))
+
+(defun node-children (node)
+  (cddr node))
+
+(defun (setf node-children) (newval node)
+  (setf (cddr node) newval))
+
+
+;;;; SAX-Handler (Parser)
+
+(defclass xmls-builder ()
+    ((element-stack :initform nil :accessor element-stack)
+     (root :initform nil :accessor root)
+     (include-default-values :initform t
+                             :initarg :include-default-values
+                             :accessor include-default-values)
+     (include-namespace-uri :initform t
+			    :initarg :include-namespace-uri
+			    :accessor include-namespace-uri)))
+
+(defun make-xmls-builder (&key (include-default-values t)
+		               (include-namespace-uri t))
+  "Make a XMLS style builder.  When 'include-namespace-uri is true a modified
+  XMLS tree is generated that includes the element namespace URI rather than
+  the qualified name prefix and also includes the namespace URI for attributes."
+  (make-instance 'xmls-builder
+		 :include-default-values include-default-values
+		 :include-namespace-uri include-namespace-uri))
+
+(defmethod sax:end-document ((handler xmls-builder))
+  (root handler))
+
+(defmethod sax:start-element
+    ((handler xmls-builder) namespace-uri local-name qname attributes)
+  (let* ((include-default-values (include-default-values handler))
+	 (include-namespace-uri (include-namespace-uri handler))
+	 (attributes
+          (loop
+              for attr in attributes
+	      for attr-namespace-uri = (sax:attribute-namespace-uri attr)
+	      for attr-local-name = (sax:attribute-local-name attr)
+              when (and (or (sax:attribute-specified-p attr)
+			    include-default-values)
+			#+(or)
+			(or (not include-namespace-uri)
+			    (not attr-namespace-uri)
+			    attr-local-name))
+              collect
+                (list (cond (include-namespace-uri
+			     (cond (attr-namespace-uri
+				    (cons attr-local-name attr-namespace-uri))
+				   (t
+				    (sax:attribute-qname attr))))
+                            (t
+                             (sax:attribute-qname attr)))
+                      (sax:attribute-value attr))))
+	 (namespace (when include-namespace-uri namespace-uri))
+         (node (make-node :name local-name
+                          :ns namespace
+                          :attrs attributes))
+         (parent (car (element-stack handler))))
+    (if parent
+        (push node (node-children parent))
+        (setf (root handler) node))
+    (push node (element-stack handler))))
+
+(defmethod sax:end-element
+    ((handler xmls-builder) namespace-uri local-name qname)
+  (declare (ignore namespace-uri local-name qname))
+  (let ((node (pop (element-stack handler))))
+    (setf (node-children node) (reverse (node-children node)))))
+
+(defmethod sax:characters ((handler xmls-builder) data)
+  (let* ((parent (car (element-stack handler)))
+         (prev (car (node-children parent))))
+    ;; Be careful to accept both rods and strings here, so that xmls can be
+    ;; used with strings even if cxml is configured to use octet string rods.
+    (if (typep prev '(or rod string))
+        ;; um entities herum wird SAX:CHARACTERS mehrfach aufgerufen fuer
+        ;; den gleichen Textknoten.  Hier muessen wir den bestehenden Knoten
+        ;; erweitern, sonst ist das Dokument nicht normalisiert.
+        ;; (XXX Oder sollte man besser den Parser entsprechend aendern?)
+        (setf (car (node-children parent))
+              (concatenate `(vector ,(array-element-type prev))
+                           prev
+                           data))
+        (push data (node-children parent)))))
+
+
+;;;; SAX-Treiber (fuer Serialisierung)
+
+(defun map-node
+    (handler node
+     &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
+          (include-namespace-uri t))
+  (if include-namespace-uri
+      (map-node/lnames (cxml:make-namespace-normalizer handler)
+		       node
+		       include-xmlns-attributes)
+      (map-node/qnames handler node include-xmlns-attributes)))
+
+(defun map-node/lnames (handler node include-xmlns-attributes)
+  (sax:start-document handler)
+  (labels ((walk (node)
+	     (unless (node-ns node)
+	       (error "serializing with :INCLUDE-NAMESPACE-URI, but node ~
+                       was created without namespace URI"))
+	     (let* ((attlist
+		     (compute-attributes/lnames node include-xmlns-attributes))
+		    (uri (node-ns node))
+		    (lname (node-name node))
+		    (qname lname)	;let the normalizer fix it
+		    )
+	       (sax:start-element handler uri lname qname attlist)
+	       (dolist (child (node-children node))
+		 (typecase child
+		   (list (walk child))
+		   ((or string rod)
+		    (sax:characters handler (string-rod child)))))
+	       (sax:end-element handler uri lname qname))))
+    (walk node))
+  (sax:end-document handler))
+
+(defun map-node/qnames (handler node include-xmlns-attributes)
+  (sax:start-document handler)
+  (labels ((walk (node)
+	     (when (node-ns node)
+	       (error "serializing without :INCLUDE-NAMESPACE-URI, but node ~
+                       was created with a namespace URI"))
+             (let* ((attlist
+		     (compute-attributes/qnames node include-xmlns-attributes))
+		    (qname (string-rod (node-name node)))
+                    (lname (nth-value 1 (cxml::split-qname qname))))
+               (sax:start-element handler nil lname qname attlist)
+               (dolist (child (node-children node))
+                 (typecase child
+                   (list (walk child))
+                   ((or string rod)
+		    (sax:characters handler (string-rod child)))))
+               (sax:end-element handler nil lname qname))))
+    (walk node))
+  (sax:end-document handler))
+
+(defun compute-attributes/lnames (node xmlnsp)
+  (remove nil
+          (mapcar (lambda (a)
+                    (destructuring-bind (name value) a
+		      (unless (listp name)
+			(setf name (cons name nil)))
+                      (destructuring-bind (lname &rest uri) name
+			(cond
+			  ((not (equal uri "http://www.w3.org/2000/xmlns/"))
+			   (sax:make-attribute
+			    ;; let the normalizer fix the qname
+			    :qname (if uri
+				       (string-rod (concatenate 'string
+							 "dummy:"
+							 lname))
+				       (string-rod lname))
+			    :local-name (string-rod lname)
+			    :namespace-uri uri
+			    :value (string-rod value)
+			    :specified-p t))
+			  (xmlnsp
+			   (sax:make-attribute
+			    :qname (string-rod
+				    (if lname
+					(concatenate 'string "xmlns:" lname)
+					"xmlns"))
+			    :local-name (string-rod lname)
+			    :namespace-uri uri
+			    :value (string-rod value)
+			    :specified-p t))))))
+                  (node-attrs node))))
+
+(defun compute-attributes/qnames (node xmlnsp)
+  (remove nil
+          (mapcar (lambda (a)
+                    (destructuring-bind (name value) a
+		      (when (listp name)
+			(error "serializing without :INCLUDE-NAMESPACE-URI, ~
+                                but attribute was created with a namespace ~
+                                URI"))
+                      (if (or xmlnsp
+			      (not (cxml::xmlns-attr-p (string-rod name))))
+                          (sax:make-attribute :qname (string-rod name)
+                                              :value (string-rod value)
+                                              :specified-p t)
+                          nil)))
+                  (node-attrs node))))


From ksprotte at common-lisp.net  Sun Feb 17 16:38:39 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Sun, 17 Feb 2008 11:38:39 -0500 (EST)
Subject: [bknr-cvs] r2521 - in branches/trunk-reorg/bknr/datastore/src:
	indices utils
Message-ID: <20080217163839.5B2C06D08E@common-lisp.net>

Author: ksprotte
Date: Sun Feb 17 11:38:38 2008
New Revision: 2521

Modified:
   branches/trunk-reorg/bknr/datastore/src/indices/package.lisp
   branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
   branches/trunk-reorg/bknr/datastore/src/utils/smbpasswd.lisp
Log:
#+cmu removed :use :ext from defpackages bknr.utils and bknr.indices
as this does not seem to be needed and causes a symbol conflict


Modified: branches/trunk-reorg/bknr/datastore/src/indices/package.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/indices/package.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/indices/package.lisp	Sun Feb 17 11:38:38 2008
@@ -3,7 +3,6 @@
 (defpackage :bknr.indices
   (:use :cl
 	#+clisp :ext
-	#+cmu :ext
 	#+sbcl :sb-ext
 	:cl-user
 	:bknr.utils

Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp	Sun Feb 17 11:38:38 2008
@@ -5,7 +5,6 @@
         :cl-ppcre
         :cl-interpol
         :md5
-        #+cmu :extensions
         #+sbcl :sb-ext
         #+cmu :mp
         #+openmcl :ccl)

Modified: branches/trunk-reorg/bknr/datastore/src/utils/smbpasswd.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/utils/smbpasswd.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/utils/smbpasswd.lisp	Sun Feb 17 11:38:38 2008
@@ -29,9 +29,9 @@
       (let ((process
 	     (ext:run-program +smb-wrapper-program+ args :output stream :error :output)))
 	(unwind-protect
-	     (unless (zerop (process-exit-code process))
+	     (unless (zerop (ext:process-exit-code process))
 	       (error (make-condition 'smb-password-error :message (get-output-stream-string stream))))
-	  (process-close process)))
+	  (ext:process-close process)))
       #+openmcl
       (ccl::run-program +smb-wrapper-program+
 			args


From hhubner at common-lisp.net  Sun Feb 17 19:25:59 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 14:25:59 -0500 (EST)
Subject: [bknr-cvs] r2522 - in branches/trunk-reorg/bknr/web/src: . images
	rss web
Message-ID: <20080217192559.77379830A1@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 14:25:56 2008
New Revision: 2522

Removed:
   branches/trunk-reorg/bknr/web/src/rss/parse-atom.lisp
   branches/trunk-reorg/bknr/web/src/rss/parse-rss091.lisp
   branches/trunk-reorg/bknr/web/src/rss/parse-rss10.lisp
   branches/trunk-reorg/bknr/web/src/rss/parse-rss20.lisp
   branches/trunk-reorg/bknr/web/src/rss/parse-xml.lisp
   branches/trunk-reorg/bknr/web/src/rss/test.lisp
Modified:
   branches/trunk-reorg/bknr/web/src/bknr-web.asd
   branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp
   branches/trunk-reorg/bknr/web/src/images/image.lisp
   branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
   branches/trunk-reorg/bknr/web/src/packages.lisp
   branches/trunk-reorg/bknr/web/src/rss/rss.lisp
   branches/trunk-reorg/bknr/web/src/web/handlers.lisp
   branches/trunk-reorg/bknr/web/src/web/menu.lisp
   branches/trunk-reorg/bknr/web/src/web/site.lisp
   branches/trunk-reorg/bknr/web/src/web/tags.lisp
   branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
   branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
Log:
Docstrings.

Cleaning up:  The old RSS parsing code is now gone, as it was not used and
did not work any more.

HANDLER-MATCHES renamed to HANDLER-MATCHES-P


Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd
==============================================================================
--- branches/trunk-reorg/bknr/web/src/bknr-web.asd	(original)
+++ branches/trunk-reorg/bknr/web/src/bknr-web.asd	Sun Feb 17 14:25:56 2008
@@ -49,16 +49,7 @@
 							:depends-on ("hyperspec")))
 			  :depends-on ("packages"))
 
-		 (:module "rss" :components ((:file "rss")
-					     (:file "parse-xml")
-					     (:file "parse-rss10"
-						    :depends-on ("parse-xml" "rss"))
-					     (:file "parse-rss091"
-						    :depends-on ("parse-xml" "rss"))
-					     (:file "parse-atom"
-						    :depends-on ("parse-xml" "rss"))
-					     (:file "parse-rss20"
-						    :depends-on ("parse-xml" "rss")))
+		 (:module "rss" :components ((:file "rss"))
 			  :depends-on ("packages"))
 
 		 (:module "web" :components ((:file "site")

Modified: branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/image-handlers.lisp	Sun Feb 17 14:25:56 2008
@@ -10,12 +10,13 @@
       (setf (header-out :cache-control) (format nil "max-age=~A" max-age)))
     (unless (zerop date)
       (setf (header-out :last-modified) (rfc-1123-date date)))
-    (with-http-body ()
+    (let ((stream (send-headers)))
+      (setf (flex:flexi-stream-element-type stream) 'flex:octet)
       (setf (save-alpha-p :image image) t)
       (if (member image-format '(:jpg :jpeg))
-	  (write-image-to-stream *html-stream* image-format :image image :quality quality)
-	  (write-image-to-stream *html-stream* image-format :image image))
-      (finish-output *html-stream*))))
+	  (write-image-to-stream stream image-format :image image :quality quality)
+	  (write-image-to-stream stream image-format :image image))
+      (finish-output stream))))
 
 (defmethod store-image-xml-info ((image store-image))
   (cxml:with-element "image"
@@ -52,9 +53,6 @@
 (defmethod object-list-handler-title ((handler image-page-handler) object)
   "bknr images")
 
-(defmethod object-list-handler-rss-link ((handler image-page-handler) object)
-  "/image-rss")
-
 (defmethod object-list-handler-get-objects ((handler image-page-handler) object)
   (all-store-images))
 
@@ -65,7 +63,6 @@
 (defmethod handle-object ((handler image-page-handler) images)
   (let ((results (make-keyword-results (object-list-handler-get-objects handler images))))
     (with-bknr-page (:title (object-list-handler-title handler images))
-      (cmslink (object-list-handler-rss-link handler images) "rss")
       (image-page results))))
   
 (defclass upload-image-handler (form-handler)
@@ -114,10 +111,6 @@
 (defmethod object-list-handler-title ((handler image-keyword-handler) keyword)
   (format nil "bknr keyword images: ~a" keyword))
 
-(defmethod object-list-handler-rss-link ((handler image-keyword-handler) keyword)
-  (format nil "/keyword-rss/~A"
-	  (string-downcase (symbol-name keyword))))
-
 (defclass image-union-handler (image-page-handler keywords-handler)
   ())
 
@@ -127,9 +120,6 @@
 (defmethod object-list-handler-title ((handler image-union-handler) keywords)
   (format nil "bknr union images: ~a" keywords))
 
-(defmethod object-list-handler-rss-link ((handler image-union-handler) keywords)
-  (format nil "/union-rss/~A" (parse-url)))
-
 (defclass image-intersection-handler (image-page-handler keywords-handler)
   ())
 
@@ -139,43 +129,6 @@
 (defmethod object-list-handler-title ((handler image-intersection-handler) keywords)
   (format nil "bknr intersection images: ~a" keywords))
 
-(defmethod object-list-handler-rss-link ((handler image-intersection-handler) keywords)
-  (format nil "/intersection-rss/~A" (parse-url)))
-
-;;; rss image feeds
-#|
-(defclass rss-image-handler (object-rss-handler image-page-handler)
-  ())
-
-(defmethod create-object-rss-feed ((handler rss-image-handler) object)
-  (let* ((url (website-url (page-handler-site handler)))
-	 (image-items (mapcar #'(lambda (image)
-				      (store-image-to-rss-item image :url url))
-				  (subseq (sort (object-list-handler-get-objects handler object)
-						#'> :key #'blob-timestamp)
-					  0 20))))
-    (if image-items
-	(make-instance 'rss-feed
-		       :channel (make-instance
-				 'rss-channel
-				 :about (render-uri url nil)
-				 :title (object-list-handler-title handler object)
-				 :link (render-uri url nil)
-				 :items (mapcar #'rss-item-link image-items))
-		       :items image-items)
-	(make-instance 'rss-feed :channel (make-instance 'rss-channel
-							 :about "no such keyword"
-							 :title "no such keyword")))))
-  
-(defclass rss-image-keyword-handler (rss-image-handler image-keyword-handler)
-  ())
-
-(defclass rss-image-union-handler (rss-image-handler image-union-handler)
-  ())
-
-(defclass rss-image-intersection-handler (rss-image-handler image-intersection-handler)
-  ())
-|#
 
 (defclass xml-image-browser-handler (image-handler xml-object-handler)
   ())
@@ -203,12 +156,6 @@
   ("/image-keyword" image-keyword-handler)
   ("/image-union" image-union-handler)
   ("/image-intersection" image-intersection-handler)
-  #|
-  ("/rss-image" rss-image-handler)
-  ("/rss-image-keyword" rss-image-keyword-handler)
-  ("/rss-image-union" rss-image-union-handler)
-  ("/rss-image-intersection" rss-image-intersection-handler)
-  |#
   ("/image" imageproc-handler)
   ("/image-import" image-import-handler)
   ("/session-image" session-image-handler)

Modified: branches/trunk-reorg/bknr/web/src/images/image.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/image.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/image.lisp	Sun Feb 17 14:25:56 2008
@@ -103,26 +103,6 @@
 		(store-image-with-name image-id)))
     (keyword (store-image-with-name (string-downcase (symbol-name image-id))))))
 
-(defmethod store-image-to-rss-item ((image store-image) &key (url (parse-uri "")))
-  (let ((image-url (render-uri (merge-uris (parse-uri (format nil "/image/~a"
-							      (store-object-id image)))
-					   url) nil))
-	(browse-url (render-uri (merge-uris (parse-uri (format nil "/browse-image/~A"
-							      (store-object-id image)))
-					   url) nil))	)
-    (make-instance 'rss-item
-		   :about browse-url
-		   :title (store-image-name image)
-		   :link browse-url
-		   :desc (with-output-to-string (s)
-			   (html-stream s ((:a :href image-url)
-                                           ((:img :src
-                                                  (concatenate 'string
-                                                               image-url
-                                                               "/thumbnail,,320,200")
-                                                  :align "left")))))
-		   :date (blob-timestamp image))))
-
 ;;; import
 (defun import-image (pathname &key name user keywords directory (keywords-from-dir t) (class-name 'store-image) initargs)
   "Create blob from given file"

Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp	Sun Feb 17 14:25:56 2008
@@ -34,9 +34,7 @@
       (when (and (true-color-p working-image)
                  (not (true-color-p input-image)))
         (true-color-to-palette :dither t :image working-image :colors-wanted 256))
-      (let ((stream (send-headers)))
-        (setf (flex:flexi-stream-element-type stream) 'flex:octet)
-        (write-image-to-stream stream (image-type-keyword image) :image working-image))
+      (emit-image-to-browser working-image (image-type-keyword image))
       (unless (eq working-image input-image)
         (destroy-image working-image)))))
 

Modified: branches/trunk-reorg/bknr/web/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/packages.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/packages.lisp	Sun Feb 17 14:25:56 2008
@@ -20,17 +20,8 @@
 
 (defpackage :bknr.rss
   (:use :cl :cl-user :cl-ppcre :bknr.utils :bknr.xml :puri :cxml-xmls :bknr.datastore :bknr.indices :cxml)
-  (:export #:xml-escape
-	   #:*img-src-scanner*
-	   #:*a-href-scanner*
-	   #:*link-href-scanner*
-	   #:replace-relative-links
-	   #:make-absolute-url
-   
-	   #:rss-to-xml
-	   #:merge-feeds
+  (:export ;; channel
 
-	   ;; channel
 	   #:rss-channel
 	   #:find-rss-channel
 	   #:make-rss-channel
@@ -44,13 +35,6 @@
 	   #:rss-channel-items
 	   #:rss-channel-xml
 
-	   ;; image
-	   #:rss-image
-	   #:rss-image-about
-	   #:rss-image-title
-	   #:rss-image-url
-	   #:rss-image-link
-
 	   ;; item
 	   #:rss-item
 	   #:rss-item-channel
@@ -65,22 +49,7 @@
 	   #:rss-item-enclosure
 	   #:rss-item-guid
 	   #:rss-item-source
-	   #:rss-item-encoded-content
-
-	   ;; textinput
-	   #:rss-textinput
-	   #:rss-textinput-about
-	   #:rss-textinput-title
-	   #:rss-textinput-desc
-	   #:rss-textinput-link
-	   #:rss-textinput-name
-
-	   #:parse-rss091-feed
-	   #:parse-rss10-feed
-	   #:parse-rss20-feed
-	   #:parse-atom-feed
-
-	   #:*base-url*))
+	   #:rss-item-encoded-content))
 
 (defpackage :bknr.events
     (:use :cl
@@ -292,13 +261,12 @@
 	   #:website-session-info
            #:website-base-href
            #:website-make-path
-	   #:website-rss-feed-url
 	   #:host
 	   #:publish-site
 	   #:publish-handler
 	   #:unpublish
 
-	   #:handler-matches
+	   #:handler-matches-p
 	   #:handle-object
 	   #:handle-object-form
 	   #:handle-form
@@ -357,7 +325,6 @@
 	   #:object-list-handler
 	   #:object-list-handler-get-objects
 	   #:object-list-handler-title
-	   #:object-list-handler-rss-link
 	   #:object-list-handler-show-object-xml
 	   #:object-date-list-handler
 	   #:object-date-list-handler-grouped-objects

Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/rss/rss.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp	Sun Feb 17 14:25:56 2008
@@ -4,33 +4,7 @@
 
 ;; This package aids in the automatic generation of RSS channels.
 
-;; Class rss-channel models one rss channel.  Items are added to a
-;; channel by deriving other persistent classes from the (mixin) class
-;; rss-item.  When an object of such a derived class is created, it is
-;; automatically added to its RSS channel.  Likewise, it is
-;; automatically deleted from the channel when it is deleted.
-
-;; The channel that an item is put into is defined by the generic
-;; function rss-item-channel which needs to be specialized for each
-;; item class.  The default method of this generic function specifies
-;; nil as channel, which results in the creation of a warning message
-;; when an object of this class is created.
-
-;; The rss-item-channel method may return the channel either as a
-;; string or as a channel object.
-
-;; Subclasses of rss-item should provide methods for some of the
-;; generic functions (rss-item-channel rss-item-title rss-item-link
-;; rss-item-description rss-item-author rss-item-category
-;; rss-item-comments rss-item-enclosure rss-item-guid
-;; rss-item-source).  These functions are called when the RSS file for
-;; the channel is generated and provide the
-
-;; One rss-item can only be in one channel.
-
-;; The channel object has more required elements than the standard
-;; specifies in order to make the generated feed documents more widely
-;; accepted.
+;; See the documentation to class RSS-CHANNEL for an overview.
 
 ;;; Paul Graham, On Lisp, p191
 (defmacro aif (test-form then-form &optional else-form)
@@ -48,17 +22,46 @@
    (description :update)
    (last-update :update :initform (get-universal-time))
    (max-item-age :update :initform (* 4 7 3600))
-   (items :update :initform nil)))
+   (items :update :initform nil))
+  (:documentation "RSS-CHANNEL models one rss channel.  Items are
+added to a channel by deriving other persistent classes from the mixin
+class RSS-ITEM.  When an object of such a derived class is created, it
+is automatically added to its RSS channel.  Likewise, it is
+automatically deleted from the channel when it is deleted.
+
+The channel that an item is put into is defined by the generic
+function RSS-ITEM-CHANNEL which needs to be specialized for each item
+class.  The default method of this generic function specifies nil as
+channel, which results in the creation of a warning message when an
+object of this class is created.
+
+The RSS-ITEM-CHANNEL method may return the channel either as a string
+or as a channel object.
+
+Subclasses of RSS-ITEM should provide methods for some of the generic
+functions (RSS-ITEM-CHANNEL RSS-ITEM-TITLE RSS-ITEM-LINK
+RSS-ITEM-DESCRIPTION RSS-ITEM-AUTHOR RSS-ITEM-CATEGORY
+RSS-ITEM-COMMENTS RSS-ITEM-ENCLOSURE RSS-ITEM-GUID RSS-ITEM-SOURCE).
+These functions are called when the RSS file for the channel is
+generated and provide the content in the RSS items.
+
+One RSS-ITEM can only be in one channel, which is a restriction that
+may eventually be removed.
+
+The channel object has more required elements than specified by the
+standard in order to make the generated feed documents more widely
+accepted."))
 
 (defmethod prepare-for-snapshot ((channel rss-channel))
+  "When snapshotting, remove items from CHANNEL that are destroyed."
   (setf (rss-channel-items channel) (remove-if #'object-destroyed-p (rss-channel-items channel))))
 
 ;; Mixin for items
 
 (define-persistent-class rss-item ()
-  ())
-
-(defgeneric rss-item-pub-date (item))
+  ()
+  (:documentation "Mixin class for RSS items.  See documentation for
+class RSS-CHANNEL for an overview."))
 
 (defun make-rss-channel (name title description link &rest args)
   (apply #'make-object 'rss-channel :name name :title title :description description :link link args))
@@ -85,42 +88,41 @@
                                      (rss-channel-items channel)))
 	  (rss-item-xml item))))))
 
-(defmethod rss-channel-items ((channel rss-channel))
-  "Return all non-expired items in channel."
-  (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel))))
-    (remove-if (lambda (item) (or (object-destroyed-p item)
-                                  (< (rss-item-pub-date item) expiry-time)))
-               (slot-value channel 'items))))
+(defgeneric rss-channel-items (channel)
+  (:documentation "Return all non-expired items in channel.")
+  (:method ((channel rss-channel))
+    (let ((expiry-time (- (get-universal-time) (rss-channel-max-item-age channel))))
+      (remove-if (lambda (item) (or (object-destroyed-p item)
+                                    (< (rss-item-pub-date item) expiry-time)))
+                 (slot-value channel 'items)))))
 
 (deftransaction rss-channel-cleanup (channel)
   "Remove expired items from the items list.  Can be used to reduce
 the memory footprint of very high volume channels."
   (setf (slot-value channel 'items) (rss-channel-items channel)))
 
-;; Internal helper functions to find a channel
-
-(defmethod remove-item ((channel rss-channel) item)
-  "Remove item from channel.  May only be called within transaction context."
-  (setf (slot-value channel 'items) (remove item (rss-channel-items channel))))
-
-(defmethod remove-item ((channel string) item)
-  (aif (find-rss-channel channel)
-       (remove-item it item)))
-
-(defmethod remove-item ((channel (eql nil)) item)
-  (warn "no RSS channel defined for item ~A" item))
-
-(defmethod add-item ((channel rss-channel) item)
-  "Add item to channel.  May only be called within transaction context."
-  (setf (slot-value channel 'items) (cons item (rss-channel-items channel))))
-
-(defmethod add-item ((channel string) item)
-  (aif (find-rss-channel channel)
-       (add-item it item)
-       (warn "can't find RSS channel ~A to add newly created item ~A to" channel item)))
-
-(defmethod add-item ((channel (eql nil)) item)
-  (warn "no RSS channel defined for item ~A" item))
+(defgeneric remove-item (channel item)
+  (:documentation "Remove ITEM from CHANNEL.  May only be called
+within transaction context.")
+  (:method ((channel rss-channel) item)
+    (setf (slot-value channel 'items) (remove item (rss-channel-items channel))))
+  (:method ((channel string) item)
+    (aif (find-rss-channel channel)
+         (remove-item it item)))
+  (:method ((channel (eql nil)) item)
+    (warn "no RSS channel defined for item ~A" item)))
+
+(defgeneric add-item (channel item)
+  (:documentation "Add ITEM to CHANNEL.  May only be called within
+transaction context.")
+  (:method ((channel rss-channel) item)
+    (setf (slot-value channel 'items) (cons item (rss-channel-items channel))))
+  (:method ((channel string) item)
+    (aif (find-rss-channel channel)
+         (add-item it item)
+         (warn "can't find RSS channel ~A to add newly created item ~A to" channel item)))
+  (:method ((channel (eql nil)) item)
+    (warn "no RSS channel defined for item ~A" item)))
 
 (defmethod initialize-persistent-instance :after ((rss-item rss-item))
   (add-item (rss-item-channel rss-item) rss-item))
@@ -129,12 +131,14 @@
   (remove-item (rss-item-channel rss-item) rss-item))
 
 (defun item-slot-element (item slot-name)
+  "Cheapo helper function to map from a pseudo slot name to an accessor."
   (let ((accessor (find-symbol (format nil "RSS-ITEM-~A" slot-name) (find-package :bknr.rss))))
     (aif (funcall accessor item)
 	 (with-element (string-downcase (symbol-name slot-name))
 	   (text it)))))
 
 (defun rss-item-xml (item)
+  "Generate RSS XML for ITEM using CXML's unparse functionality."
   (with-element "item"
     (dolist (slot '(title link author category comments enclosure source))
       (item-slot-element item slot))
@@ -154,27 +158,41 @@
 ;; All items present on an RSS stream can implement the access
 ;; methods below.
 
-(defmethod rss-item-published (item)
-  t)
+(defgeneric rss-item-pub-date (item)
+  (:documentation "The default implementation for the publication date
+delivers the current system date/time as publication date.")
+  (:method (item)
+    (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item))
+    (get-universal-time)))
 
-(defmethod rss-item-pub-date (item)
-  "The default implementation for the publication date delivers the
-current system date/time as publication date."
-  (warn "no rss-item-pub-date defined for class ~A, using current date/time" (class-of item))
-  (get-universal-time))
-
-(defmethod rss-item-channel (item))
-(defmethod rss-item-title (item))
-(defmethod rss-item-link (item))
-(defmethod rss-item-description (item))
-(defmethod rss-item-author (item))
-(defmethod rss-item-category (item))
-(defmethod rss-item-comments (item))
-(defmethod rss-item-enclosure (item))
-(defmethod rss-item-guid (item))
-(defmethod rss-item-source (item))
-(defgeneric rss-item-encoded-content (item)
-  (:documentation "Return the content for ITEM in encoded (usually HTML) form as string.")
+(defgeneric rss-item-published (item)
+  (:documentation "Return non-nil if the ITEM is published.
+Non-published items are not put into generated XML by
+RSS-CHANNEL-XML.")
   (:method (item)
-    (declare (ignore item))
-    nil))
+    t))
+
+(defmacro define-rss-item-field (field-name
+                                 &key
+                                 (documentation (format nil "Return the ~(~A~) of the ITEM as a string" field-name))
+                                 mandatory)
+  `(defgeneric ,(intern (format nil "RSS-ITEM-~A" field-name)) (item)
+    (:documentation ,(format nil "~A~@[ (optional)~]"
+                             documentation (not mandatory)))
+    ,@(unless mandatory
+            '((:method (item) nil)))))
+
+(define-rss-item-field channel
+    :documentation "Return the channel that the ITEM is published in."
+    :mandatory t)
+(define-rss-item-field title)
+(define-rss-item-field link)
+(define-rss-item-field description)
+(define-rss-item-field author)
+(define-rss-item-field category)
+(define-rss-item-field comments)
+(define-rss-item-field enclosure)
+(define-rss-item-field guid)
+(define-rss-item-field source)
+(define-rss-item-field encoded-content
+    :documentation "Return the content for ITEM in encoded (usually HTML) form as string.")

Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/handlers.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp	Sun Feb 17 14:25:56 2008
@@ -503,13 +503,13 @@
 
 (defgeneric object-date-list-handler-grouped-objects (handler object))
 
-(defmethod object-date-list-handler-date ((handler object-date-list-handler)
-                                          object)
-  (with-query-params (date)
-    (get-daytime (if date
-		     (or (parse-integer date :junk-allowed t)
-			 (get-universal-time))
-		     (get-universal-time)))))
+(defgeneric object-date-list-handler-date (handler object)
+  (:method ((handler object-date-list-handler) object)
+    (with-query-params (date)
+      (get-daytime (if date
+                       (or (parse-integer date :junk-allowed t)
+                           (get-universal-time))
+                       (get-universal-time))))))
 
 (defclass admin-only-handler ()
   ())

Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/menu.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/menu.lisp	Sun Feb 17 14:25:56 2008
@@ -44,6 +44,7 @@
   (let* ((menu (bknr.impex:parse-xml-file
                 #+cmu (ext:unix-namestring (merge-pathnames config *default-pathname-defaults*))
                 #+sbcl (sb-int:unix-namestring (merge-pathnames config *default-pathname-defaults*))
+                #-(or cmu sbcl) (namestring (probe-file (merge-pathnames config *default-pathname-defaults*)))
                 *menu-def-classes*)))
     (html
      ((:div :class container-class)

Modified: branches/trunk-reorg/bknr/web/src/web/site.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/site.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/site.lisp	Sun Feb 17 14:25:56 2008
@@ -5,6 +5,6 @@
 (defparameter *thumbnail-max-width* 108)
 (defparameter *thumbnail-max-height* 54)
 
-;; default billboard to show on home page
-(defparameter *default-billboard* "main")
+(defparameter *default-billboard* "main"
+  "default billboard to show on home page")
 

Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/tags.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/tags.lisp	Sun Feb 17 14:25:56 2008
@@ -61,6 +61,7 @@
       (html ((:input :type "checkbox" :name name) (:princ-safe value)))))
 
 (define-bknr-tag date-field (name &key date (show-time t))
+  "Generate a date entry widget using HTML <select> elements."
   (unless date
     (setf date (get-universal-time)))
   (multiple-value-bind (sec min hour day month year)

Modified: branches/trunk-reorg/bknr/web/src/web/template-handler.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/template-handler.lisp	Sun Feb 17 14:25:56 2008
@@ -300,7 +300,7 @@
 (defmacro with-error-handlers ((handler) &body body)
   `(invoke-with-error-handlers (lambda () , at body) ,handler))
 
-(defmethod handler-matches ((handler template-handler))
+(defmethod handler-matches-p ((handler template-handler))
   (handler-case 
       (find-template-pathname handler (script-name))
     (template-not-found (c)

Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp	Sun Feb 17 14:25:56 2008
@@ -80,6 +80,8 @@
 	    :value ,(or variable ""))))
 
 (defmacro html-warn (&rest warning)
+  "Generate a warning on the console and write the warning into the
+currently generated XHTML output as a comment."
   `(progn
     (html (:princ-safe (format nil "<!-- ~a -->~%" (format nil , at warning))))
     (warn , at warning)))


From hhubner at common-lisp.net  Sun Feb 17 21:27:26 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 16:27:26 -0500 (EST)
Subject: [bknr-cvs] r2523 - branches/trunk-reorg/bknr/datastore/src/data
Message-ID: <20080217212726.730CC450C9@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 16:27:25 2008
New Revision: 2523

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
Log:
Improve DEFTRANSACTION:

Define wrapper function with docstring, if supplied.  Use lambda list
specified in DEFTRANSACTION for the wrapper function.  Handle
docstrings correctly.  Insert IN-TRANSACTION-P check after
declarations and docstring in generated function.


Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	Sun Feb 17 16:27:25 2008
@@ -240,26 +240,90 @@
 (defmethod execute-transaction ((executor transaction) transaction)
   (execute-unlogged transaction))
 
+(defun find-doc (body)
+  "Given a function definition BODY, extract the docstring, if any.
+Skips over any declarations that precede the docstring.  See also CLHS
+3.4.11"
+  (do ((body body (cdr body)))
+      ((or (not (listp (car body)))
+           (not (eq 'declare (caar body))))
+       (when (and (stringp (car body))
+                  (cdr body))
+         (car body)))))
+
+(defun insert-after-declarations (body forms-to-insert)
+  "Given a function definition body, insert FORMS-TO-INSERT after all
+declarations and documentation in BODY."
+  (loop for rest on body
+        for form = (car rest)
+        with decls
+        with doc
+        while (or (and (listp form) (eq 'declare (car form)))
+                  (and (not doc) (cdr rest) (stringp form)))
+        when (stringp form)
+        do (setf doc form)
+        do (push form decls)
+        finally (return-from insert-after-declarations (append (nreverse decls) forms-to-insert rest))))
+
+(defun make-args (args)
+  "Parse the lambda list ARGS, returning a list that contains the
+arguments in the lambda list prepared so that the list can be applied
+to a function accepting that lambda list.
+
+For example:
+
+ (MAKE-ARGS '(A B &OPTIONAL C &REST D &KEY E F)) => (A B C :E E :F F)
+
+It is used to forward arguments to a transaction wrapper generated by
+DEFTRANSACTION to the actual transaction so that the wrapper function
+can be declared with the lambda list of the transaction function
+itself,"
+  (do ((args args (cdr args))
+       result
+       in-keywords-p)
+      ((not args)
+       (nreverse result))
+    (let ((arg (funcall (if (listp (car args)) #'caar #'car) args)))
+      (cond
+        ((eql #\& (aref (symbol-name arg) 0))
+         (case arg
+           (&optional)
+           (&rest (setf args (cdr args))) ; skip argument, too
+           (&key (setf in-keywords-p t))
+           (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg))))
+        (t
+         (when in-keywords-p
+           (push (intern (symbol-name arg) :keyword) result))
+         (push arg result))))))
+
 (defmacro deftransaction (name (&rest args) &rest body)
-  "Define a transaction function tx-NAME and a function NAME executing tx-NAME in the context
-of the current store. The arguments to NAME will be serialized to the transaction-log, and
-should must be supported by the binary encoder. tx-NAME will be called during a roll-forward."
-  (dolist (arg args)
-    (when (listp arg)
-      (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name)))
-  (let ((args-name (gensym))
-	(tx-name (intern (string-upcase (concatenate 'string "tx-" (symbol-name name)))
-			 (symbol-package name))))
-    `(progn
-      (defun ,tx-name ,args
-	(unless (in-transaction-p)
-	  (error 'not-in-transaction))
-	, at body)
-      (defun ,name (&rest ,args-name)
-	(execute (make-instance 'transaction
-				:function-symbol ',tx-name
-				:timestamp (get-universal-time)
-				:args ,args-name))))))
+  "Define a transaction function tx-NAME and a function NAME executing
+tx-NAME in the context of the current store. The arguments to NAME
+will be serialized to the transaction-log, and should must be
+supported by the binary encoder. tx-NAME will be called during a
+roll-forward."
+  (let ((name name)
+        (args args)
+        (body body))
+    (dolist (arg args)
+      (when (listp arg)
+        (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name)))
+    (let ((tx-name (intern (format nil "TX-~A" name)
+                           (symbol-package name))))
+      `(progn
+        (defun ,tx-name ,args
+          ,@(insert-after-declarations body
+                                       '((unless (in-transaction-p)
+                                           (error 'not-in-transaction)))))
+        (defun ,name ,args
+          ,@(let ((doc (find-doc body)))
+                 (when doc (list (format nil "[Transaction function wrapper ~A invokes a store transaction]~%~A" name doc))))
+          ,@(let ((rest (member '&rest args)))
+                 (when rest `((declare (ignore ,(second rest))))))
+          (execute (make-instance 'transaction
+                                  :function-symbol ',tx-name
+                                  :timestamp (get-universal-time)
+                                  :args (list ,@(make-args args)))))))))
 
 (defmethod encode-object ((object transaction) stream)
   (%write-char #\T stream)


From hhubner at common-lisp.net  Sun Feb 17 21:38:18 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 16:38:18 -0500 (EST)
Subject: [bknr-cvs] r2524 - in branches/trunk-reorg/projects/quickhoney: src
	website/templates
Message-ID: <20080217213818.3FFC91B033@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 16:38:17 2008
New Revision: 2524

Modified:
   branches/trunk-reorg/projects/quickhoney/src/tags.lisp
   branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
Log:
remove testing code.


Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp	Sun Feb 17 16:38:17 2008
@@ -1,6 +1,6 @@
 (in-package :quickhoney.tags)
 
-(define-bknr-tag version-and-last-change (&rest args)
+(define-bknr-tag version-and-last-change ()
   (html "v1.1 | updated "
         (:princ-safe (string-downcase
                       (substitute #\Space #\-

Modified: branches/trunk-reorg/projects/quickhoney/website/templates/index.xml
==============================================================================
--- branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	(original)
+++ branches/trunk-reorg/projects/quickhoney/website/templates/index.xml	Sun Feb 17 16:38:17 2008
@@ -35,7 +35,7 @@
 		</a>
 
 		<p id="path" class="text"> </p>
-		<p id="version" class="text"><quickhoney:version-and-last-change foo="1" bar="2" /></p>
+		<p id="version" class="text"><quickhoney:version-and-last-change /></p>
 
 		<div id="elements">
 			<div id="quickhoney">


From hhubner at common-lisp.net  Sun Feb 17 21:39:29 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Sun, 17 Feb 2008 16:39:29 -0500 (EST)
Subject: [bknr-cvs] r2525 - in branches/trunk-reorg/bknr: datastore/src/data
	modules/mail web/src/rss
Message-ID: <20080217213929.18BAF1B033@common-lisp.net>

Author: hhubner
Date: Sun Feb 17 16:39:28 2008
New Revision: 2525

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/object.lisp
   branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
   branches/trunk-reorg/bknr/modules/mail/mail.lisp
   branches/trunk-reorg/bknr/web/src/rss/rss.lisp
Log:
Docstring fixes, add another missing defgeneric.


Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/object.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp	Sun Feb 17 16:39:28 2008
@@ -647,7 +647,7 @@
   
 
 (defun find-store-object (id-or-name &key (class 'store-object) query-function key-slot-name)
-  "mock up implementation of find-store-object api as in the old datastore"
+  "Mock up implementation of find-store-object API as in the old datastore"
   (unless id-or-name
     (error "can't search a store object with null key"))
   (when (stringp id-or-name)

Modified: branches/trunk-reorg/bknr/datastore/src/data/txn.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/txn.lisp	Sun Feb 17 16:39:28 2008
@@ -223,12 +223,11 @@
 ;;; itself or, in the case of a nested transaction, the parent
 ;;; transaction.  Named transactions do not explicitly log the nested
 ;;; transactions as the nesting is implicit, meaning that any repeated
-;;; execution of the transactions triggered by rolling forward the
-;;; transaction log will automatically repeat the sequence of
-;;; executing nested transactions by the program code executed.
-;;; Contrasted to that, an anonymous transaction has no implicit
-;;; nesting, so any nested transactions which are called are
-;;; explicitly logged.
+;;; execution of the transactions while rolling forward the
+;;; transaction log will automatically repeat the sequence of nested
+;;; transaction executions by the program code executed.  Contrasted
+;;; to that, an anonymous transaction has no implicit nesting, so any
+;;; nested transactions which are called are explicitly logged.
 
 (defgeneric execute-transaction (executor transaction)
   (:documentation "Execute TRANSACTION on EXECUTOR (which may be a store or a transaction scope)."))
@@ -299,9 +298,10 @@
 (defmacro deftransaction (name (&rest args) &rest body)
   "Define a transaction function tx-NAME and a function NAME executing
 tx-NAME in the context of the current store. The arguments to NAME
-will be serialized to the transaction-log, and should must be
-supported by the binary encoder. tx-NAME will be called during a
-roll-forward."
+will be serialized to the transaction-log, and must be supported by
+the binary encoder. tx-NAME will be called during a roll-forward to
+repeat any effects that the transaction function had on the persistent
+store."
   (let ((name name)
         (args args)
         (body body))

Modified: branches/trunk-reorg/bknr/modules/mail/mail.lisp
==============================================================================
--- branches/trunk-reorg/bknr/modules/mail/mail.lisp	(original)
+++ branches/trunk-reorg/bknr/modules/mail/mail.lisp	Sun Feb 17 16:39:28 2008
@@ -92,12 +92,14 @@
 		     :subject (header :subject)
 		     :id (regex-replace-all
 			  *message-id-re*
-			  (header :message-id) #?/\1/)
-#|		     :in-reply (regex-replace-all
+			  (header :message-id)
+                          #?/\1/)
+		     :in-reply (regex-replace-all
 				*message-id-re*
 				(first (if (header :in-reply-to)
 					   (split #?/\s+/ (header :in-reply-to))
-					   (last (split #?/\s+/ (header :references)))))) |#
+					   (last (split #?/\s+/ (header :references)))))
+                                 #?/\1/)
 		     :headers headers
 		     :body body)))))
 

Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp
==============================================================================
--- branches/trunk-reorg/bknr/web/src/rss/rss.lisp	(original)
+++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp	Sun Feb 17 16:39:28 2008
@@ -64,6 +64,9 @@
 class RSS-CHANNEL for an overview."))
 
 (defun make-rss-channel (name title description link &rest args)
+  "Create an RSS channel with the given NAME, TITLE, DESCRIPTION and
+LINK (all strings) which are the mandatory fields in an RSS channel.
+Returns the persistent RSS-CHANNEL object that has been created."
   (apply #'make-object 'rss-channel :name name :title title :description description :link link args))
   
 (defun render-mandatory-element (channel element)
@@ -73,20 +76,23 @@
 	       it
 	       (format nil "(channel ~(~A~) not defined)" element)))))
 
-(defmethod rss-channel-xml ((channel rss-channel) stream)
-  (with-xml-output (make-character-stream-sink stream)
-    (with-element "rss"
-      (attribute "version" "2.0")
-      (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/")
-      (with-element "channel"
-	(dolist (slot '(title link description))
-	  (render-mandatory-element channel slot))
+(defgeneric rss-channel-xml (channel stream)
+  (:documentation "Generate XML for the current state of RSS channel
+CHANNEL to STREAM.")
+  (:method ((channel rss-channel) stream)
+    (with-xml-output (make-character-stream-sink stream)
+      (with-element "rss"
+        (attribute "version" "2.0")
+        (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/")
+        (with-element "channel"
+          (dolist (slot '(title link description))
+            (render-mandatory-element channel slot))
 	
-	(dolist (item (remove-if-not #'(lambda (item)
-                                         (and (not (object-destroyed-p item))
-                                              (rss-item-published item)))
-                                     (rss-channel-items channel)))
-	  (rss-item-xml item))))))
+          (dolist (item (remove-if-not #'(lambda (item)
+                                           (and (not (object-destroyed-p item))
+                                                (rss-item-published item)))
+                                       (rss-channel-items channel)))
+            (rss-item-xml item)))))))
 
 (defgeneric rss-channel-items (channel)
   (:documentation "Return all non-expired items in channel.")


From hhubner at common-lisp.net  Mon Feb 18 08:38:51 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 03:38:51 -0500 (EST)
Subject: [bknr-cvs] r2526 - branches/trunk-reorg/thirdparty/uffi-1.6.0/src
Message-ID: <20080218083851.A81EF1603D@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 03:38:51 2008
New Revision: 2526

Modified:
   branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
Log:
fix :pointer-self for unions

Modified: branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	(original)
+++ branches/trunk-reorg/thirdparty/uffi-1.6.0/src/aggregates.lisp	Mon Feb 18 03:38:51 2008
@@ -67,40 +67,48 @@
   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
   )
 
-(defun process-struct-fields (name fields &optional (variant nil))
+(defun process-aggregate-fields (name fields &key (variant nil) (aggregate-type :struct))
   (let (processed)
     (dolist (field fields)
       (let* ((field-name (car field))
 	     (type (cadr field))
 	     (def (append (list field-name)
-			  (if (eq type :pointer-self)
-			      #+(or cmu scl) `((* (alien:struct ,name)))
-			      #+sbcl `((* (sb-alien:struct ,name)))
-			      #+(or openmcl digitool) `((:* (:struct ,name)))
-			      #+lispworks `((:pointer ,name))
-			      #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
-			      `(,(convert-from-uffi-type type :struct))))))
+                          (if (eq type :pointer-self)
+                            (ecase aggregate-type
+                              (:struct 
+                               #+(or cmu scl) `((* (alien:struct ,name)))
+                               #+sbcl `((* (sb-alien:struct ,name)))
+                               #+(or openmcl digitool) `((:* (:struct ,name)))
+                               #+lispworks `((:pointer ,name))
+                               #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name)))
+                              (:union
+                               #+(or cmu scl) `((* (alien:union ,name)))
+                               #+sbcl `((* (sb-alien:union ,name)))
+                               #+(or openmcl digitool) `((:* (:union ,name)))
+                               #+lispworks `((:pointer ,name))
+                               #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))))
+                            `(,(convert-from-uffi-type type aggregate-type))))))
 	(if variant
 	    (push (list def) processed)
-	  (push def processed))))
+            (push def processed))))
     (nreverse processed)))
 	
 	    
 (defmacro def-struct (name &rest fields)
   #+(or cmu scl)
-  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
+  `(alien:def-alien-type ,name (alien:struct ,name ,@(process-aggregate-fields name fields)))
   #+sbcl
-  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
+  `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-aggregate-fields name fields)))
   #+allegro
-  `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
+  `(ff:def-foreign-type ,name (:struct ,@(process-aggregate-fields name fields)))
   #+lispworks
-  `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
+  `(fli:define-c-struct ,name ,@(process-aggregate-fields name fields))
   #+digitool
-  `(ccl:defrecord ,name ,@(process-struct-fields name fields))
+  `(ccl:defrecord ,name ,@(process-aggregate-fields name fields))
   #+openmcl
   `(ccl::def-foreign-type
     nil 
-    (:struct ,name ,@(process-struct-fields name fields)))
+    (:struct ,name ,@(process-aggregate-fields name fields)))
   )
 
 
@@ -192,19 +200,26 @@
 
 (defmacro def-union (name &rest fields)
   #+allegro
-  `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
+  `(ff:def-foreign-type ,name (:union ,@(process-aggregate-fields name fields
+                                                                  :aggregate-type :union)))
   #+lispworks
-  `(fli:define-c-union ,name ,@(process-struct-fields name fields))
+  `(fli:define-c-union ,name ,@(process-aggregate-fields name fields
+                                                         :aggregate-type :union))
   #+(or cmu scl)
-  `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
+  `(alien:def-alien-type ,name (alien:union ,name ,@(process-aggregate-fields name fields
+                                                                              :aggregate-type :union)))
   #+sbcl
-  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
+  `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-aggregate-fields name fields
+                                                                                       :aggregate-type :union)))
   #+digitool
-  `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
+  `(ccl:defrecord ,name (:variant ,@(process-aggregate-fields name fields
+                                                              :variant t
+                                                              :aggregate-type :union)))
   #+openmcl
   `(ccl::def-foreign-type nil 
-			  (:union ,name ,@(process-struct-fields name fields)))
-)
+    (:union ,name ,@(process-aggregate-fields name fields
+                                              :aggregate-type :union)))
+  )
 
 
 #-(or sbcl cmu)


From hhubner at common-lisp.net  Mon Feb 18 10:30:00 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:30:00 -0500 (EST)
Subject: [bknr-cvs] r2527 -
	branches/trunk-reorg/thirdparty/hunchentoot-0.15.0
Message-ID: <20080218103000.E354515022@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:30:00 2008
New Revision: 2527

Modified:
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp
Log:
CCL 1.2 compatibility fix

Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp	(original)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/port-mcl.lisp	Mon Feb 18 05:30:00 2008
@@ -41,6 +41,7 @@
   "Like INCF, but other threads can't interfer."
   `(ccl::atomic-incf-decf ,place ,delta))
 
+#-openmcl-native-threads
 (defun invoke-with-timeout (seconds bodyfn timeoutfn)
   "Executes the function \(with no arguments) BODY-FN and returns
 its results but stops execution after DURATION seconds and then
@@ -54,6 +55,7 @@
       (unwind-protect (funcall bodyfn)
 	(ccl::dequeue-timer-request timer)))))
 
+#-openmcl-native-threads
 (defmacro with-timeout ((seconds &body timeout-forms) &body body)
   "Executes the code BODY and returns the results of the last
 form but stops execution after SECONDS seconds and then instead
@@ -63,6 +65,14 @@
                         #'(lambda () , at body)
                         #'(lambda () , at timeout-forms)))
 
+#+openmcl-native-threads
+(defmacro with-timeout ((seconds &body timeout-forms) &body body)
+  "Compatibility stub, CCL with native threads does not support
+support asynchronous timeouts."
+  (declare (ignore seconds timeout-forms))
+  `(progn
+    , at body))
+
 (defun process-run-function (name function &rest args)
   "See OpenMCL documentation for CCL:PROCESS-RUN-FUNCTION."
   (apply #'ccl:process-run-function name function args))


From hhubner at common-lisp.net  Mon Feb 18 10:34:39 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:34:39 -0500 (EST)
Subject: [bknr-cvs] r2528 - branches/trunk-reorg/bknr/datastore/src/data
Message-ID: <20080218103439.109FC24104@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:34:38 2008
New Revision: 2528

Modified:
   branches/trunk-reorg/bknr/datastore/src/data/object.lisp
Log:
Fix warnings


Modified: branches/trunk-reorg/bknr/datastore/src/data/object.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/data/object.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/data/object.lisp	Mon Feb 18 05:34:38 2008
@@ -133,7 +133,7 @@
   (:metaclass persistent-class)
   (:class-indices (all-class :index-type class-skip-index
 			     :index-subclasses t
-			     :index-initargs (:type 'integer :index-superclasses t)
+			     :index-initargs (:index-superclasses t)
 			     :index-keys all-store-classes
 			     :index-reader store-objects-with-class
 			     :slots (id))))
@@ -410,8 +410,7 @@
 	(progn
 	  #+nil (format t "read-slots for object ~A, id ~A~%" object object-id)
 	  (unless object
-	    (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id)
-	    (return-from snapshot-read-slots))
+	    (error "READ-SLOTS form for unexistent object with ID ~A~%" object-id))
 	  (%read-slots stream object (cdr (gethash layout-id layouts)))
 	  #+nil
 	  (when object 


From hhubner at common-lisp.net  Mon Feb 18 10:35:20 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:35:20 -0500 (EST)
Subject: [bknr-cvs] r2529 - branches/trunk-reorg/bknr/datastore/src/indices
Message-ID: <20080218103520.9D4712411E@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:35:20 2008
New Revision: 2529

Modified:
   branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp
   branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp
Log:
Fix warnings.


Modified: branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/indices/category-index.lisp	Mon Feb 18 05:35:20 2008
@@ -141,13 +141,11 @@
     (when (and (not (slot-index-index-nil index))
 	       (null key))
       (return-from index-add))
-    (multiple-value-bind (value presentp)
-	(gethash key hash-table)
-      (if presentp
-	  (push object (gethash key hash-table))
-	  (progn
-	    (tree-add-category tree key)
-	    (setf (gethash key hash-table) (list object)))))))
+    (if (nth-value 1 (gethash key hash-table))
+        (push object (gethash key hash-table))
+        (progn
+          (tree-add-category tree key)
+          (setf (gethash key hash-table) (list object))))))
 
 (defmethod index-remove ((index category-index) object)
   (let ((key (slot-value object (slot-index-slot-name index)))

Modified: branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/indices/indices.lisp	Mon Feb 18 05:35:20 2008
@@ -135,11 +135,9 @@
     (when (and (not (slot-index-index-nil index))
 	       (null key))
       (return-from index-add))
-    (multiple-value-bind (value presentp)
-	(gethash key hash-table)
-      (if presentp
-	  (push object (gethash key hash-table))
-	  (setf (gethash key hash-table) (list object))))))
+    (if (nth-value 1 (gethash key hash-table))
+        (push object (gethash key hash-table))
+        (setf (gethash key hash-table) (list object)))))
 
 (defmethod index-remove ((index hash-index) object)
   (let ((key (slot-value object (slot-index-slot-name index)))
@@ -172,11 +170,9 @@
   (labels ((index-object (object class)
 	     (let ((key (class-name class))
 		   (hash-table (slot-index-hash-table index)))
-	       (multiple-value-bind (value presentp)
-		   (gethash key hash-table)
-		 (if presentp
-		     (push object (gethash key hash-table))
-		     (setf (gethash key hash-table) (list object)))))))
+               (if (nth-value 1 (gethash key hash-table))
+                   (push object (gethash key hash-table))
+                   (setf (gethash key hash-table) (list object))))))
     
     (if (class-index-index-superclasses index)
 	(dolist (class (cons (class-of object)
@@ -212,11 +208,9 @@
   (let ((keys (slot-value object (slot-index-slot-name index)))
 	(hash-table (slot-index-hash-table index)))
     (dolist (key keys)
-      (multiple-value-bind (value presentp)
-	  (gethash key hash-table)
-	(if presentp
-	    (push object (gethash key hash-table))
-	    (setf (gethash key hash-table) (list object)))))))
+      (if (nth-value 1 (gethash key hash-table))
+          (push object (gethash key hash-table))
+          (setf (gethash key hash-table) (list object))))))
 
 (defmethod index-remove ((index hash-list-index) object)
   (let ((keys (slot-value object (slot-index-slot-name index)))
@@ -406,7 +400,7 @@
 the new skip-list."
   (let ((new-list (skip-list-index-skip-list new-index)) 
 	(old-list (skip-list-index-skip-list old-index)))
-    (setf (skip-list-index-skip-list new-index) old-list)
+    (setf (skip-list-index-skip-list new-list) old-list)
     new-index))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -419,9 +413,8 @@
 	      :accessor class-skip-index-slot-name)
    (hash-table :accessor class-skip-index-hash-table)))
 
-(defmethod initialize-instance :after ((index class-skip-index) &key (type 'string)
-				       (test #'eql)
-				       slots index-superclasses &allow-other-keys)
+(defmethod initialize-instance :after ((index class-skip-index)
+                                       &key (test #'eql) slots index-superclasses)
   (unless (<= (length slots) 1)
     (error "Can not create slot-index with more than one slot."))
   (with-slots (hash-table slot-name) index


From hhubner at common-lisp.net  Mon Feb 18 10:36:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:36:28 -0500 (EST)
Subject: [bknr-cvs] r2530 - branches/trunk-reorg/bknr/datastore/src/xml-impex
Message-ID: <20080218103628.E1A954D043@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:36:28 2008
New Revision: 2530

Modified:
   branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp
Log:
refactor, remove warnings

Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp
==============================================================================
--- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp	(original)
+++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp	Mon Feb 18 05:36:28 2008
@@ -12,43 +12,14 @@
 (defmacro with-xml-export* ((&key output indentation canonical) &body body)
   `(let ((*objects-written* (make-hash-table :test #'equal))
 	 (cxml::*current-element* nil)
-         (cxml::*sink* #+(or) (cxml:make-character-stream-sink ,output
-							       :indentation ,indentation :canonical ,canonical)))
+         (cxml::*sink* (cxml:make-character-stream-sink ,output
+                                                        :indentation ,indentation :canonical ,canonical)))
      , at body))
 
 (defmacro with-xml-export (nil &body body)
   `(with-xml-export* (:output *standard-output* :indentation 1 :canonical nil)
      , at body))
 
-(defgeneric write-to-xml (object &key name no-recurse)
-  (:documentation "Write object to XML stream"))
-
-(defmethod write-to-xml ((object (eql nil)) &key name no-recurse)
-  (declare (ignore name)))
-
-(defmethod write-to-xml ((object list) &key (name (error "Can not serialize list to XML without an element name~%")) no-recurse)
-  (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil)
-  (dolist (obj object)
-    (write-to-xml obj))
-  (sax:end-element cxml::*sink* nil nil (cxml::string-rod name)))
-
-(defmethod write-to-xml ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)) no-recurse)
-  (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil)
-  (sax:characters cxml::*sink* (cxml::string-rod object))
-  (sax:end-element cxml::*sink* nil nil (cxml::string-rod name)))
-
-(defmethod write-to-xml ((object standard-object) &key &allow-other-keys)
-  (cxml:with-element (string-downcase (class-name (class-of object)))
-    (dolist (slot (class-slots (class-of object)))
-      (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot)))
-	(let ((value (slot-value object (slot-definition-name slot))))
-	  (when value
-	    (cxml:text (handler-case
-			   (cxml::utf8-string-to-rod (princ-to-string value))
-			 (error (e)
-			   (declare (ignore e))
-			   (cxml::utf8-string-to-rod "[unprintable]"))))))))))
-
 (defun write-object-reference (class object unique-id-slot-name name)
   (let ((slotdef (find unique-id-slot-name (class-slots class) :key #'slot-definition-name)))
     (unless (xml-effective-slot-definition-attribute slotdef)
@@ -58,65 +29,92 @@
                                                  :value (cxml::string-rod (slot-serialize-value slotdef (slot-value object unique-id-slot-name))))))
     (sax:end-element cxml::*sink* nil nil name)))
 
-(defmethod write-to-xml ((object xml-class) &key name no-recurse)
-  (xml-object-check-validity object)
-  (let* ((class (class-of object))
-	 (qname (cxml::string-rod (or name (xml-class-element class)))))
-
-    ;; If this object has been serialized to the XML stream,
-    ;; write a reference to the object and return.
-
-    (with-slots (unique-id-slot) class
-      (when unique-id-slot
-	(if (gethash (slot-value object (first unique-id-slot)) *objects-written*)
-	    (progn
-	      (write-object-reference class object (first unique-id-slot) qname)
-	      (return-from write-to-xml))
-	    (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t))))
-
-    ;; Object has not been written to the XML file or no
-    ;; unique-id-slot is defined for this class.
-
-    (let* ((attr-slots (xml-class-attribute-slots class))
-	   (elt-slots (xml-class-element-slots class))
-	   (body-slot (xml-class-body-slot class))
-	   ;; attributes
-	   (attributes (loop for slot in attr-slots
-			  for name = (slot-definition-name slot)
-			  for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot))
-			  when (and (slot-boundp object name)
-				    (slot-value object name))
-			  collect (sax:make-attribute
-				   :qname attdef
-				   :value
-				   (cxml::string-rod
-				    (slot-serialize-value slot (slot-value object name)))))))
-      (sax:start-element cxml::*sink* nil nil qname attributes)
-
-      ;; elements
-      (dolist (slot elt-slots)
-	(let ((name (slot-definition-name slot))
-	      (element-name (xml-effective-slot-definition-element slot))		     
-	      (containment (xml-effective-slot-definition-containment slot)))
-	  (when (slot-boundp object name)
-	    (if (consp (slot-value object name))
-		(dolist (child (slot-value object name))
-		  (if (typep (class-of child) 'xml-class)
-		      (write-to-xml child)
-		      (write-to-xml (slot-serialize-value slot child) :name element-name)))
-		(let ((child (slot-value object name)))
-		  (if (typep (class-of child) 'xml-class)
-		      (write-to-xml child)
-		      (write-to-xml (slot-serialize-value slot child) :name element-name)))))))
-
-      ;; body slot
-      (when body-slot
-	(let ((name (slot-definition-name body-slot)))
-	  (when (slot-boundp object name)
-	    (sax:characters
-	     cxml::*sink*
-	     (cxml::string-rod
-	      (funcall (xml-effective-slot-definition-serializer body-slot)
-		       (slot-value object name)))))))
+(defgeneric write-to-xml (object &key)
+  (:documentation "Write OBJECT to XML stream")
+
+  (:method ((object (eql nil)) &key))
+
+  (:method ((object list) &key (name (error "Can not serialize list to XML without an element name~%")))
+    (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil)
+    (dolist (obj object)
+      (write-to-xml obj))
+    (sax:end-element cxml::*sink* nil nil (cxml::string-rod name)))
+
+  (:method ((object string) &key (name (error "Can not serialize string ~A to XML without an element name." object)))
+    (sax:start-element cxml::*sink* nil nil (cxml::string-rod name) nil)
+    (sax:characters cxml::*sink* (cxml::string-rod object))
+    (sax:end-element cxml::*sink* nil nil (cxml::string-rod name)))
+
+  (:method ((object standard-object) &key)
+    (cxml:with-element (string-downcase (class-name (class-of object)))
+      (dolist (slot (class-slots (class-of object)))
+        (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot)))
+          (let ((value (slot-value object (slot-definition-name slot))))
+            (when value
+              (cxml:text (handler-case
+                             (cxml::utf8-string-to-rod (princ-to-string value))
+                           (error (e)
+                             (declare (ignore e))
+                             (cxml::utf8-string-to-rod "[unprintable]"))))))))))
+
+  (:method ((object xml-class) &key name)
+    (xml-object-check-validity object)
+    (let* ((class (class-of object))
+           (qname (cxml::string-rod (or name (xml-class-element class)))))
+      
+      ;; If this object has been serialized to the XML stream,
+      ;; write a reference to the object and return.
+
+      (with-slots (unique-id-slot) class
+        (when unique-id-slot
+          (if (gethash (slot-value object (first unique-id-slot)) *objects-written*)
+              (progn
+                (write-object-reference class object (first unique-id-slot) qname)
+                (return-from write-to-xml))
+              (setf (gethash (slot-value object (first unique-id-slot)) *objects-written*) t))))
+
+      ;; Object has not been written to the XML file or no
+      ;; unique-id-slot is defined for this class.
+
+      (let* ((attr-slots (xml-class-attribute-slots class))
+             (elt-slots (xml-class-element-slots class))
+             (body-slot (xml-class-body-slot class))
+             ;; attributes
+             (attributes (loop for slot in attr-slots
+                               for name = (slot-definition-name slot)
+                               for attdef = (cxml::string-rod (xml-effective-slot-definition-attribute slot))
+                               when (and (slot-boundp object name)
+                                         (slot-value object name))
+                               collect (sax:make-attribute
+                                        :qname attdef
+                                        :value
+                                        (cxml::string-rod
+                                         (slot-serialize-value slot (slot-value object name)))))))
+        (sax:start-element cxml::*sink* nil nil qname attributes)
+
+        ;; elements
+        (dolist (slot elt-slots)
+          (let ((name (slot-definition-name slot))
+                (element-name (xml-effective-slot-definition-element slot)))
+            (when (slot-boundp object name)
+              (if (consp (slot-value object name))
+                  (dolist (child (slot-value object name))
+                    (if (typep (class-of child) 'xml-class)
+                        (write-to-xml child)
+                        (write-to-xml (slot-serialize-value slot child) :name element-name)))
+                  (let ((child (slot-value object name)))
+                    (if (typep (class-of child) 'xml-class)
+                        (write-to-xml child)
+                        (write-to-xml (slot-serialize-value slot child) :name element-name)))))))
+
+        ;; body slot
+        (when body-slot
+          (let ((name (slot-definition-name body-slot)))
+            (when (slot-boundp object name)
+              (sax:characters
+               cxml::*sink*
+               (cxml::string-rod
+                (funcall (xml-effective-slot-definition-serializer body-slot)
+                         (slot-value object name)))))))
 	
-      (sax:end-element cxml::*sink* nil nil qname))))
+        (sax:end-element cxml::*sink* nil nil qname)))))


From hhubner at common-lisp.net  Mon Feb 18 10:39:20 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:39:20 -0500 (EST)
Subject: [bknr-cvs] r2531 - branches/trunk-reorg/projects/lisp-ecoop/src
Message-ID: <20080218103920.D09001502C@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:39:20 2008
New Revision: 2531

Modified:
   branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp
   branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
Log:
port to trunk-reorg

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/config.lisp	Mon Feb 18 05:39:20 2008
@@ -7,7 +7,11 @@
   (when (probe-file "site.lisp")
     (load "site.lisp")))
 
-(defparameter *root-directory* (merge-pathnames #P"../" *load-pathname*))
+(defparameter *root-directory* (merge-pathnames #P"../"
+                                                (make-pathname :name nil
+                                                               :type nil
+                                                               :version nil
+                                                               :defaults *load-pathname*)))
 
 (defparameter *store-directory* (merge-pathnames #p"datastore/" *root-directory*))
 

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/init.lisp	Mon Feb 18 05:39:20 2008
@@ -11,7 +11,7 @@
   (unless (find-user "anonymous")
     (make-user "anonymous")		; used for all anonymous sessions
     (make-user "admin" :password "wispleb" :full-name "Administrator" :flags '(:admin))
-    (import-image "bknr-logo.png" :keywords '(:banner :bknr)))
+    (import-image (probe-file #P"bknr-logo.png") :keywords '(:banner :bknr)))
 
   #+(or)
   (bknr.cron:start-cron)

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/participant.lisp	Mon Feb 18 05:39:20 2008
@@ -16,7 +16,7 @@
     (with-slots (documents) submission
       (setf documents (remove document documents)))))
 
-y(define-lisp-ecoop-class submission ()
+(define-lisp-ecoop-class submission ()
   ((title :update :documentation "Title of the submission" :initform nil :attribute t)
    (abstract :update :documentation "Abstract or short description" :initform nil :element t)
    (submitters :update :documentation "List of participants who submitted this" :initform nil :element t :containment :+)

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/tags.lisp	Mon Feb 18 05:39:20 2008
@@ -393,4 +393,4 @@
          (pathname (find-template-pathname expander "toplevel"))
          (toplevel (bknr.web::get-cached-template pathname expander))
          (bknr.web::*toplevel-children* bknr.web::*tag-children*))
-    (emit-template-node toplevel)))
\ No newline at end of file
+    (emit-template-node expander toplevel)))
\ No newline at end of file

Modified: branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp	(original)
+++ branches/trunk-reorg/projects/lisp-ecoop/src/webserver.lisp	Mon Feb 18 05:39:20 2008
@@ -19,9 +19,9 @@
 		 :name "LISP ECOOP CMS"
                  :base-href base-href
                  :template-base-directory (namestring (merge-pathnames #p"templates/" *website-directory*))
-                 :template-command-packages '((:lisp-ecoop . :lisp-ecoop.tags)
-                                              (:bknr . :bknr.web)
-                                              (:menu . :bknr.site-menu))
+                 :template-command-packages '(("http://lisp-ecoop07.bknr.net" . :lisp-ecoop.tags)
+                                              ("http://bknr.net" . :bknr.web)
+                                              ("http://bknr.net/menu" . :bknr.site-menu))
 		 :handler-definitions `(user images
 					#+(or) stats
 					#+(or) mailinglist
@@ -41,4 +41,5 @@
   (when (and (boundp '*server*) *server*)
     (stop-server *server*))
   (publish-lisp-ecoop)
+  (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
   (setq *server* (start-server :port port)))
\ No newline at end of file


From hhubner at common-lisp.net  Mon Feb 18 10:42:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 05:42:28 -0500 (EST)
Subject: [bknr-cvs] r2532 - in branches/trunk-reorg/projects: eboy gpn
	raw-data saugnapf unmaintained unmaintained/eboy
	unmaintained/gpn unmaintained/raw-data unmaintained/saugnapf
Message-ID: <20080218104228.2B9383001B@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 05:42:27 2008
New Revision: 2532

Added:
   branches/trunk-reorg/projects/unmaintained/
   branches/trunk-reorg/projects/unmaintained/eboy/
      - copied from r2514, branches/trunk-reorg/projects/eboy/
   branches/trunk-reorg/projects/unmaintained/gpn/
      - copied from r2514, branches/trunk-reorg/projects/gpn/
   branches/trunk-reorg/projects/unmaintained/raw-data/
      - copied from r2514, branches/trunk-reorg/projects/raw-data/
   branches/trunk-reorg/projects/unmaintained/saugnapf/
      - copied from r2514, branches/trunk-reorg/projects/saugnapf/
Removed:
   branches/trunk-reorg/projects/eboy/
   branches/trunk-reorg/projects/gpn/
   branches/trunk-reorg/projects/raw-data/
   branches/trunk-reorg/projects/saugnapf/
Log:
create "unmaintained" directory and move the historical projects there


From ksprotte at common-lisp.net  Mon Feb 18 10:46:33 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 05:46:33 -0500 (EST)
Subject: [bknr-cvs] r2533 - in branches/trunk-reorg/thirdparty/arnesi: . src
Message-ID: <20080218104633.514ED1705D@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 05:46:33 2008
New Revision: 2533

Added:
   branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp
Modified:
   branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
   branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
   branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
Log:
pulled latest arnesi - no slime dep anymore


Modified: branches/trunk-reorg/thirdparty/arnesi/arnesi.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/arnesi/arnesi.asd	(original)
+++ branches/trunk-reorg/thirdparty/arnesi/arnesi.asd	Mon Feb 18 05:46:33 2008
@@ -35,7 +35,7 @@
 			     (:file "lisp1" :depends-on ("packages" "lambda-list" "one-liners" "walk" "unwalk"))
                              (:file "lexenv" :depends-on ("packages" "one-liners"))
                              (:file "list" :depends-on ("packages" "one-liners" "accumulation" "flow-control"))
-                             ;; (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
+                             (:file "log" :depends-on ("packages" "numbers" "hash" "io"))
                              (:file "matcher" :depends-on ("packages" "hash" "list" "flow-control" "one-liners"))
                              (:file "mop" :depends-on ("packages" "mopp"))
 			     (:file "mopp" :depends-on ("packages" "list" "flow-control"))
@@ -55,15 +55,14 @@
                              (:file "vector" :depends-on ("packages" "flow-control"))
                              (:file "walk" :depends-on ("packages" "list" "mopp" "lexenv" "one-liners")))))
   :properties ((:features "v1.4.0" "v1.4.1" "v1.4.2" "cc-interpreter"
-                          "join-strings-return-value" "getenv"))
-  :depends-on (:swank))
+                          "join-strings-return-value" "getenv")))
 
 (defsystem :arnesi.test
   :components ((:module :t
 		:components ((:file "accumulation" :depends-on ("suite"))
                              (:file "call-cc" :depends-on ("suite"))
                              (:file "http" :depends-on ("suite"))
-                             ;; (:file "log" :depends-on ("suite"))
+                             (:file "log" :depends-on ("suite"))
                              (:file "matcher" :depends-on ("suite"))
                              (:file "numbers" :depends-on ("suite"))
                              (:file "queue" :depends-on ("suite"))
@@ -83,6 +82,10 @@
                 :components ((:file "cl-ppcre-extras"))))
   :depends-on (:cl-ppcre :arnesi))
 
+(defsystem :arnesi.slime-extras
+  :components ((:module :src :components ((:file "slime-extras"))))
+  :depends-on (:arnesi :swank))
+
 (defmethod perform ((op asdf:test-op) (system (eql (find-system :arnesi))))
   (asdf:oos 'asdf:load-op :arnesi.test)
   (funcall (intern (string :run!) (string :it.bese.FiveAM))

Modified: branches/trunk-reorg/thirdparty/arnesi/src/log.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/arnesi/src/log.lisp	(original)
+++ branches/trunk-reorg/thirdparty/arnesi/src/log.lisp	Mon Feb 18 05:46:33 2008
@@ -77,45 +77,6 @@
     (pushnew l (children anc) :test (lambda (a b)
 				     (eql (name a) (name b))))))
 
-(defun log-level-setter-inspector-action-for (prompt current-level setter)
-  (lambda ()
-    (with-simple-restart
-        (abort "Abort setting log level")
-      (let ((value-string (swank::eval-in-emacs
-                           `(condition-case c
-                             (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list)))))
-                               (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level))
-                                                  :initial-value ,(string-downcase (log-level-name-of current-level))))
-                             (quit nil)))))
-        (when (and value-string
-                   (not (string= value-string "")))
-          (funcall setter (eval (let ((*package* #.(find-package :arnesi)))
-                                  (read-from-string value-string)))))))))
-
-(defmethod swank:inspect-for-emacs ((category log-category))
-  (let ((class (class-of category)))
-    (values "A log-category."
-            `("Class: " (:value ,class) (:newline)
-              "Runtime level: " (:value ,(log.level category)
-                                 ,(string (log-level-name-of (log.level category))))
-              " "
-              (:action "[set level]" ,(log-level-setter-inspector-action-for
-                                       "Set runtime log level to (evaluated): "
-                                       (log.level category)
-                                       (lambda (value)
-                                         (setf (log.level category) value))))
-              (:newline)
-              "Compile-time level: " (:value ,(log.compile-time-level category)
-                                      ,(string (log-level-name-of (log.compile-time-level category))))
-               " "
-              (:action "[set level]" ,(log-level-setter-inspector-action-for
-                                       "Set compile-time log level to (evaluated): "
-                                       (log.compile-time-level category)
-                                       (lambda (value)
-                                         (setf (log.compile-time-level category) value))))
-              (:newline)
-              ,@(swank::all-slots-for-inspector category)))))
-
 ;;; Runtime levels
 (defmethod enabled-p ((cat log-category) level)
   (>= level (log.level cat)))
@@ -331,69 +292,6 @@
          :verbosity verbosity
          args))
 
-(defclass slime-repl-log-appender (appender)
-  ()
-  (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection.
-
-You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations:
-
-\(add-hook 'slime-repl-mode-hook
-          (lambda ()
-            (setf parse-sexp-lookup-properties nil)))
-"))
-
-(defun swank::present-in-emacs (value-or-values &key (separated-by " "))
-  "Present VALUE in the Emacs repl buffer of the current thread."
-  (unless (consp value-or-values)
-    (setf value-or-values (list value-or-values)))
-  (flet ((present (value)
-           (if (stringp value)
-               (swank::send-to-emacs `(:write-string ,value))
-               (let ((id (swank::save-presented-object value)))
-                 (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
-    (map nil (let ((first-time-p t))
-               (lambda (value)
-                 (when (and (not first-time-p)
-                            separated-by)
-                   (present separated-by))
-                 (present value)
-                 (setf first-time-p nil)))
-         value-or-values))
-  (values))
-
-(defmethod append-message ((category log-category) (appender slime-repl-log-appender)
-                           message level)
-  (when (swank::default-connection)
-    (swank::with-connection ((swank::default-connection))
-      (multiple-value-bind (second minute hour day month year)
-          (decode-universal-time (get-universal-time))
-        (declare (ignore second day month year))
-        (swank::present-in-emacs (format nil
-                                         "~2,'0D:~2,'0D ~A/~A: "
-                                         hour minute
-                                         (symbol-name (name category))
-                                         (symbol-name level))))
-      (if (consp message)
-          (let ((format-control (when (stringp (first message))
-                                  (first message)))
-                (args (if (stringp (first message))
-                          (rest message)
-                          message)))
-            (when format-control
-              (setf message (apply #'format nil format-control args)))
-            (swank::present-in-emacs message)
-            (awhen (and format-control
-                        (> (verbosity-of appender) 1)
-                        (remove-if (lambda (el)
-                                     (or (stringp el)
-                                         (null el)))
-                                   args))
-              (swank::present-in-emacs " (")
-              (swank::present-in-emacs it)
-              (swank::present-in-emacs ")")))
-          (swank::present-in-emacs message))
-      (swank::present-in-emacs #.(string #\Newline)))))
-
 (defun arnesi-logger-inspector-lookup-hook (form)
   (when (symbolp form)
     (if-bind logger (get-logger form)
@@ -402,13 +300,6 @@
         (when-bind logger (get-logger logger-name)
           (values logger t))))))
 
-(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank)
-  (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it)))
-
-(defun make-slime-repl-log-appender (&rest args &key (verbosity 2))
-  (remf-keywords args :verbosity)
-  (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args))
-
 (defclass file-log-appender (stream-log-appender)
   ((log-file :initarg :log-file :accessor log-file
              :documentation "Name of the file to write log messages to."))

Modified: branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp
==============================================================================
--- branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp	(original)
+++ branches/trunk-reorg/thirdparty/arnesi/src/packages.lisp	Mon Feb 18 05:46:33 2008
@@ -224,7 +224,6 @@
    #:brief-stream-log-appender
    #:verbose-stream-log-appender
    #:make-stream-log-appender
-   #:make-slime-repl-log-appender
    #:file-log-appender
    #:make-file-log-appender
    #:deflogger

Added: branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp
==============================================================================
--- (empty file)
+++ branches/trunk-reorg/thirdparty/arnesi/src/slime-extras.lisp	Mon Feb 18 05:46:33 2008
@@ -0,0 +1,114 @@
+(in-package :arnesi)
+
+;;;; * Logging slime integration
+
+(defclass slime-repl-log-appender (appender)
+  ()
+  (:documentation "Logs to the slime repl when there's a valid swank::*emacs-connection* bound. Arguments are presented ready for inspection.
+
+You may want to add this to your init.el to speed up cursor movement in the repl buffer with many presentations:
+
+\(add-hook 'slime-repl-mode-hook
+          (lambda ()
+            (setf parse-sexp-lookup-properties nil)))
+"))
+
+(awhen (find-symbol (symbol-name '#:*inspector-dwim-lookup-hooks*) :swank)
+  (pushnew 'arnesi-logger-inspector-lookup-hook (symbol-value it)))
+
+(defun make-slime-repl-log-appender (&rest args &key (verbosity 2))
+  (remf-keywords args :verbosity)
+  (apply #'make-instance 'slime-repl-log-appender :verbosity verbosity args))
+
+(export '(make-slime-repl-log-appender) :arnesi)
+
+(defun swank::present-in-emacs (value-or-values &key (separated-by " "))
+  "Present VALUE in the Emacs repl buffer of the current thread."
+  (unless (consp value-or-values)
+    (setf value-or-values (list value-or-values)))
+  (flet ((present (value)
+           (if (stringp value)
+               (swank::send-to-emacs `(:write-string ,value))
+               (let ((id (swank::save-presented-object value)))
+                 (swank::send-to-emacs `(:write-string ,(prin1-to-string value) ,id))))))
+    (map nil (let ((first-time-p t))
+               (lambda (value)
+                 (when (and (not first-time-p)
+                            separated-by)
+                   (present separated-by))
+                 (present value)
+                 (setf first-time-p nil)))
+         value-or-values))
+  (values))
+
+(defmethod append-message ((category log-category) (appender slime-repl-log-appender)
+                           message level)
+  (when (swank::default-connection)
+    (swank::with-connection ((swank::default-connection))
+      (multiple-value-bind (second minute hour day month year)
+          (decode-universal-time (get-universal-time))
+        (declare (ignore second day month year))
+        (swank::present-in-emacs (format nil
+                                         "~2,'0D:~2,'0D ~A/~A: "
+                                         hour minute
+                                         (symbol-name (name category))
+                                         (symbol-name level))))
+      (if (consp message)
+          (let ((format-control (when (stringp (first message))
+                                  (first message)))
+                (args (if (stringp (first message))
+                          (rest message)
+                          message)))
+            (when format-control
+              (setf message (apply #'format nil format-control args)))
+            (swank::present-in-emacs message)
+            (awhen (and format-control
+                        (> (verbosity-of appender) 1)
+                        (remove-if (lambda (el)
+                                     (or (stringp el)
+                                         (null el)))
+                                   args))
+              (swank::present-in-emacs " (")
+              (swank::present-in-emacs it)
+              (swank::present-in-emacs ")")))
+          (swank::present-in-emacs message))
+      (swank::present-in-emacs #.(string #\Newline)))))
+
+(defun log-level-setter-inspector-action-for (prompt current-level setter)
+  (lambda ()
+    (with-simple-restart
+        (abort "Abort setting log level")
+      (let ((value-string (swank::eval-in-emacs
+                           `(condition-case c
+                             (let ((arnesi-log-levels '(,@(mapcar #'string-downcase (coerce *log-level-names* 'list)))))
+                               (slime-read-object ,prompt :history (cons 'arnesi-log-levels ,(1+ current-level))
+                                                  :initial-value ,(string-downcase (log-level-name-of current-level))))
+                             (quit nil)))))
+        (when (and value-string
+                   (not (string= value-string "")))
+          (funcall setter (eval (let ((*package* #.(find-package :arnesi)))
+                                  (read-from-string value-string)))))))))
+
+(defmethod swank:emacs-inspect ((category log-category))
+  (let ((class (class-of category)))
+    (values "A log-category."
+            `("Class: " (:value ,class) (:newline)
+              "Runtime level: " (:value ,(log.level category)
+                                 ,(string (log-level-name-of (log.level category))))
+              " "
+              (:action "[set level]" ,(log-level-setter-inspector-action-for
+                                       "Set runtime log level to (evaluated): "
+                                       (log.level category)
+                                       (lambda (value)
+                                         (setf (log.level category) value))))
+              (:newline)
+              "Compile-time level: " (:value ,(log.compile-time-level category)
+                                      ,(string (log-level-name-of (log.compile-time-level category))))
+               " "
+              (:action "[set level]" ,(log-level-setter-inspector-action-for
+                                       "Set compile-time log level to (evaluated): "
+                                       (log.compile-time-level category)
+                                       (lambda (value)
+                                         (setf (log.compile-time-level category) value))))
+              (:newline)
+              ,@(swank::all-slots-for-inspector category)))))


From hhubner at common-lisp.net  Mon Feb 18 11:33:01 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:33:01 -0500 (EST)
Subject: [bknr-cvs] r2534 -
	branches/trunk-reorg/thirdparty/hunchentoot-0.15.0
Message-ID: <20080218113301.8F1AD5E006@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:32:59 2008
New Revision: 2534

Modified:
   branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
Log:
Re-enable acl-compat, needed for WITH-TIMEOUT (but I'd rather see that not
used).


Modified: branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
==============================================================================
--- branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	(original)
+++ branches/trunk-reorg/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	Mon Feb 18 06:32:59 2008
@@ -51,7 +51,7 @@
                :rfc2388
                #+:sbcl :sb-bsd-sockets
                #+:sbcl :sb-posix
-               ; #+:openmcl :acl-compat
+               #+:openmcl :acl-compat
                :url-rewrite)
   :components ((:file "packages")
                (:file "conditions")


From hhubner at common-lisp.net  Mon Feb 18 11:34:45 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:34:45 -0500 (EST)
Subject: [bknr-cvs] r2535 - branches/trunk-reorg/projects/lisp-ecoop/website
Message-ID: <20080218113445.479413916E@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:34:44 2008
New Revision: 2535

Removed:
   branches/trunk-reorg/projects/lisp-ecoop/website/
Log:
remove 2007 templates


From hhubner at common-lisp.net  Mon Feb 18 11:36:20 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:36:20 -0500 (EST)
Subject: [bknr-cvs] r2536 - branches/trunk-reorg/projects/lisp-ecoop/website
Message-ID: <20080218113620.D419E2400D@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:36:20 2008
New Revision: 2536

Added:
   branches/trunk-reorg/projects/lisp-ecoop/website/
      - copied from r2535, trunk/projects/lisp-ecoop/website/
Log:
copy 2008 templates from trunk before it is deleted.



From hhubner at common-lisp.net  Mon Feb 18 11:38:29 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:38:29 -0500 (EST)
Subject: [bknr-cvs] r2537 - trunk
Message-ID: <20080218113829.A86F43001B@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:38:29 2008
New Revision: 2537

Removed:
   trunk/
Log:
trunk is being replaced by trunk-reorg branch


From hhubner at common-lisp.net  Mon Feb 18 11:40:19 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:40:19 -0500 (EST)
Subject: [bknr-cvs] r2538 - branches/trunk-reorg trunk
Message-ID: <20080218114019.1B24C39178@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:40:18 2008
New Revision: 2538

Added:
   trunk/
      - copied from r2537, branches/trunk-reorg/
Removed:
   branches/trunk-reorg/
Log:
Replaced trunk with reorganized branch.



From hhubner at common-lisp.net  Mon Feb 18 11:44:15 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:44:15 -0500 (EST)
Subject: [bknr-cvs] r2539 - branches/bknr.net
Message-ID: <20080218114415.359F144052@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:44:14 2008
New Revision: 2539

Removed:
   branches/bknr.net/
Log:
Remove obsolete branch



From hhubner at common-lisp.net  Mon Feb 18 11:44:37 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:44:37 -0500 (EST)
Subject: [bknr-cvs] r2540 - branches/legacy
Message-ID: <20080218114437.8696E4D043@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:44:37 2008
New Revision: 2540

Removed:
   branches/legacy/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 11:46:37 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:46:37 -0500 (EST)
Subject: [bknr-cvs] r2541 - branches/grin
Message-ID: <20080218114637.DA6AC5E105@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:46:37 2008
New Revision: 2541

Removed:
   branches/grin/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 11:46:51 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:46:51 -0500 (EST)
Subject: [bknr-cvs] r2542 - branches/grin-neu
Message-ID: <20080218114651.6665481000@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:46:51 2008
New Revision: 2542

Removed:
   branches/grin-neu/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 11:48:07 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 06:48:07 -0500 (EST)
Subject: [bknr-cvs] r2543 - branches/xml-class-rework
Message-ID: <20080218114807.5D1342E17C@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 06:48:07 2008
New Revision: 2543

Removed:
   branches/xml-class-rework/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 12:11:39 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 07:11:39 -0500 (EST)
Subject: [bknr-cvs] r2544 - branches/hoan
Message-ID: <20080218121139.BA8D2481A9@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 07:11:39 2008
New Revision: 2544

Removed:
   branches/hoan/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 12:12:13 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 07:12:13 -0500 (EST)
Subject: [bknr-cvs] r2545 - vendor/cxml
Message-ID: <20080218121213.176C856222@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 07:12:12 2008
New Revision: 2545

Removed:
   vendor/cxml/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 12:12:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 07:12:28 -0500 (EST)
Subject: [bknr-cvs] r2546 - vendor/portableaserve
Message-ID: <20080218121228.A40095C183@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 07:12:28 2008
New Revision: 2546

Removed:
   vendor/portableaserve/
Log:
remove obsolete branch


From hhubner at common-lisp.net  Mon Feb 18 12:34:18 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 07:34:18 -0500 (EST)
Subject: [bknr-cvs] r2547 - trunk/bknr/web/src/web
Message-ID: <20080218123418.2ABAD5C184@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 07:34:17 2008
New Revision: 2547

Modified:
   trunk/bknr/web/src/web/authorizer.lisp
   trunk/bknr/web/src/web/handlers.lisp
Log:
Make FIND-USER-FROM-REQUEST-PARAMS a GF again to support BOS.


Modified: trunk/bknr/web/src/web/authorizer.lisp
==============================================================================
--- trunk/bknr/web/src/web/authorizer.lisp	(original)
+++ trunk/bknr/web/src/web/authorizer.lisp	Mon Feb 18 07:34:17 2008
@@ -27,18 +27,21 @@
              (declare (ignore c))
              (format s "Login failed"))))
 
-(defun find-user-from-request-parameters ()
-  (with-query-params (__username __password)
-    (unless (and __username __password
-                 (not (equal __username ""))
-                 (not (equal __password "")))
-      (return-from find-user-from-request-parameters nil))
-    (let ((user (find-user __username)))
+(defgeneric find-user-from-request-parameters ((authorizer authorizer))
+  (:documentation "Return the user that is associated with the current
+request or NIL.")
+  (:method ((authorizer bknr-authorizer))
+    (with-query-params (__username __password)
+      (unless (and __username __password
+                   (not (equal __username ""))
+                   (not (equal __password "")))
+        (return-from find-user-from-request-parameters nil))
+      (let ((user (find-user __username)))
 	(when (and user
                    (not (user-disabled user))
 		   (verify-password user __password))
           (return-from find-user-from-request-parameters user)))
-    (error 'login-failure)))
+      (error 'login-failure))))
 
 (defmethod authorize ((authorizer bknr-authorizer))
   ;; Catch any errors that occur during request body processing

Modified: trunk/bknr/web/src/web/handlers.lisp
==============================================================================
--- trunk/bknr/web/src/web/handlers.lisp	(original)
+++ trunk/bknr/web/src/web/handlers.lisp	Mon Feb 18 07:34:17 2008
@@ -283,10 +283,9 @@
 (defun ensure-bknr-session ()
   "Ensure that the BKNR-SESSION session variable is set and that it
 belongs to the user that is specified in the request."
-  (let ((request-user (find-user-from-request-parameters)))
+  (let ((request-user (find-user-from-request-parameters (website-authorizer *website*))))
     (unless (and (session-value 'bknr-session)
-                 (equal (bknr-session-user)
-                        (find-user-from-request-parameters)))
+                 (eq (bknr-session-user) request-user))
       (setf (session-value 'bknr-session)
             (make-instance 'bknr-session :user (or request-user
                                                    (find-user "anonymous")))))))


From hhubner at common-lisp.net  Mon Feb 18 12:35:28 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 07:35:28 -0500 (EST)
Subject: [bknr-cvs] r2548 - trunk/projects/lisp-ecoop/src
Message-ID: <20080218123528.136052E1D1@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 07:35:24 2008
New Revision: 2548

Modified:
   trunk/projects/lisp-ecoop/src/webserver.lisp
Log:
Fix namespace URL for ELW application.


Modified: trunk/projects/lisp-ecoop/src/webserver.lisp
==============================================================================
--- trunk/projects/lisp-ecoop/src/webserver.lisp	(original)
+++ trunk/projects/lisp-ecoop/src/webserver.lisp	Mon Feb 18 07:35:24 2008
@@ -19,7 +19,7 @@
 		 :name "LISP ECOOP CMS"
                  :base-href base-href
                  :template-base-directory (namestring (merge-pathnames #p"templates/" *website-directory*))
-                 :template-command-packages '(("http://lisp-ecoop07.bknr.net" . :lisp-ecoop.tags)
+                 :template-command-packages '(("http://elw.bknr.net/" . :lisp-ecoop.tags)
                                               ("http://bknr.net" . :bknr.web)
                                               ("http://bknr.net/menu" . :bknr.site-menu))
 		 :handler-definitions `(user images


From ksprotte at common-lisp.net  Mon Feb 18 13:05:50 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 08:05:50 -0500 (EST)
Subject: [bknr-cvs] r2549 - trunk/bknr/web/src/web
Message-ID: <20080218130550.0234E24141@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 08:05:47 2008
New Revision: 2549

Modified:
   trunk/bknr/web/src/web/authorizer.lisp
Log:
(defgeneric find-user-from-request-parameters (authorizer) ...) small syntax fix


Modified: trunk/bknr/web/src/web/authorizer.lisp
==============================================================================
--- trunk/bknr/web/src/web/authorizer.lisp	(original)
+++ trunk/bknr/web/src/web/authorizer.lisp	Mon Feb 18 08:05:47 2008
@@ -27,7 +27,7 @@
              (declare (ignore c))
              (format s "Login failed"))))
 
-(defgeneric find-user-from-request-parameters ((authorizer authorizer))
+(defgeneric find-user-from-request-parameters (authorizer)
   (:documentation "Return the user that is associated with the current
 request or NIL.")
   (:method ((authorizer bknr-authorizer))


From ksprotte at common-lisp.net  Mon Feb 18 13:55:21 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 08:55:21 -0500 (EST)
Subject: [bknr-cvs] r2550 - in trunk/thirdparty/fiveam: . docs src t
Message-ID: <20080218135521.5A9104407B@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 08:55:20 2008
New Revision: 2550

Added:
   trunk/thirdparty/fiveam/
   trunk/thirdparty/fiveam/COPYING
   trunk/thirdparty/fiveam/README
   trunk/thirdparty/fiveam/docs/
   trunk/thirdparty/fiveam/docs/make-qbook.lisp
   trunk/thirdparty/fiveam/fiveam.asd
   trunk/thirdparty/fiveam/src/
   trunk/thirdparty/fiveam/src/check.lisp
   trunk/thirdparty/fiveam/src/classes.lisp
   trunk/thirdparty/fiveam/src/explain.lisp
   trunk/thirdparty/fiveam/src/fixture.lisp
   trunk/thirdparty/fiveam/src/packages.lisp
   trunk/thirdparty/fiveam/src/random.lisp
   trunk/thirdparty/fiveam/src/run.lisp
   trunk/thirdparty/fiveam/src/style.css
   trunk/thirdparty/fiveam/src/suite.lisp
   trunk/thirdparty/fiveam/src/test.lisp
   trunk/thirdparty/fiveam/t/
   trunk/thirdparty/fiveam/t/example.lisp
   trunk/thirdparty/fiveam/t/suite.lisp
   trunk/thirdparty/fiveam/t/tests.lisp
Log:
added fiveam


Added: trunk/thirdparty/fiveam/COPYING
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/COPYING	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,30 @@
+Copyright (c) 2003-2006, Edward Marco Baringer
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+  
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+    
+- Neither the name of Edward Marco Baringer, nor BESE, nor the names
+of its contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

Added: trunk/thirdparty/fiveam/README
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/README	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,9 @@
+This is FiveAM, a common lisp testing framework.
+
+The documentation can be found in the docstrings, start with the
+package :it.bese.fiveam (nicknamed 5AM).
+
+The mailing list for FiveAM is bese-devel at common-lisp.net (the list is
+shared with arnesi, yaclml and ucw).
+
+All the code is Copyright (C) 2002-2006 Edward Marco Baringer.
\ No newline at end of file

Added: trunk/thirdparty/fiveam/docs/make-qbook.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/docs/make-qbook.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,13 @@
+(asdf:oos 'asdf:load-op :FiveAM)
+(asdf:oos 'asdf:load-op :qbook)
+
+(asdf:oos 'qbook:publish-op :FiveAM
+          :generator (make-instance 'qbook:html-generator
+                                    :title "FiveAM"
+                                    :output-directory
+                                    (merge-pathnames
+                                        (make-pathname :directory '(:relative "docs" "html"))
+                                        (asdf:component-pathname (asdf:find-system :FiveAM)))))
+
+          
+

Added: trunk/thirdparty/fiveam/fiveam.asd
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/fiveam.asd	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,34 @@
+;; -*- lisp -*-
+
+(defpackage :it.bese.FiveAM.system
+  (:use :common-lisp
+        :asdf))
+
+(in-package :it.bese.FiveAM.system)
+
+(defsystem :FiveAM
+    :author "Edward Marco Baringer <mb at bese.it>"
+    :properties ((:test-suite-name . :it.bese.fiveam))
+    :components ((:static-file "fiveam.asd")
+                 (:module :src
+                  :components ((:file "check" :depends-on ("packages"))
+			       (:file "classes" :depends-on ("packages"))
+			       (:file "explain" :depends-on ("classes" "packages" "check"))
+			       (:file "fixture" :depends-on ("packages"))
+			       (:file "packages")
+			       (:file "run" :depends-on ("packages" "classes" "test" "suite" "check"))
+			       (:file "suite" :depends-on ("packages" "test" "classes"))
+                               (:file "random" :depends-on ("packages" "check"))
+			       (:file "test" :depends-on ("packages" "classes"))))
+		 (:module :t
+		  :components ((:file "suite")
+			       (:file "tests" :depends-on ("suite")))
+		  :depends-on (:src)))
+    :depends-on (:arnesi))
+
+(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :FiveAM))))
+  (funcall (intern (string :run!) (string :it.bese.FiveAM)) :it.bese.FiveAM))
+
+;;;;@include "src/packages.lisp"
+
+;;;;@include "t/example.lisp"

Added: trunk/thirdparty/fiveam/src/check.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/check.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,324 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Checks
+
+;;;; At the lowest level testing the system requires that certain
+;;;; forms be evaluated and that certain post conditions are met: the
+;;;; value returned must satisfy a certain predicate, the form must
+;;;; (or must not) signal a certain condition, etc. In FiveAM these
+;;;; low level operations are called 'checks' and are defined using
+;;;; the various checking macros.
+
+;;;; Checks are the basic operators for collecting results. Tests and
+;;;; test suites on the other hand allow grouping multiple checks into
+;;;; logic collections.
+
+(defvar *test-dribble* t)
+
+(defmacro with-*test-dribble* (stream &body body)
+  `(let ((*test-dribble* ,stream))
+     (declare (special *test-dribble*))
+     , at body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-special-environment run-state ()
+    result-list
+    current-test))
+
+;;;; ** Types of test results
+
+;;;; Every check produces a result object. 
+
+(defclass test-result ()
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "All checking macros will generate an object of
+ type TEST-RESULT."))
+
+(defclass test-passed (test-result)
+  ()
+  (:documentation "Class for successful checks."))
+
+(defgeneric test-passed-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-passed)) t))
+
+(define-condition check-failure (error)
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "Signaled when a check fails.")
+  (:report  (lambda (c stream)
+              (format stream "The following check failed: ~S~%~A."
+                      (test-expr c)
+                      (reason c)))))
+
+(defmacro process-failure (&rest args)
+  `(progn
+    (with-simple-restart (ignore-failure "Continue the test run.")
+      (error 'check-failure , at args))
+    (add-result 'test-failure , at args)))
+
+(defclass test-failure (test-result)
+  ()
+  (:documentation "Class for unsuccessful checks."))
+
+(defgeneric test-failure-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-failure)) t))
+
+(defclass unexpected-test-failure (test-failure)
+  ((actual-condition :accessor actual-condition :initarg :condition))
+  (:documentation "Represents the result of a test which neither
+passed nor failed, but signaled an error we couldn't deal
+with.
+
+Note: This is very different than a SIGNALS check which instead
+creates a TEST-PASSED or TEST-FAILURE object."))
+
+(defclass test-skipped (test-result)
+  ()
+  (:documentation "A test which was not run. Usually this is due
+to unsatisfied dependencies, but users can decide to skip test
+when appropiate."))
+
+(defgeneric test-skipped-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-skipped)) t))
+
+(defun add-result (result-type &rest make-instance-args)
+  "Create a TEST-RESULT object of type RESULT-TYPE passing it the
+  initialize args MAKE-INSTANCE-ARGS and adds the resulting
+  object to the list of test results."
+  (with-run-state (result-list current-test)
+    (let ((result (apply #'make-instance result-type
+                         (append make-instance-args (list :test-case current-test)))))
+      (etypecase result
+	(test-passed  (format *test-dribble* "."))
+        (unexpected-test-failure (format *test-dribble* "X"))
+	(test-failure (format *test-dribble* "f"))
+	(test-skipped (format *test-dribble* "s")))
+      (push result result-list))))
+
+;;;; ** The check operators
+
+;;;; *** The IS check
+
+(defmacro is (test &rest reason-args)
+  "The DWIM checking operator.
+
+If TEST returns a true value a test-passed result is generated,
+otherwise a test-failure result is generated. The reason, unless
+REASON-ARGS is provided, is generated based on the form of TEST:
+
+ (predicate expected actual) - Means that we want to check
+ whether, according to PREDICATE, the ACTUAL value is
+ in fact what we EXPECTED.
+
+ (predicate value) - Means that we want to ensure that VALUE
+ satisfies PREDICATE.
+
+ Wrapping the TEST form in a NOT simply preducse a negated reason
+ string."
+  (assert (listp test)
+          (test)
+          "Argument to IS must be a list, not ~S" test)
+  (let (bindings effective-test default-reason-args)
+    (with-unique-names (e a v)
+      (flet ((process-entry (predicate expected actual &optional negatedp)
+               ;; make sure EXPECTED is holding the entry that starts with 'values
+               (when (and (consp actual)
+                          (eq (car actual) 'values))
+                 (assert (not (and (consp expected)
+                                   (eq (car expected) 'values))) ()
+                                   "Both the expected and actual part is a values expression.")
+                 (let ((tmp expected))
+                   (setf expected actual
+                         actual tmp)))
+               (let ((setf-forms))
+                 (if (and (consp expected)
+                          (eq (car expected) 'values))
+                     (progn
+                       (setf expected (copy-list expected))
+                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+                                              for i from 0
+                                              while cell
+                                              when (eq (car cell) '*)
+                                              collect `(setf (elt ,a ,i) nil)
+                                              and do (setf (car cell) nil)))
+                       (setf bindings (list (list e `(list ,@(rest expected)))
+                                            (list a `(multiple-value-list ,actual)))))
+                     (setf bindings (list (list e expected)
+                                          (list a actual))))
+                 (setf effective-test `(progn
+                                        , at setf-forms
+                                        ,(if negatedp
+                                             `(not (,predicate ,e ,a))
+                                             `(,predicate ,e ,a)))))))
+        (list-match-case test
+          ((not (?predicate ?expected ?actual))
+           (process-entry ?predicate ?expected ?actual t)
+           (setf default-reason-args
+                 (list "~S evaluated to ~S, which is ~S to ~S (it should not be)"
+                       `',?actual a `',?predicate e)))
+          ((not (?satisfies ?value))
+           (setf bindings (list (list v ?value))
+                 effective-test `(not (,?satisfies ,v))
+                 default-reason-args
+                 (list "~S evaluated to ~S, which satisfies ~S (it should not)"
+                       `',?value v `',?satisfies)))
+          ((?predicate ?expected ?actual)
+           (process-entry ?predicate ?expected ?actual)
+           (setf default-reason-args
+                 (list "~S evaluated to ~S, which is not ~S to ~S."
+                       `',?actual a `',?predicate e)))
+          ((?satisfies ?value)
+           (setf bindings (list (list v ?value))
+                 effective-test `(,?satisfies ,v)
+                 default-reason-args
+                 (list "~S evaluated to ~S, which does not satisfy ~S"
+                       `',?value v `',?satisfies)))
+          (?_
+           (setf bindings '()
+                 effective-test test
+                 default-reason-args (list "~S was NIL." `',test)))))
+      `(let ,bindings
+         (if ,effective-test
+             (add-result 'test-passed :test-expr ',test)
+             (process-failure :reason (format nil ,@(or reason-args default-reason-args))
+                              :test-expr ',test))))))
+
+;;;; *** Other checks
+
+(defmacro skip (&rest reason)
+  "Generates a TEST-SKIPPED result."
+  `(progn
+     (format *test-dribble* "s")
+     (add-result 'test-skipped :reason (format nil , at reason))))
+
+(defmacro is-every (predicate &body clauses)
+  "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+   for each pair of elements or (is (,predicate ,expr ,value) , at reason) for each list."
+  `(progn
+    ,@(if (every #'consp clauses)
+          (loop for (expected actual . reason) in clauses
+                collect `(is (,predicate ,expected ,actual) , at reason))
+          (progn
+            (assert (evenp (list-length clauses)))
+            (loop for (expr value) on clauses by #'cddr
+                  collect `(is (,predicate ,expr ,value)))))))
+
+(defmacro is-true (condition &rest reason-args)
+  "Like IS this check generates a pass if CONDITION returns true
+  and a failure if CONDITION returns false. Unlike IS this check
+  does not inspect CONDITION to determine how to report the
+  failure."
+  `(if ,condition
+    (add-result 'test-passed :test-expr ',condition)
+    (process-failure
+     :reason ,(if reason-args
+                  `(format nil , at reason-args)
+                  `(format nil "~S did not return a true value" ',condition))
+     :test-expr ',condition)))
+
+(defmacro is-false (condition &rest reason-args)
+  "Generates a pass if CONDITION returns false, generates a
+  failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
+  not inspect CONDITION to determine what reason to give it case
+  of test failure"
+  
+  (with-unique-names (value)
+    `(let ((,value ,condition))
+       (if ,value
+           (process-failure
+            :reason ,(if reason-args
+                         `(format nil , at reason-args)
+                         `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
+            :test-expr ',condition)
+           (add-result 'test-passed :test-expr ',condition)))))
+
+(defmacro signals (condition-spec
+                   &body body)
+  "Generates a pass if BODY signals a condition of type
+CONDITION. BODY is evaluated in a block named NIL, CONDITION is
+not evaluated."
+  (let ((block-name (gensym)))
+    (destructuring-bind (condition &optional reason-control reason-args)
+        (ensure-list condition-spec)
+      `(block ,block-name
+         (handler-bind ((,condition (lambda (c)
+                                      (declare (ignore c))
+                                      ;; ok, body threw condition
+                                      (add-result 'test-passed 
+                                                  :test-expr ',condition)
+                                      (return-from ,block-name t))))
+           (block nil
+             , at body))
+         (process-failure
+          :reason ,(if reason-control
+                       `(format nil ,reason-control , at reason-args)
+                       `(format nil "Failed to signal a ~S" ',condition))
+          :test-expr ',condition)
+         (return-from ,block-name nil)))))
+
+(defmacro finishes (&body body)
+  "Generates a pass if BODY executes to normal completion. In
+other words if body does signal, return-from or throw this test
+fails."
+  `(let ((ok nil))
+     (unwind-protect
+	 (progn 
+	   , at body
+	   (setf ok t))
+       (if ok
+	   (add-result 'test-passed :test-expr ',body)
+           (process-failure
+            :reason (format nil "Test didn't finish")
+            :test-expr ',body)))))
+
+(defmacro pass (&rest message-args)
+  "Simply generate a PASS."
+  `(add-result 'test-passed 
+               :test-expr ',message-args
+               ,@(when message-args
+                       `(:reason (format nil , at message-args)))))
+
+(defmacro fail (&rest message-args)
+  "Simply generate a FAIL."
+  `(process-failure
+    :test-expr ',message-args
+    ,@(when message-args
+            `(:reason (format nil , at message-args)))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

Added: trunk/thirdparty/fiveam/src/classes.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/classes.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,128 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+(defclass testable-object ()
+  ((name :initarg :name :accessor name 
+	 :documentation "A symbol naming this test object.")
+   (description :initarg :description :accessor description :initform nil
+		:documentation "The textual description of this test object.")
+   (depends-on :initarg :depends-on :accessor depends-on :initform nil
+	       :documentation "The list of AND, OR, NOT forms specifying when to run this test.")
+   (status :initarg :status :accessor status :initform :unknown
+	   :documentation "A symbol specifying the current status
+	   of this test. Either: T - this test (and all its
+	   dependencies, have passed. NIL - this test
+	   failed (either it failed or its dependecies weren't
+	   met. :circular this test has a circular dependency
+	   and was skipped. Or :depends-not-satisfied or :resolving")
+   (profiling-info :accessor profiling-info
+                   :initform nil
+                   :documentation "An object representing how
+                   much time and memory where used by the
+                   test.")
+   (collect-profiling-info :accessor collect-profiling-info
+                           :initarg :collect-profiling-info
+                           :initform nil
+                           :documentation "When T profiling
+                           information will be collected when the
+                           test is run.")))
+
+(defmethod print-object ((test testable-object) stream)
+  (print-unreadable-object (test stream :type t :identity t)
+    (format stream "~S" (name test))))
+
+(defclass test-suite (testable-object)
+  ((tests :accessor tests :initform (make-hash-table :test 'eql)
+	  :documentation "The hash table mapping names to test
+	  objects in this suite. The values in this hash table
+	  can be either test-cases or other test-suites."))
+  (:documentation "A test suite is a collection of tests or test suites.
+
+Test suites serve to organize tests into groups so that the
+developer can chose to run some tests and not just one or
+all. Like tests test suites have a name and a description.
+
+Test suites, like tests, can be part of other test suites, this
+allows the developer to create a hierarchy of tests where sub
+trees can be singularly run.
+
+Running a test suite has the effect of running every test (or
+suite) in the suite."))
+
+(defclass test-case (testable-object)
+  ((test-lambda :initarg :test-lambda :accessor test-lambda
+		:documentation "The function to run.")
+   (runtime-package :initarg :runtime-package :accessor runtime-package
+                    :documentation "By default it stores *package* from the time this test was defined (macroexpanded)."))
+  (:documentation "A test case is a single, named, collection of
+checks.
+
+A test case is the smallest organizational element which can be
+run individually. Every test case has a name, which is a symbol,
+a description and a test lambda. The test lambda is a regular
+funcall'able function which should use the various checking
+macros to collect results.
+
+Every test case is part of a suite, when a suite is not
+explicitly specified (either via the :SUITE parameter to the TEST
+macro or the global variable *SUITE*) the test is inserted into
+the global suite named NIL.
+
+Sometimes we want to run a certain test only if another test has
+passed. FiveAM allows us to specify the ways in which one test is
+dependent on another.
+
+- AND Run this test only if all the named tests passed.
+
+- OR Run this test if at least one of the named tests passed.
+
+- NOT Run this test only if another test has failed.
+
+FiveAM considers a test to have passed if all the checks executed
+were successful, otherwise we consider the test a failure.
+
+When a test is not run due to it's dependencies having failed a
+test-skipped result is added to the results."))
+
+(defclass explainer ()
+  ())
+
+(defclass text-explainer (explainer)
+  ())
+
+(defclass simple-text-explainer (text-explainer)
+  ())
+
+(defclass detailed-text-explainer (text-explainer)
+  ())
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

Added: trunk/thirdparty/fiveam/src/explain.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/explain.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,131 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Analyzing the results
+
+(defparameter *verbose-failures* nil
+  "T if we should print the expression failing, NIL otherwise.")
+
+;;;; Just as important as defining and runnig the tests is
+;;;; understanding the results. FiveAM provides the function EXPLAIN
+;;;; which prints a human readable summary (number passed, number
+;;;; failed, what failed and why, etc.) of a list of test results.
+
+(defmethod explain ((exp detailed-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  #| "Given a list of test results report write to stream detailed
+  human readable statistics regarding the results." |# 
+  (multiple-value-bind (num-checks passed num-passed passed%
+				   skipped num-skipped skipped%
+				   failed num-failed failed%
+				   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed))
+    (flet ((output (&rest format-args)
+             (format stream "~&~vT" recursive-depth)
+             (apply #'format stream format-args)))
+      
+      (when (zerop num-checks)
+        (output "Didn't run anything...huh?")
+        (return-from explain nil))
+      (output "Did ~D check~P.~%" num-checks num-checks)
+      (output "   Pass: ~D (~2D%)~%" num-passed passed%)
+      (output "   Skip: ~D (~2D%)~%" num-skipped skipped%)
+      (output "   Fail: ~D (~2D%)~%" num-failed failed%)
+      (when unknown
+        (output "   UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%))
+      (terpri stream)
+      (when failed
+        (output "Failure Details:~%")
+        (dolist (f (reverse failed))
+          (output "--------------------------------~%")
+          (output "~A ~@{[~A]~}: ~%" 
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "     ~A.~%" (reason f))
+          (when (for-all-test-failed-p f)
+            (output "Results collected with failure data:~%")
+            (explain exp (slot-value f 'result-list)
+                     stream (+ 4 recursive-depth)))
+          (when (and *verbose-failures* (test-expr f))
+            (output "    ~S~%" (test-expr f)))
+          (output "--------------------------------~%"))
+        (terpri stream))
+      (when skipped
+        (output "Skip Details:~%")
+        (dolist (f skipped)
+          (output "~A ~@{[~A]~}: ~%" 
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "    ~A.~%" (reason f)))
+        (terpri *test-dribble*)))))
+
+(defmethod explain ((exp simple-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  (multiple-value-bind (num-checks passed num-passed passed%
+				   skipped num-skipped skipped%
+				   failed num-failed failed%
+				   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%))
+    (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed)
+    (when (plusp num-skipped)
+      (format stream ", ~D skipped " num-skipped))
+    (format stream " and ~D failed.~%" num-failed)
+    (when (plusp num-unknown)
+      (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown))))
+
+(defun partition-results (results-list)
+  (let ((num-checks (length results-list)))
+    (destructuring-bind (passed skipped failed unknown)
+	(partitionx results-list
+		    (lambda (res)
+		      (typep res 'test-passed))
+		    (lambda (res)
+		      (typep res 'test-skipped))
+		    (lambda (res)
+		      (typep res 'test-failure))
+		    t)
+      (if (zerop num-checks)
+	  (values 0
+		  nil 0 0
+		  nil 0 0
+		  nil 0 0
+		  nil 0 0)
+	  (values
+	   num-checks
+	   passed (length passed) (floor (* 100 (/ (length passed) num-checks)))
+	   skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks)))
+	   failed (length failed) (floor (* 100 (/ (length failed) num-checks)))
+	   unknown (length unknown) (floor (* 100 (/ (length failed) num-checks))))))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

Added: trunk/thirdparty/fiveam/src/fixture.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/fixture.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,71 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; ** Fixtures
+
+;;;; When running tests we often need to setup some kind of context
+;;;; (create dummy db connections, simulate an http request,
+;;;; etc.). Fixtures provide a way to conviently hide this context
+;;;; into a macro and allow the test to focus on testing.
+
+;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term
+;;;; 'fixture' is so common in testing frameworks we've provided a
+;;;; wrapper around defmacro for this purpose.
+
+(deflookup-table fixture
+  :documentation "Lookup table mapping fixture names to fixture
+  objects.")
+
+(defmacro def-fixture (name args &body body)
+  "Defines a fixture named NAME. A fixture is very much like a
+macro but is used only for simple templating. A fixture created
+with DEF-FIXTURE is a macro which can use the special macrolet
+&BODY to specify where the body should go.
+
+See Also: WITH-FIXTURE
+"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (get-fixture ',name) (cons ',args ',body))
+     ',name))
+
+(defmacro with-fixture (fixture-name args &body body)
+  "Insert BODY into the fixture named FIXTURE-NAME.
+
+See Also: DEF-FIXTURE"
+  (assert (get-fixture fixture-name)
+          (fixture-name)
+          "Unknown fixture ~S." fixture-name)
+  (destructuring-bind (largs &rest lbody) (get-fixture fixture-name)
+    `(macrolet ((&body () '(progn , at body)))
+       (funcall (lambda ,largs , at lbody) , at args))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: trunk/thirdparty/fiveam/src/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/packages.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,130 @@
+;; -*- lisp -*-
+
+;;;; * Introduction
+
+;;;; FiveAM is a testing framework. It takes care of all the boring
+;;;; bookkeeping associated with managing a test framework allowing
+;;;; the developer to focus on writing tests and code.
+
+;;;; FiveAM was designed with the following premises:
+
+;;;; - Defining tests should be about writing tests, not
+;;;; infrastructure. The developer should be able to focus on what
+;;;; they're testing, not the testing framework.
+
+;;;; - Interactive testing is the norm. Common Lisp is an interactive
+;;;; development environment, the testing environment should allow the
+;;;; developer to quickly and easily redefine, change, remove and run
+;;;; tests.
+
+(defpackage :it.bese.FiveAM
+  (:use :common-lisp :it.bese.arnesi)
+  (:nicknames :5am :fiveam)
+  (:export ;; creating tests and test-suites
+           #:make-suite
+	   #:def-suite
+	   #:in-suite
+	   #:in-suite*
+	   #:make-test
+	   #:test
+	   #:get-test
+	   #:rem-test
+           #:test-names
+	   ;; fixtures
+	   #:make-fixture
+	   #:def-fixture
+	   #:with-fixture
+	   #:get-fixture
+	   #:rem-fixture
+	   ;; running checks
+           #:is
+           #:is-every
+           #:is-true
+           #:is-false
+           #:signals
+           #:finishes
+           #:skip
+	   #:pass
+	   #:fail
+	   #:*test-dribble*
+           #:for-all
+           #:gen-integer
+           #:gen-float
+           #:gen-character
+           #:gen-string
+           #:gen-list
+           #:gen-tree
+           #:gen-buffer
+           #:gen-one-element
+	   ;; running tests
+           #:run
+           #:run-all-tests
+           #:explain
+           #:explain!
+           #:run!
+           #:debug!
+           #:!
+           #:!!
+           #:!!!
+           #:*run-test-when-defined*
+	   #:*debug-on-error*
+           #:*debug-on-failure*
+           #:*verbose-failures*
+           #:results-status))
+
+;;;; You can use #+5am to put your test-defining code inline with your
+;;;; other code - and not require people to have fiveam to run your
+;;;; package.
+
+(pushnew :5am *features*)
+
+;;;;@include "check.lisp"
+
+;;;;@include "random.lisp"
+
+;;;;@include "fixture.lisp"
+
+;;;;@include "test.lisp"
+
+;;;;@include "suite.lisp"
+
+;;;;@include "run.lisp"
+
+;;;;@include "explain.lisp"
+
+;;;; * Colophon
+
+;;;; This documentaion was written by Edward Marco Baringer
+;;;; <mb at bese.it> and generated by qbook.
+
+;;;; ** COPYRIGHT
+
+;;;; Copyright (c) 2002-2003, Edward Marco Baringer
+;;;; All rights reserved. 
+ 
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+ 
+;;;;  - Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+ 
+;;;;  - Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer in the
+;;;;    documentation and/or other materials provided with the distribution.
+
+;;;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;;;    of its contributors may be used to endorse or promote products
+;;;;    derived from this software without specific prior written permission.
+ 
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

Added: trunk/thirdparty/fiveam/src/random.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/random.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,265 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; ** Random (QuickCheck-ish) testing
+
+;;;; FiveAM provides the ability to automatically generate a
+;;;; collection of random input data for a specific test and run a
+;;;; test multiple times.
+
+;;;; Specification testing is done through the FOR-ALL macro. This
+;;;; macro will bind variables to random data and run a test body a
+;;;; certain number of times. Should the test body ever signal a
+;;;; failure we stop running and report what values of the variables
+;;;; caused the code to fail.
+
+;;;; The generation of the random data is done using "generator
+;;;; functions" (see below for details). A generator function is a
+;;;; function which creates, based on user supplied parameters, a
+;;;; function which returns random data. In order to facilitate
+;;;; generating good random data the FOR-ALL macro also supports guard
+;;;; conditions and creating one random input based on the values of
+;;;; another (see the FOR-ALL macro for details).
+
+;;;; *** Public Interface to the Random Tester
+
+(defparameter *num-trials* 100
+  "Number of times we attempt to run the body of the FOR-ALL test.")
+
+(defparameter *max-trials* 10000
+  "Number of total times we attempt to run the body of the
+  FOR-ALL test including when the body is skipped due to failed
+  guard conditions.
+
+Since we have guard conditions we may get into infinite loops
+where the test code is never run due to the guards never
+returning true. This second run limit prevents that.")
+
+(defmacro for-all (bindings &body body)
+  "Bind BINDINGS to random variables and test BODY *num-trials* times.
+
+BINDINGS is a list of binding forms, each element is a list
+of (BINDING VALUE &optional GUARD). Value, which is evaluated
+once when the for-all is evaluated, must return a generator which
+be called each time BODY is evaluated. BINDING is either a symbol
+or a list which will be passed to destructuring-bind. GUARD is a
+form which, if present, stops BODY from executing when IT returns
+NIL. The GUARDS are evaluated after all the random data has been
+generated and they can refer to the current value of any
+binding. NB: Generator forms, unlike guard forms, can not contain
+references to the boud variables.
+
+Examples:
+
+  (for-all ((a (gen-integer)))
+    (is (integerp a)))
+
+  (for-all ((a (gen-integer) (plusp a)))
+    (is (integerp a))
+    (is (plusp a)))
+
+  (for-all ((less (gen-integer))
+            (more (gen-integer) (< less more)))
+    (is (<= less more)))
+
+  (for-all (((a b) (gen-two-integers)))
+    (is (integerp a))
+    (is (integerp b)))"
+  (with-unique-names (test-lambda-args)
+    `(perform-random-testing
+      (list ,@(mapcar #'second bindings))
+      (lambda (,test-lambda-args)
+        (destructuring-bind ,(mapcar #'first bindings)
+            ,test-lambda-args
+          (if (and ,@(delete-if #'null (mapcar #'third bindings)))
+              (progn , at body)
+              (throw 'run-once
+                (list :guard-conditions-failed))))))))
+
+;;;; *** Implementation 
+
+;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be
+;;;; a preproccessor for the perform-random-testing function is
+;;;; actually much easier.
+
+(defun perform-random-testing (generators body)
+  (loop
+     with random-state = *random-state*
+     with total-counter = *max-trials*
+     with counter = *num-trials*
+     with run-at-least-once = nil
+     until (or (zerop total-counter)
+               (zerop counter))
+     do (let ((result (perform-random-testing/run-once generators body)))
+          (ecase (first result)
+            (:pass
+             (decf counter)
+             (decf total-counter)
+             (setf run-at-least-once t))
+            (:no-tests
+             (add-result 'for-all-test-no-tests
+                         :reason "No tests"
+                         :random-state random-state)
+             (return-from perform-random-testing nil))
+            (:guard-conditions-failed
+             (decf total-counter))
+            (:fail
+             (add-result 'for-all-test-failed
+                         :reason "Found failing test data"
+                         :random-state random-state
+                         :failure-values (second result)
+                         :result-list (third result))
+             (return-from perform-random-testing nil))))
+     finally (if run-at-least-once
+                 (add-result 'for-all-test-passed)
+                 (add-result 'for-all-test-never-run
+                             :reason "Guard conditions never passed"))))
+
+(defun perform-random-testing/run-once (generators body)
+  (catch 'run-once
+    (bind-run-state ((result-list '()))
+      (let ((values (mapcar #'funcall generators)))
+        (funcall body values)
+        (cond
+          ((null result-list)
+           (throw 'run-once (list :no-tests)))
+          ((every #'test-passed-p result-list)
+           (throw 'run-once (list :pass)))
+          ((notevery #'test-passed-p result-list)
+           (throw 'run-once (list :fail values result-list))))))))
+
+(defclass for-all-test-result ()
+  ((random-state :initarg :random-state)))
+
+(defclass for-all-test-passed (test-passed for-all-test-result)
+  ())
+
+(defclass for-all-test-failed (test-failure for-all-test-result)
+  ((failure-values :initarg :failure-values)
+   (result-list :initarg :result-list)))
+
+(defgeneric for-all-test-failed-p (object)
+  (:method ((object for-all-test-failed)) t)
+  (:method ((object t)) nil))
+
+(defmethod reason ((result for-all-test-failed))
+  (format nil "Falsafiable with ~S" (slot-value result 'failure-values)))
+
+(defclass for-all-test-no-tests (test-failure for-all-test-result)
+  ())
+
+(defclass for-all-test-never-run (test-failure for-all-test-result)
+  ())
+
+;;;; *** Generators
+
+;;;; Since this is random testing we need some way of creating random
+;;;; data to feed to our code. Generators are regular functions which
+;;;; create this random data.
+
+;;;; We provide a set of built-in generators.
+
+(defun gen-integer (&key (max (1+ most-positive-fixnum))
+                         (min (1- most-negative-fixnum)))
+  "Returns a generator which produces random integers greater
+than or equal to MIN and less than or equal to MIN."
+  (lambda ()
+    (+ min (random (1+ (- max min))))))
+
+(defun gen-float (&key bound (type 'short-float))
+  "Returns a generator which producs floats of type TYPE. BOUND,
+if specified, constrains the ruselts to be in the range (-BOUND,
+BOUND)."
+  (lambda ()
+    (let* ((most-negative (ecase type
+                            (short-float most-negative-short-float)
+                            (single-float most-negative-single-float)
+                            (double-float most-negative-double-float)
+                            (long-float most-negative-long-float)))
+           (most-positive (ecase type
+                            (short-float most-positive-short-float)
+                            (single-float most-positive-single-float)
+                            (double-float most-positive-double-float)
+                            (long-float most-positive-long-float)))
+           (bound (or bound (max most-positive (- most-negative)))))
+      (coerce 
+       (ecase (random 2)
+         (0 ;; generate a positive number
+          (random (min most-positive bound)))
+         (1 ;; generate a negative number
+          (- (random (min (- most-negative) bound)))))
+       type))))
+
+(defun gen-character (&key (code-limit char-code-limit)
+                           (code (gen-integer :min 0 :max (1- code-limit)))
+                           (alphanumericp nil))
+  "Returns a generator of characters.
+
+CODE must be a generator of random integers. ALPHANUMERICP, if
+non-NIL, limits the returned chars to those which pass
+alphanumericp."
+  (lambda ()
+    (if alphanumericp            
+        (loop
+           for count upfrom 0
+           for char = (code-char (funcall code))
+           until (alphanumericp char)
+           when (= 1000 count)
+             do (error "After 1000 iterations ~S has still not generated an alphanumeric character :(."
+                       code)
+           finally (return char))
+        (code-char (funcall code)))))
+
+(defun gen-string (&key (length (gen-integer :min 0 :max 80))
+                        (elements (gen-character))
+                        (element-type 'character))
+  "Returns a generator which producs random strings. LENGTH must
+be a generator which producs integers, ELEMENTS must be a
+generator which produces characters of type ELEMENT-TYPE."
+  (lambda ()
+    (loop
+       with length = (funcall length)
+       with string = (make-string length :element-type element-type)
+       for index below length
+       do (setf (aref string index) (funcall elements))
+       finally (return string))))
+
+(defun gen-list (&key (length (gen-integer :min 0 :max 10))
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which producs random lists. LENGTH must be
+an integer generator and ELEMENTS must be a generator which
+producs objects."
+  (lambda ()
+    (loop
+       repeat (funcall length)
+       collect (funcall elements))))
+
+(defun gen-tree (&key (size 20)
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which producs random trees. SIZE control
+the approximate size of the tree, but don't try anything above
+ 30, you have been warned. ELEMENTS must be a generator which
+will produce the elements."
+  (labels ((rec (&optional (current-depth 0))
+             (let ((key (random (+ 3 (- size current-depth)))))
+               (cond ((> key 2)
+                      (list (rec (+ current-depth 1))
+                            (rec (+ current-depth 1))))
+                     (t (funcall elements))))))
+    (lambda ()
+      (rec))))
+
+(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
+                        (element-type '(unsigned-byte 8))
+                        (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
+  (lambda ()
+    (let ((buffer (make-array (funcall length) :element-type element-type)))
+      (map-into buffer elements))))
+
+(defun gen-one-element (&rest elements)
+  (lambda ()
+    (nth (random (length elements)) elements)))
+
+;;;; The trivial always-produce-the-same-thing generator is done using
+;;;; cl:constantly.

Added: trunk/thirdparty/fiveam/src/run.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/run.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,288 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Running Tests
+
+;;;; Once the programmer has defined what the tests are these need to
+;;;; be run and the expected effects should be compared with the
+;;;; actual effects. FiveAM provides the function RUN for this
+;;;; purpose, RUN executes a number of tests and collects the results
+;;;; of each individual check into a list which is then
+;;;; returned. There are three types of test results: passed, failed
+;;;; and skipped, these are represented by TEST-RESULT objects.
+
+;;;; Generally running a test will return normally, but there are two
+;;;; exceptional situations which can occur:
+
+;;;; - An exception is signaled while running the test. If the
+;;;;   variable *debug-on-error* is T than FiveAM will enter the
+;;;;   debugger, otherwise a test failure (of type
+;;;;   unexpected-test-failure) is returned. When entering the
+;;;;   debugger two restarts are made available, one simply reruns the
+;;;;   current test and another signals a test-failure and continues
+;;;;   with the remaining tests.
+
+;;;; - A circular dependency is detected. An error is signaled and a
+;;;;   restart is made available which signals a test-skipped and
+;;;;   continues with the remaining tests. This restart also sets the
+;;;;   dependency status of the test to nil, so any tests which depend
+;;;;   on this one (even if the dependency is not circular) will be
+;;;;   skipped.
+
+;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
+;;;; RUN and EXPLAIN.
+
+(defparameter *debug-on-error* nil
+  "T if we should drop into a debugger on error, NIL otherwise.")
+
+(defparameter *debug-on-failure* nil
+  "T if we should drop into a debugger on a failing check, NIL otherwise.")
+
+(defun import-testing-symbols (package-designator)
+  (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
+	  package-designator))
+
+(defparameter *run-queue* '()
+  "List of test waiting to be run.")
+
+(define-condition circular-dependency (error)
+  ((test-case :initarg :test-case))
+  (:report (lambda (cd stream)
+             (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case))))
+  (:documentation "Condition signaled when a circular dependency
+between test-cases has been detected."))
+
+(defgeneric run-resolving-dependencies (test)
+  (:documentation "Given a dependency spec determine if the spec
+is satisfied or not, this will generally involve running other
+tests. If the dependency spec can be satisfied the test is alos
+run."))
+
+(defmethod run-resolving-dependencies ((test test-case))
+  "Return true if this test, and its dependencies, are satisfied,
+  NIL otherwise."
+  (case (status test)
+    (:unknown
+     (setf (status test) :resolving)
+     (if (or (not (depends-on test))
+             (eql t (resolve-dependencies (depends-on test))))
+         (progn
+           (run-test-lambda test)
+           (status test))
+         (with-run-state (result-list)
+           (unless (eql :circular (status test))
+             (push (make-instance 'test-skipped
+                                  :test-case test
+                                  :reason "Dependencies not satisfied")
+                   result-list)
+             (setf (status test) :depends-not-satisfied)))))         
+    (:resolving
+     (restart-case
+         (error 'circular-dependency :test-case test)
+       (skip ()
+	 :report (lambda (s)
+		   (format s "Skip the test ~S and all its dependencies." (name test)))
+	 (with-run-state (result-list)
+	   (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
+		 result-list))
+	 (setf (status test) :circular))))
+    (t (status test))))
+
+(defmethod resolve-dependencies ((depends-on symbol))
+  "A test which depends on a symbol is interpreted as `(AND
+  ,DEPENDS-ON)."
+  (run-resolving-dependencies (get-test depends-on)))
+
+(defmethod resolve-dependencies ((depends-on list))
+  "Return true if the dependency spec DEPENDS-ON is satisfied,
+  nil otherwise."
+  (if (null depends-on)
+      t
+      (flet ((satisfies-depends-p (test)
+	       (funcall test (lambda (dep)
+			       (eql t (resolve-dependencies dep)))
+			     (cdr depends-on))))
+	(ecase (car depends-on)
+	  (and (satisfies-depends-p #'every))
+	  (or  (satisfies-depends-p #'some))
+	  (not (satisfies-depends-p #'notany))
+          (:before (every #'(lambda (dep)
+                              (let ((status (status (get-test dep))))
+                                (eql :unknown status)))
+                         (cdr depends-on)))))))
+
+(defun results-status (result-list)
+  "Given a list of test results (generated while running a test)
+  return true if all of the results are of type TEST-PASSED,
+  faile otherwise."
+  (every (lambda (res)
+	   (typep res 'test-passed))
+	 result-list))
+
+(defun return-result-list (test-lambda)
+  "Run the test function TEST-LAMBDA and return a list of all
+  test results generated, does not modify the special environment
+  variable RESULT-LIST."
+  (bind-run-state ((result-list '())) 
+    (funcall test-lambda)
+    result-list))
+
+(defmethod run-test-lambda ((test test-case))
+  (with-run-state (result-list)
+    (bind-run-state ((current-test test))
+      (labels ((abort-test (e)
+                 (add-result 'unexpected-test-failure
+                             :test-expr nil
+                             :test-case test
+                             :reason (format nil "Unexpected Error: ~S~%~A." e e)
+                             :condition e))
+               (run-it ()
+                 (let ((result-list '()))
+                   (declare (special result-list))
+                   (handler-bind ((check-failure (lambda (e)
+                                                   (declare (ignore e))
+                                                   (unless *debug-on-failure*
+                                                     (invoke-restart
+                                                      (find-restart 'ignore-failure)))))
+                                  (error (lambda (e)
+                                           (unless (or *debug-on-error*
+                                                       (typep e 'check-failure))
+                                             (abort-test e)
+                                             (return-from run-it result-list)))))
+                     (restart-case
+                         (let ((*readtable* (copy-readtable))
+                               (*package* (runtime-package test)))
+                           (if (collect-profiling-info test)
+                               (setf (profiling-info test)
+                                     (arnesi:collect-timing (test-lambda test)))
+                               (funcall (test-lambda test))))
+                       (retest ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Rerun the test ~S~@:>" test))
+                         (return-from run-it (run-it)))
+                       (ignore ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+                         (abort-test (make-instance 'test-failure :test-case test
+                                                    :reason "Failure restart."))))
+                     result-list))))
+        (let ((results (run-it)))
+          (setf (status test) (results-status results)
+                result-list (nconc result-list results)))))))
+
+(defgeneric %run (test-spec)
+  (:documentation "Internal method for running a test. Does not
+  update the status of the tests nor the special vairables !,
+  !!, !!!"))
+
+(defmethod %run ((test test-case))
+  (run-resolving-dependencies test))
+
+(defmethod %run ((tests list))
+  (mapc #'%run tests))
+
+(defmethod %run ((suite test-suite))
+  (let ((suite-results '()))
+    (flet ((run-tests ()
+             (loop
+                for test being the hash-values of (tests suite)
+                do (%run test))))
+      (unwind-protect
+           (bind-run-state ((result-list '()))
+             (unwind-protect
+                  (if (collect-profiling-info suite)
+                      (setf (profiling-info suite) (collect-timing #'run-tests))
+                      (run-tests)))
+             (setf suite-results result-list
+                   (status suite) (every (lambda (res)
+                                           (typep res 'test-passed))
+                                         suite-results)))
+        (with-run-state (result-list)
+          (setf result-list (nconc result-list suite-results)))))))
+
+(defmethod %run ((test-name symbol))
+  (when-bind test (get-test test-name)
+    (%run test)))
+
+(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
+
+(defvar *!* *initial-!*)
+(defvar *!!* *initial-!*)
+(defvar *!!!* *initial-!*)
+
+;;;; ** Public entry points
+
+(defun run! (&optional (test-spec *suite*))
+  "Equivalent to (explain (run TEST-SPEC))."
+  (explain! (run test-spec)))
+
+(defun explain! (result-list)
+  "Explain the results of RESULT-LIST using a
+detailed-text-explainer with output going to *test-dribble*"
+  (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*))
+
+(defun debug! (&optional (test-spec *suite*))
+  "Calls (run! test-spec) but enters the debugger if any kind of error happens."
+  (let ((*debug-on-error* t)
+        (*debug-on-failure* t))
+    (run! test-spec)))
+
+(defun run (test-spec)
+  "Run the test specified by TEST-SPEC.
+
+TEST-SPEC can be either a symbol naming a test or test suite, or
+a testable-object object. This function changes the operations
+performed by the !, !! and !!! functions."
+  (psetf *!* (lambda ()
+               (loop for test being the hash-keys of *test*
+                     do (setf (status (get-test test)) :unknown))
+               (bind-run-state ((result-list '()))
+                 (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
+                   (%run test-spec))
+                 result-list))
+         *!!* *!*
+         *!!!* *!!*)
+  (funcall *!*))
+
+(defun ! () 
+  "Rerun the most recently run test and explain the results."
+  (explain! (funcall *!*)))
+
+(defun !! () 
+  "Rerun the second most recently run test and explain the results."
+  (explain! (funcall *!!*)))
+  
+(defun !!! ()
+  "Rerun the third most recently run test and explain the results."
+  (explain! (funcall *!!!*)))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: trunk/thirdparty/fiveam/src/style.css
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/style.css	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,64 @@
+body {
+  background-color: #FFFFFF;
+  color: #000000;
+  padding: 0px; margin: 0px;
+}
+
+.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; 
+         border-left: 3em solid #660000; padding: 3px; }
+
+h1 { text-align: center; margin: 0px;
+     color: #333333; 
+     border-bottom: 0.3em solid #660000; 
+}
+
+p { padding-left: 1em; }
+
+h2 { border-bottom: 0.2em solid #000000; font-family: verdana; }
+
+h3 { border-bottom: 0.1em solid #000000; }
+
+pre.code {
+	background-color: #eeeeee;
+	border: solid 1px #d0d0d0;
+        overflow: auto;
+}
+
+pre.code * .paren { color: #666666; } 
+
+pre.code a:active  { color: #000000; }
+pre.code a:link    { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+div.contents { font-family: verdana; }
+
+div.contents a:active  { color: #000000; }
+div.contents a:link    { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active  { color: #660000; }
+div.contents div.contents-heading-1 a:link    { color: #660000; }
+div.contents div.contents-heading-1 a:visited { color: #660000; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active  { color: #660000; }
+div.contents div.contents-heading-2 a:link    { color: #660000; }
+div.contents div.contents-heading-2 a:visited { color: #660000; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active  { color: #660000; }
+div.contents div.contents-heading-3 a:link    { color: #660000; }
+div.contents div.contents-heading-3 a:visited { color: #660000; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active  { color: #660000; }
+div.contents div.contents-heading-4 a:link    { color: #660000; }
+div.contents div.contents-heading-4 a:visited { color: #660000; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active  { color: #660000; }
+div.contents div.contents-heading-5 a:link    { color: #660000; }
+div.contents div.contents-heading-5 a:visited { color: #660000; }

Added: trunk/thirdparty/fiveam/src/suite.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/suite.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,115 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Test Suites
+
+;;;; Test suites allow us to collect multiple tests into a single
+;;;; object and run them all using asingle name. Test suites do not
+;;;; affect the way test are run nor the way the results are handled,
+;;;; they are simply a test organizing group.
+
+;;;; Test suites can contain both tests and other test suites. Running
+;;;; a test suite causes all of its tests and test suites to be
+;;;; run. Suites do not affect test dependencies, running a test suite
+;;;; can cause tests which are not in the suite to be run.
+
+;;;; ** Creating Suits
+
+(defmacro def-suite (name &key description in)
+  "Define a new test-suite named NAME.
+
+IN (a symbol), if provided, causes this suite te be nested in the
+suite named by IN. NB: This macro is built on top of make-suite,
+as such it, like make-suite, will overrwrite any existing suite
+named NAME."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (make-suite ',name
+                 ,@(when description `(:description ,description))
+                 ,@(when in `(:in ',in)))
+     ',name))
+
+(defmacro def-suite* (name &rest def-suite-args)
+  `(progn
+     (def-suite ,name , at def-suite-args)
+     (in-suite ,name)))
+
+(defun make-suite (name &key description in)
+  "Create a new test suite object.
+
+Overides any existing suite named NAME."
+  (let ((suite (make-instance 'test-suite :name name)))
+    (when description
+      (setf (description suite) description))
+    (loop for i in (ensure-list in)
+	  for in-suite = (get-test i)
+	  do (progn
+	       (when (null in-suite)
+		 (cerror "Create a new suite named ~A." "Unknown suite ~A." i)
+		 (setf (get-test in-suite) (make-suite i)
+		       in-suite (get-test in-suite)))
+	       (setf (gethash name (tests in-suite)) suite)))
+    (setf (get-test name) suite)
+    suite))
+
+;;;; ** Managing the Current Suite
+
+(defvar *suite* (setf (get-test 'NIL)
+		      (make-suite 'NIL :description "Global Suite"))
+  "The current test suite object")
+
+(defmacro in-suite (suite-name)
+  "Set the *suite* special variable so that all tests defined
+after the execution of this form are, unless specified otherwise,
+in the test-suite named SUITE-NAME.
+
+See also: DEF-SUITE *SUITE*"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%in-suite ,suite-name)))
+
+(defmacro in-suite* (suite-name &key in)
+  "Just like in-suite, but silently creates missing suites."
+  `(%in-suite ,suite-name :in ,in :fail-on-error nil))
+
+(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+  (with-unique-names (suite)
+    `(progn
+       (if-bind ,suite (get-test ',suite-name)
+           (setf *suite* ,suite)
+	   (progn
+	     (when ,fail-on-error
+               (cerror "Create a new suite named ~A."
+                       "Unkown suite ~A." ',suite-name))
+	     (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in)
+		   *suite* (get-test ',suite-name))))
+       ',suite-name)))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

Added: trunk/thirdparty/fiveam/src/test.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/test.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,122 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Tests
+
+;;;; While executing checks and collecting the results is the core job
+;;;; of a testing framework it is also important to be able to
+;;;; organize checks into groups, FiveAM provides two mechanisms for
+;;;; organizing checks: tests and test suites. A test is a named
+;;;; collection of checks which can be run and a test suite is a named
+;;;; collection of tests and test suites.
+
+(deflookup-table test
+  :at-redefinition nil
+  :documentation "Lookup table mapping test (and test suite)
+  names to objects.")
+
+(defun test-names ()
+  (loop for test being the hash-keys of *test*
+        collect test))
+
+(defmacro test (name &body body)
+  "Create a test named NAME. If NAME is a list it must be of the
+form:
+
+  (name &key depends-on suite fixture compile-at profile)
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixtrue to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (let* ((tmp (gensym))
+         (suite-arg (getf (cdr (ensure-list name)) :suite tmp))
+         (suite-form (cond
+                       ((eq tmp suite-arg) '*suite*)
+                       (t                  `(get-test ',suite-arg)))))
+    (when (consp name)
+      (remf (cdr name) :suite))
+    (destructuring-bind (name &key depends-on (compile-at :run-time) fixture profile)
+        (ensure-list name)
+      (declare (type (member :run-time :definition-time) compile-at))
+      (let ((description (if (stringp (car body))
+                             (pop body)
+                             ""))
+            (effective-body (if fixture
+                                (destructuring-bind (name &rest args)
+                                    (ensure-list fixture)
+                                  `((with-fixture ,name ,args , at body)))
+                                body)))
+        `(progn
+           (setf (get-test ',name) (make-instance 'test-case
+                                                  :name ',name
+                                                  :runtime-package
+                                                  #-ecl ,*package*
+                                                  #+ecl (find-package ,(package-name *package*))
+                                                  :test-lambda
+                                                  (lambda ()
+                                                    ,@ (ecase compile-at
+                                                         (:run-time `((funcall
+                                                                       (let ((*package* (find-package ',(package-name *package*))))
+                                                                         (compile nil '(lambda ()
+                                                                                        , at effective-body))))))
+                                                         (:definition-time effective-body)))
+                                                  :description ,description
+                                                  :depends-on ',depends-on
+                                                  :collect-profiling-info ,profile))
+           (setf (gethash ',name (tests ,suite-form)) ',name)
+           (when *run-test-when-defined*
+             (run! ',name))
+           ',name)))))
+
+(defvar *run-test-when-defined* nil
+  "When non-NIL tests are run as soon as they are defined.")
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved. 
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;; 
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 
+;;  - Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: trunk/thirdparty/fiveam/t/example.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/example.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,126 @@
+;; -*- lisp -*-
+
+;;;; * FiveAM Example (poor man's tutorial)
+
+(asdf:oos 'asdf:load-op :FiveAM)
+
+(defpackage :it.bese.FiveAM.example
+  (:use :common-lisp
+	:it.bese.FiveAM))
+
+(in-package :it.bese.FiveAM.example)
+
+;;;; First we need some functions to test.
+
+(defun add-2 (n)
+  (+ n 2))
+
+(defun add-4 (n) 
+  (+ n 4))
+
+;;;; Now we need to create a test which makes sure that add-2 and add-4
+;;;; work as specified.
+
+;;;; we create a test named ADD-2 and supply a short description.
+(test add-2
+ "Test the ADD-2 function" ;; a short description
+ ;; the checks
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2))))
+
+;;;; we can already run add-2. This will return the list of test
+;;;; results, it should be a list of two test-passed objects.
+
+(run 'add-2) 
+
+;;;; since we'd like to have some kind of readbale output we'll explain
+;;;; the results
+
+(explain! (run 'add-2))
+
+;;;; or we could do both at once:
+
+(run! 'add-2)
+
+;;;; So now we've defined and run a single test. Since we plan on
+;;;; having more than one test and we'd like to run them together let's
+;;;; create a simple test suite.
+
+(def-suite example-suite :description "The example test suite.")
+
+;;;; we could explictly specify that every test we create is in the the
+;;;; example-suite suite, but it's easier to just change the default
+;;;; suite:
+
+(in-suite example-suite)
+
+;;;; now we'll create a new test for the add-4 function.
+
+(test add-4
+  (is (= 0 (add-4 -4))))
+
+;;;; now let's run the test
+
+(run! 'add-4)
+
+;;;; we can get the same effect by running the suite:
+
+(run! 'example-suite)
+
+;;;; since we'd like both add-2 and add-4 to be in the same suite, let's
+;;;; redefine add-2 to be in this suite:
+
+(test add-2 "Test the ADD-2 function"
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2))))
+
+;;;; now we can run the suite and we'll see that both add-2 and add-4
+;;;; have been run (we know this since we no get 4 checks as opposed to
+;;;; 2 as before.
+
+(run! 'example-suite)
+
+;;;; Just for fun let's see what happens when a test fails. Again we'll
+;;;; redefine add-2, but add in a third, failing, check:
+
+(test add-2 "Test the ADD-2 function"
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2)))
+ (is (= 0 (add-2 0))))
+
+;;;; Finally let's try out the specification based testing.
+
+(defun dummy-add (a b)
+  (+ a b))
+
+(defun dummy-strcat (a b)
+  (concatenate 'string a b))
+
+(test dummy-add
+  (for-all ((a (gen-integer))
+            (b (gen-integer)))
+    ;; assuming we have an "oracle" to compare our function results to
+    ;; we can use it:
+    (is (= (+ a b) (dummy-add a b)))
+    ;; if we don't have an oracle (as in most cases) we just ensure
+    ;; that certain properties hold:
+    (is (= (dummy-add a b)
+           (dummy-add b a)))
+    (is (= a (dummy-add a 0)))
+    (is (= 0 (dummy-add a (- a))))
+    (is (< a (dummy-add a 1)))
+    (is (= (* 2 a) (dummy-add a a)))))
+
+(test dummy-strcat
+  (for-all ((result (gen-string))
+            (split-point (gen-integer :min 0 :max 10000)
+                         (< split-point (length result))))
+    (is (string= result (dummy-strcat (subseq result 0 split-point)
+                                      (subseq result split-point))))))
+
+(test random-failure
+  (for-all ((result (gen-integer :min 0 :max 1)))
+    (is (plusp result))
+    (is (= result 0))))
+
+(run! 'example-suite)

Added: trunk/thirdparty/fiveam/t/suite.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/suite.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,9 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.fiveam)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (get-test :it.bese)
+    (def-suite :it.bese)))
+
+(def-suite :it.bese.fiveam :in :it.bese)

Added: trunk/thirdparty/fiveam/t/tests.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/tests.lisp	Mon Feb 18 08:55:20 2008
@@ -0,0 +1,256 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+(in-suite :it.bese.FiveAM)
+
+(def-suite test-suite :description "Suite for tests which should fail.")
+
+(defmacro with-test-results ((results test-name) &body body)
+  `(let ((,results (with-*test-dribble* nil (run ',test-name))))
+     , at body))
+
+(def-fixture null-fixture ()
+  `(progn ,@(&body)))
+
+;;;; Test the checks
+
+(test (is1 :suite test-suite)
+  (is (plusp 1))
+  (is (< 0 1))
+  (is (not (plusp -1)))
+  (is (not (< 1 0)))
+  (is-true t)
+  (is-false nil))
+
+(test (is2 :suite test-suite :fixture null-fixture)
+  (is (plusp 0))
+  (is (< 0 -1))
+  (is (not (plusp 1)))
+  (is (not (< 0 1)))
+  (is-true nil)
+  (is-false t))
+
+(test (is :profile t)
+  (with-test-results (results is1)
+    (is (= 6 (length results)))
+    (is (every #'test-passed-p results)))
+  (with-test-results (results is2)
+    (is (= 6 (length results)))
+    (is (every #'test-failure-p results))))
+
+(test signals/finishes
+  (signals error
+    (error "an error"))
+  (finishes
+   (signals error
+    (error "an error"))))
+
+(test pass
+  (pass))
+
+(test (fail1 :suite test-suite)
+  (fail "This is supposed to fail"))
+
+(test fail
+  (with-test-results (results fail1)
+    (is (= 1 (length results)))
+    (is (test-failure-p (first results)))))
+
+;;;; non top level checks
+
+(test foo-bar
+  (let ((state 0))
+    (is (= 0 state))
+    (is (= 1 (incf state)))))
+
+;;;; Test dependencies
+
+(test (ok :suite test-suite)
+  (pass))
+
+(test (not-ok :suite test-suite)
+  (fail "This is supposed to fail."))
+
+(test (and1 :depends-on (and ok not-ok) :suite test-suite)
+  (fail))
+
+(test (and2 :depends-on (and ok) :suite test-suite)
+  (pass))
+
+(test dep-and 
+  (with-test-results (results and1)
+    (is (= 3 (length results)))
+    ;; we should have one skippedw one failed and one passed
+    (is (some #'test-passed-p results))
+    (is (some #'test-skipped-p results))
+    (is (some #'test-failure-p results)))
+  (with-test-results (results and2)
+    (is (= 2 (length results)))
+    (is (every #'test-passed-p results))))
+
+(test (or1 :depends-on (or ok not-ok) :suite test-suite)
+  (pass))
+
+(test (or2 :depends-on (or not-ok ok) :suite test-suite)
+  (pass))
+
+(test dep-or
+  (with-test-results (results or1)
+    (is (= 2 (length results)))
+    (is (every #'test-passed-p results)))
+  (with-test-results (results or2)
+    (is (= 3 (length results)))
+    (is (= 2 (length (remove-if-not #'test-passed-p results))))))
+
+(test (not1 :depends-on (not not-ok) :suite test-suite)
+  (pass))
+
+(test (not2 :depends-on (not ok) :suite test-suite)
+  (fail))
+
+(test not
+  (with-test-results (results not1)
+    (is (= 2 (length results)))
+    (is (some #'test-passed-p results))
+    (is (some #'test-failure-p results)))
+  (with-test-results (results not2)
+    (is (= 2 (length results)))
+    (is (some #'test-passed-p results))
+    (is (some #'test-skipped-p results))))
+
+(test (nested-logic :depends-on (and ok (not not-ok) (not not-ok))
+                    :suite test-suite)
+  (pass))
+
+(test dep-nested
+  (with-test-results (results nested-logic)
+    (is (= 3 (length results)))
+    (is (= 2 (length (remove-if-not #'test-passed-p results))))
+    (is (= 1 (length (remove-if-not #'test-failure-p results))))))
+
+(test (circular-0 :depends-on (and circular-1 circular-2 or1) 
+                  :suite test-suite)
+  (fail "we depend on a circular dependency, we should not be tested."))
+
+(test (circular-1 :depends-on (and circular-2)
+                  :suite test-suite)
+  (fail "we have a circular depednency, we should not be tested."))
+
+(test (circular-2 :depends-on (and circular-1)
+                  :suite test-suite)
+  (fail "we have a circular depednency, we should not be tested."))
+
+(test circular
+  (signals circular-dependency
+    (run 'circular-0))
+  (signals circular-dependency
+    (run 'circular-1))
+  (signals circular-dependency
+    (run 'circular-2)))
+
+
+(def-suite before-test-suite :description "Suite for before test")
+
+(test (before-0 :suite before-test-suite)
+  (pass))
+
+(test (before-1 :depends-on (:before before-0)
+                :suite before-test-suite)
+  (fail))
+
+(def-suite before-test-suite-2 :description "Suite for before test")
+
+(test (before-2 :depends-on (:before before-3)
+                :suite before-test-suite-2)
+  (pass))
+
+(test (before-3 :suite before-test-suite-2)
+  (pass))
+
+(test before
+  (with-test-results (results before-test-suite)
+    (is (some #'test-skipped-p results)))
+  
+  (with-test-results (results before-test-suite-2)
+    (is (every #'test-passed-p results))))
+
+
+;;;; dependencies with symbol
+(test (dep-with-symbol-first :suite test-suite)
+  (pass))
+
+(test (dep-with-symbol-dependencies-not-met :depends-on (not dep-with-symbol-first)
+                                            :suite test-suite)
+  (fail "Error in the test of the test, this should not ever happen"))
+
+(test (dep-with-symbol-depends-on-ok :depends-on dep-with-symbol-first :suite test-suite)
+  (pass))
+
+(test (dep-with-symbol-depends-on-failed-dependency :depends-on dep-with-symbol-dependencies-not-met
+                                                    :suite test-suite)
+  (fail "No, I should not be tested becuase I depend on a test that in its turn has a failed dependecy."))
+
+(test dependencies-with-symbol
+  (with-test-results (results dep-with-symbol-first)
+    (is (some #'test-passed-p results)))
+
+  (with-test-results (results dep-with-symbol-depends-on-ok)
+    (is (some #'test-passed-p results)))
+
+  (with-test-results (results dep-with-symbol-dependencies-not-met)
+    (is (some #'test-skipped-p results)))
+
+  ;; No failure here, because it means the test was run.
+  (with-test-results (results dep-with-symbol-depends-on-failed-dependency)
+    (is (not (some #'test-failure-p results)))))
+
+
+;;;; test for-all
+
+(test gen-integer
+  (for-all ((a (gen-integer)))
+    (is (integerp a))))
+
+(test for-all-guarded
+  (for-all ((less (gen-integer))
+            (more (gen-integer) (< less more)))
+    (is (< less more))))
+
+(test gen-float
+  (macrolet ((test-gen-float (type)
+               `(for-all ((unbounded (gen-float :type ',type))
+                          (bounded   (gen-float :type ',type :bound 42)))
+                  (is (typep unbounded ',type))
+                  (is (typep bounded ',type))
+                  (is (<= (abs bounded) 42)))))
+    (test-gen-float single-float)
+    (test-gen-float short-float)
+    (test-gen-float double-float)
+    (test-gen-float long-float)))
+
+(test gen-character
+  (for-all ((c (gen-character)))
+    (is (characterp c)))
+  (for-all ((c (gen-character :code (gen-integer :min 32 :max 40))))
+    (is (characterp c))
+    (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\())))
+
+(test gen-string
+  (for-all ((s (gen-string)))
+    (is (stringp s)))
+  (for-all ((s (gen-string :length (gen-integer :min 0 :max 2))))
+    (is (<= (length s) 2)))
+  (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0))
+                           :length (constantly 2))))
+    (is (= 2 (length s)))
+    (is (every (curry #'char= #\Null) s))))
+
+(defun dummy-mv-generator ()
+  (lambda ()
+    (list 1 1)))
+
+(test for-all-destructuring-bind
+  (for-all (((a b) (dummy-mv-generator)))
+    (is (= 1 a))
+    (is (= 1 b))))


From hhubner at common-lisp.net  Mon Feb 18 14:04:48 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 09:04:48 -0500 (EST)
Subject: [bknr-cvs] r2551 - trunk/thirdparty/hunchentoot-0.15.0
Message-ID: <20080218140448.9A78C490A1@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 09:04:48 2008
New Revision: 2551

Modified:
   trunk/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
Log:
Do not use acl-compat, as it breaks CCL when loaded.


Modified: trunk/thirdparty/hunchentoot-0.15.0/hunchentoot.asd
==============================================================================
--- trunk/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	(original)
+++ trunk/thirdparty/hunchentoot-0.15.0/hunchentoot.asd	Mon Feb 18 09:04:48 2008
@@ -51,7 +51,6 @@
                :rfc2388
                #+:sbcl :sb-bsd-sockets
                #+:sbcl :sb-posix
-               #+:openmcl :acl-compat
                :url-rewrite)
   :components ((:file "packages")
                (:file "conditions")


From hhubner at common-lisp.net  Mon Feb 18 14:13:30 2008
From: hhubner at common-lisp.net (hhubner at common-lisp.net)
Date: Mon, 18 Feb 2008 09:13:30 -0500 (EST)
Subject: [bknr-cvs] r2552 - trunk/thirdparty/acl-compat
Message-ID: <20080218141330.9456A5C17D@common-lisp.net>

Author: hhubner
Date: Mon Feb 18 09:13:30 2008
New Revision: 2552

Removed:
   trunk/thirdparty/acl-compat/
Log:
Delete the dreaded acl-compat package.  It is required only so that
Hunchentoot can implement WITH-TIMETOUT, which is a terrible thing in
itself.



From ksprotte at common-lisp.net  Mon Feb 18 14:26:59 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 09:26:59 -0500 (EST)
Subject: [bknr-cvs] r2553 - in trunk: bknr/datastore/src
	bknr/datastore/src/data thirdparty/fiveam/src
Message-ID: <20080218142659.BB69F5E4CF@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 09:26:57 2008
New Revision: 2553

Added:
   trunk/bknr/datastore/src/data/encoding-test.lisp
Modified:
   trunk/bknr/datastore/src/bknr-datastore.asd
   trunk/bknr/datastore/src/data/package.lisp
   trunk/thirdparty/fiveam/src/packages.lisp
Log:
added encoding-test


Modified: trunk/bknr/datastore/src/bknr-datastore.asd
==============================================================================
--- trunk/bknr/datastore/src/bknr-datastore.asd	(original)
+++ trunk/bknr/datastore/src/bknr-datastore.asd	Mon Feb 18 09:26:57 2008
@@ -8,22 +8,31 @@
 (in-package :bknr-datastore.system)
 
 (defsystem :bknr-datastore
-    :name "baikonour datastore"
-    :author "Hans Huebner <hans at huebner.org>"
-    :author "Manuel Odendahl <manuel at bl0rg.net>"
-    :version "0"
-    :maintainer "Manuel Odendahl <manuel at bl0rg.net>"
-    :licence "BSD"
-    :description "baikonour - launchpad for lisp satellites"
+  :name "baikonour datastore"
+  :author "Hans Huebner <hans at huebner.org>"
+  :author "Manuel Odendahl <manuel at bl0rg.net>"
+  :version "0"
+  :maintainer "Manuel Odendahl <manuel at bl0rg.net>"
+  :licence "BSD"
+  :description "baikonour - launchpad for lisp satellites"
 
-    :depends-on (:cl-interpol
-		 :closer-mop
-		 :unit-test
-		 :bknr-utils
-		 :bknr-indices)
+  :depends-on (:cl-interpol
+               :closer-mop
+               :unit-test
+               :bknr-utils
+               :bknr-indices)
 
-    :components ((:module "data" :components ((:file "package")
-					      (:file "encoding" :depends-on ("package"))
-					      (:file "txn" :depends-on ("encoding" "package"))
-					      (:file "object" :depends-on ("txn" "package"))
-                                              (:file "blob" :depends-on ("txn" "object" "package"))))))
+  :components ((:module "data" :components ((:file "package")
+                                            (:file "encoding" :depends-on ("package"))
+                                            (:file "txn" :depends-on ("encoding" "package"))
+                                            (:file "object" :depends-on ("txn" "package"))
+                                            (:file "blob" :depends-on ("txn" "object" "package"))))))
+
+(defsystem :bknr-datastore-test  
+  :depends-on (:bknr-datastore :FiveAM)
+  :components ((:module "data" :components ((:file "encoding-test")
+                                            ))))
+
+(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :bknr-datastore))))
+  (asdf:oos 'asdf:load-op :bknr-datastore-test)
+  (funcall (intern (string :run!) (string :it.bese.FiveAM)) :bknr.datastore))

Added: trunk/bknr/datastore/src/data/encoding-test.lisp
==============================================================================
--- (empty file)
+++ trunk/bknr/datastore/src/data/encoding-test.lisp	Mon Feb 18 09:26:57 2008
@@ -0,0 +1,8 @@
+(in-package :bknr.datastore)
+
+(test:def-suite :bknr.datastore.encoding :in :bknr.datastore)
+(test:in-suite :bknr.datastore.encoding)
+
+(test:test dummy
+  (test:is (= 1 2)))
+

Modified: trunk/bknr/datastore/src/data/package.lisp
==============================================================================
--- trunk/bknr/datastore/src/data/package.lisp	(original)
+++ trunk/bknr/datastore/src/data/package.lisp	Mon Feb 18 09:26:57 2008
@@ -106,3 +106,5 @@
 	   #:blob-subsystem
 
 	   #:find-refs))
+
+

Modified: trunk/thirdparty/fiveam/src/packages.lisp
==============================================================================
--- trunk/thirdparty/fiveam/src/packages.lisp	(original)
+++ trunk/thirdparty/fiveam/src/packages.lisp	Mon Feb 18 09:26:57 2008
@@ -19,7 +19,7 @@
 
 (defpackage :it.bese.FiveAM
   (:use :common-lisp :it.bese.arnesi)
-  (:nicknames :5am :fiveam)
+  (:nicknames :5am :fiveam :test)
   (:export ;; creating tests and test-suites
            #:make-suite
 	   #:def-suite


From ksprotte at common-lisp.net  Mon Feb 18 14:40:21 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 09:40:21 -0500 (EST)
Subject: [bknr-cvs] r2554 - in trunk/thirdparty/cl-store_0.8.4: . abcl acl
	allegrocl clisp cmucl doc ecl lispworks mcl openmcl sbcl
Message-ID: <20080218144021.9927344144@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 09:40:18 2008
New Revision: 2554

Added:
   trunk/thirdparty/cl-store_0.8.4/
   trunk/thirdparty/cl-store_0.8.4/ChangeLog   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/abcl/
   trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/acl/
   trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/allegrocl/
   trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/backends.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/circularities.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/cl-store.asd   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/clisp/
   trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/cmucl/
   trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/default-backend.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/doc/
   trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/doc/index.html   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/doc/style.css   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/ecl/
   trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/licence   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/lispworks/
   trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/mcl/
   trunk/thirdparty/cl-store_0.8.4/openmcl/
   trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/package.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/plumbing.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/readme   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/sbcl/
   trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/sysdef.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/tests.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/utils.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/xml-package.lisp   (contents, props changed)
   trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp   (contents, props changed)
Log:
added cl-store


Added: trunk/thirdparty/cl-store_0.8.4/ChangeLog
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/ChangeLog	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,391 @@
+2007-11-23 Sean Ross <sross at common-lisp.net>
+	0.8.3
+	* abcl/mop.lisp: MOP support for ABCL. Thanks to szergling.
+	* clisp/custom.lisp: Custom Closure serialization for CLISP. Thanks to szergling.
+	Functions are no longer reliably serializable between implementations.
+	* tests.lisp: New function tests for CLISP.
+	
+2007-10-30 Sean Ross <sross at common-lisp.net>
+	* cl-store.asd: Release 0.8
+	
+2007-09-09 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp: be lenient when parsing parts of sbcls version string. Thanks to Gustavo.
+
+2007-01-26 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp : Checked in a fix for non sb32 integers, certain 
+	large number numbers where incorrectly serialize. 
+	Reported by Cyrus Harmon.
+	* plumbing.lisp: Added a new function alias-backend and alias the backend
+	'cl-store:cl-store as :cl-store
+	
+	
+2007-01-23 Sean Ross <sross at common-lisp.net>
+	* circularities.lisp: Renamed with-grouped-serialization to with-serialization-unit
+	and added two keyword args to allow removal of *grouped-restore-hash* and 
+	*grouped-store-hash* special vars as exported symbols.
+	* default-backend.lisp: Changed defvars of register-types to defparameters.
+
+2007-01-22 Sean Ross <sross at common-lisp.net>
+	* utils.lisp, circularities.lisp, tests.lisp 
+	* stop store-32-bit from creating an intermediary object
+	which reduces the consing (on at least Lispworks 5.0 and SBCL 'Kitten of Death').
+	* export 4 new symbols which allows more efficient serialization of values.	
+	create-serialize-hash, with-grouped-serialization, *grouped-store-hash*
+	and *grouped-restore-hash*.
+	* conditionalize some forms which were preventing ABCL from running the tests.
+	
+	
+2006-12-16 Sean Ross <sross at common-lisp.net>
+	* circularities.lisp: Bug fix from Alex Mizrahi. Change *restored-values*
+	to use eql as the hash test. 
+
+2006-12-16 Sean Ross <sross at common-lisp.net>
+	* cl-store.asd, utils.lisp : Added preliminary support for ABCL (tested on 
+	version 0.0.9).
+
+2006-12-13 Sean Ross <sross at common-lisp.net>
+	* utils.lisp, acl/custom.lisp, cmucl/custom.lisp, lispworks/custom.lisp
+	sbcl/custom/lisp, default-backend.lisp, cl-store.asd: 
+	Committed handling for serialization of float types short, single, double and
+	long and handling of positive infinity, negative infinity and NaN for all
+	float types (this is still only for sbcl, cmucl, acl, and lispworks).
+
+2006-12-11 Sean Ross <sross at common-lisp.net>
+	* lispworks/custom.lisp: Began work on new special float creation.
+	* .cvsignore : Update ignorable files
+
+2006-10-01 Sean Ross <sross at common-lisp.net>
+	* utils.lisp: Fix mkstr to upcase args.
+
+2006-08-03 Sean Ross <sross at common-lisp.net>
+	* lispworks/custom.lisp: Fix float handling for Lispworks 5.0 .
+	* utils.lisp: changed references to compute-slots to class-slots.
+	* package.lisp: Removed symbols from export list that are no 
+	longer used.
+
+2006-03-13 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp: Fixed sbcl structure definition
+	storing for versions >= 0.9.6.25 .
+	
+2006-03-13 Sean Ross <sross at common-lisp.net>
+	* utils.lisp, tests.lisp, openmcl/custom.lisp: Added
+	support for structure object storing for OpenMCL.
+	Thanks to Kilian Sprotte for the code.
+	* default-backend.lisp, utils.lisp: Changed creation
+	of class initargs to use loop instead of mappend.
+	Removed mappend.
+	
+2005-11-30 Sean Ross <sross at common-lisp.net>
+	* package.lisp: Added imports for MCL (from Gary King)
+	* backends.lisp: Changed definition of the defstore-? and
+	defrestore-? macros to work with lispworks dspecs.
+	* default-backend.lisp: Fixed the *sbcl-readtable* to copy
+	the default readtable.
+	* plumbing.lisp: Changed cl-store-error to extend directly from error
+	and removed error from restore-error and store-error's precedence list.
+	 
+2005-10-06 Sean Ross <sross at common-lisp.net>
+	* backends.lisp: Fixed type definition for 
+	compatible-magic-numbers from integer to list.
+	Reported by Bryan O'Connor.
+	
+2005-10-04 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp: sb-kernel:instance is no
+	longer a class (since 0.9.5.3 or so). Fixed
+	definition of *sbcl-struct-inherits* to work 
+	with or without this class. 
+	Reported by Rafa? Strzali?ski.
+	
+2005-09-20 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Changed storing and restoring
+	of standard-object to not create unnecessary garbage.
+	
+2005-09-09 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Altered list serialization to store 
+	all types of lists (proper, dotted and circular) in N time,
+	thanks to Alain Picard for parts of the code.
+
+2005-09-01 Sean Ross <sross at common-lisp.net>
+    Version 0.6 Release.
+	* cl-store.asd, package.lisp: Added support for the new release
+	of CLISP with a MOP.
+	* default-backend.lisp: Fixed storing of long lists.
+	 (Reported by and help by Alain Picard)
+	* default-backend.lisp: New magic number, due to the
+	change in approach of storing lists, although previous
+	files can still be restored.
+	
+2005-05-18 Sean Ross <sross at common-lisp.net>
+	* utils.lisp: Removed awhen
+	* backends.lisp: Added a compatible-magic-numbers slot.
+	* default-backend.lisp: misc cleanups.
+	New magic number (can still restore previous versions files).
+	
+2005-05-06 Sean Ross <sross at common-lisp.net>
+	* backends.lisp: Added optional errorp argument
+	to find-backend (default false).
+	* default-backend.lisp: Changed simple-string storing
+	to keep the upgraded-array-element-type of the 
+	restored string the same as the string which was stored.
+	This seems to give a performance boost (more in memory usage) 
+	with SBCL and Lispworks.
+	* circularities.lisp: Stopped binding *stored-values*  
+	and *restored-values* when circularity checking is inhibited.
+	* doc/cl-store.texi: Miscellaneous fixes.
+	
+2005-05-05 Sean Ross <sross at common-lisp.net>
+	* all: After much experimentation with Lispworks I
+	discovered that globally declaiming unsafe code is
+	not a good idea. Changed to per function declarations.
+	* default-backend.lisp: Removed lispworks unicode string
+	test as it was incorrect.
+	
+2005-03-24 Sean Ross <sross at common-lisp.net>
+	* backends.lisp, circularities.lisp, tests.lisp:
+	Added test gensym.2 which crashed in previous
+	versions (pre 0.5.7). Symbols are now tested 
+	for eq-ality when storing. 
+	int-sym-or-char-p renamed to int-or-char-p.
+	* plumbing.lisp: Added error to the superclasses
+	of restore-error and store-error.
+	
+2005-03-23 Sean Ross <sross at common-lisp.net>
+	* backends.lisp: Fix up for type specifications
+	for the old-magic-numbers and stream-type slots
+	for class backend, reported by Kilian Sprotte.
+	* circularities.lisp: Changed *store-hash-size* and
+	*restore-hash-size* to more reasonable values (50).
+	
+2005-03-17 Sean Ross <sross at common-lisp.net>
+	* doc/cl-store.texi: Fixed up to work properly with makeinfo.
+	
+2005-03-15 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp, utils.lisp: Changed reference
+	to array-dimension-limit in array storing to 
+	array-total-size limit.
+	* default-backend.lisp: Added an implementation specific 
+	test to determine whether or not a string contains unicode
+	characters.
+	
+2005-02-26 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Fixed internal-store-object
+	for the hash-table class (argument order was messed).
+	
+2005-02-18 Sean Ross <sross at common-lisp.net>
+   Version 0.5 Release.
+	* utils.lisp, package.lisp: Took a lesson from the MOP
+	and changed serializable-slots to call the new GF 
+	serializable-slots-using-class.
+	
+2005-02-17 Sean Ross <sross at common-lisp.net>
+	* package.lisp, utils.lisp, default-backend.lisp: Patch 
+	from Thomas Stenhaug which changed get-slot-details to 
+	a generic-function so that it can be customized.
+	Added serializable-slots (returns a list of slot-definitions)
+	which can be overridden to customize which slots are
+	serialized when storing clos instances.
+	
+2005-02-16 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp, package.lisp, plumbing.lisp: Patch
+	from Thomas Stenhaug which adds more comprehensive package
+	storing.
+	
+2005-02-14 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Applied patch from Thomas Stenhaug
+	to default null superclasses of a restored class to 
+	standard-object as this caused errors in Lispworks.
+	
+2005-02-11 Sean Ross <sross at common-lisp.net>
+	New Magic Number for cl-store-backend.
+	* default-backend.lisp, acl/custom.lisp, lispworks/custom.lisp
+	* sbcl/custom.lisp, cmucl/custom.lisp:
+	Changed storing of floats to be compatible between implementations
+	while ensuring that NaN floats and friends are still serializable.
+	* backends.lisp, plumbing.lisp:
+	Added concept of backend designators which can be a 
+	symbol (the backend name) or the backend itself. These are 
+	acceptable replacements for a backend object
+	to store, restore and with-backend.
+	Completely changed argument order for generic functions
+	to ensure that backends are the first argument.
+	* ecl/mop.lisp: Added support for ecl.
+	* plumbing.lisp: Removed multiple-value-store (I don't really
+	see the point of it).
+	* backends.lisp: Changed the working of object restoration
+	from functions in a hash-table (restorer-funs of a backend)
+	to generic functions specialized on backend and a symbol,
+	removed find-function-for-type. 
+	* plumbing.lisp: Changed the handling of the stream-type
+	of backends to be any legal type designator since it's 
+	only used when opening files.
+	* backends.lisp: Both defstore-? and defrestore-?
+	can take an optional qualifer argument.
+	
+2005-02-03 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Fixed hash-table restoration,
+	it no longer assumes that the result of hash-table-test
+	is a symbol but treats it as a function designator.
+	* default-backend.lisp: Added various declarations
+	to help improve speed.
+	
+2005-02-01 Sean Ross <sross at common-lisp.net>
+	* various: Large patch which has removed pointless 
+	argument-precedence-order from various gf's, added the 
+	start of support for ecl, renamed fix-clisp.lisp file to 
+	mop.lisp, and changed resolving-object and setting 
+	to use delays allowing get-setf-place and *postfix-setters*
+	to be removed.
+	
+2004-12-02 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp, cmucl/custom.lisp: Changed the evals when restoring
+	structure definitions to (funcall (compile nil ...))
+	* cl-store-xml.asd: Removed
+	* cl-store-xml.noasd: Added (xml-backend is officially nuked).
+	
+2004-11-26 Sean Ross <sross at common-lisp.net>
+	* cmucl/custom.lisp: Custom structure definition storing for CMUCL.
+	* plumbing.lisp: Bind *read-eval* to nil inside store and restore.
+	
+2004-11-24 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: New Magic Number (Breaks backwards compatibility)
+	* cl-store.asd New Version 0.4
+	* default-backend.lisp: Changed symbol storing to be smarter
+	with symbols with no home package.
+	* sbcl/custom.lisp: Support for structure definitions from defstruct.
+	* tests.lisp: Tests for structure definitions.
+	* circularities.lisp: Optimization for referrers and values-object's.
+	Added *store-hash-size* and *restore-hash-size* which can be bound
+	to reduce the calls to rehash which conses like crazy.
+	Added *check-for-circs* which can be bound to nil to stop
+	checking for circularities which reduces consing drastically but objects
+	will not be eq and will hang on circular objects (see README).
+	* default-backend.lisp: New Magic Number ,again.
+	Cater for SB! package names for built-in function names
+	in SBCL.
+	
+2004-11-10 Sean Ross <sross at common-lisp.net>
+	New Version: 0.3.6 New Magic Number (Breaks backwards compatibility)
+	* default-backend.lisp: Storing for functions and generic functions.
+	* tests.lisp: Tests for functions and GF's.
+	* plumbing.lisp, circularities.lisp, default-backend.lisp: 
+	Optimized int-sym-or-char-p.
+	* clisp/fix-clisp.lisp: Added generic-function-name.
+	* package.lisp: Import generic-function-name.
+	* default-backend.lisp: More optimizations for strings and ints.
+		
+2004-11-03 Sean Ross <sross at common-lisp.net>
+	* tests.lisp: Added tests for unicode strings and symbols.
+	* default-backend.lisp: We definitely support unicode now.
+	Added small optimization to stop the size of files from
+	ballooning.
+
+2004-11-01 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Changed storing of sizes of integers
+	and strings from store-32-bit to store-object. Changed all
+	instances of store-32-byte to store-32-bit. 
+	Added a simple function storing method.
+	New Magic Number
+	* docs/cl-store.texi: New documentation.
+	* lispworks/custom.lisp: Custom storing for conditions
+	to ignore class allocated slots. 
+	
+2004-10-21 Sean Ross <sross at common-lisp.net>
+	* package.lisp, acl/custom.lisp: Added support for Allegro CL.
+	
+2004-10-13 Sean Ross <sross at common-lisp.net>
+	* cl-store.asd: New Version (0.3)
+	* circularities.lisp, default-backend.lisp, xml-backend.lisp:
+	Changed referrer representation to a structure.
+	Removed cl-store-referrer package.
+	
+2004-10-12 Sean Ross <sross at common-lisp.net>
+	* lispworks/custom.lisp, lispworks/custom-xml.lisp, default-backend.lisp: 
+	Added support for NaN floats.
+	* tests.lisp: Test NaN floats, Test multiple values.
+	* default-backend.lisp: fix typo which broke clisp support.
+	
+2004-10-11 Sean Ross <sross at common-lisp.net>
+	* default-backend: Added multiple-value-store.
+	* xml-backend: Added support for multiple return values.
+	
+2004-10-07 Sean Ross <sross at common-lisp.net>
+	* circularities.lisp: Added support for multiple return values from
+	functions defined with defrestore-?.
+	
+2004-10-06 Sean Ross <sross at common-lisp.net>
+	* cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend
+	into it's own package files.
+	* xml-backend.lisp, sbcl/custom-xml.lisp, cmucl/custom-xml.lisp, lispworks/custom-xml.lisp:
+	Added support for infinite floats to sbcl, cmucl and lispworks.
+	* xml-backend.lisp, default-backend.lisp:
+	Fixed floating point contagion warning signalled by clisp.
+	* plumbing.lisp: Changed error handing to signal a store-error or restore-error
+	inside a handler-bind and leave the original error unhandled.
+	* docs/: Rudimentary Documentation.
+	
+2004-10-05 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: New Magic number.
+	* backends.lisp: Changed with-backend to take a variable instead of a backend name.
+	* backends.lisp, plumbing.lisp: Added previous magic number field to backends and
+	an appropriate error if an incompatible magic number is read. 
+	* circularities.lisp, plumbing.lisp: Removed check-stream-element-type.
+	* default-backend.lisp: Added a small optimization for 32 byte integers and
+	support for symbols with unicode strings as names. 
+				
+2004-10-04 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp: Custom float storing (supports inifinities).
+	* cmucl/custom.lisp: Custom float storing (supports inifinities).
+	* xml-backend.lisp, tests.xml: Deprecated xml-backend.
+	
+2004-10-01 Sean Ross <sross at common-lisp.net>
+	* lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard.
+	* tests.lisp: Infinite float tests for lispworks.
+	
+2004-09-27 Sean Ross <sross at common-lisp.net>
+	* plumbing.lisp: Slightly nicer error handling (I think).
+	All conditions caught in store and restore are resignalled
+	and rethrown as a store or restore error respectively.
+
+2004-09-01 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing.
+	* cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing.
+	* lispworks/custom.lisp, lispworks/custom-xml.lisp: Custom structure storing
+	for Lispworks from Alain Picard.
+	* test.lisp: Enabled structure tests for Lispworks.
+
+2004-07-29 Sean Ross <sross at common-lisp.net>
+	* cl-store.asd: New version (0.2)
+	* sbcl/sockets.lisp: Removed.
+	* store.lisp: Removed.
+	* backends.lisp: New file for creating backends (Idea from Robert Sedgewick).
+	* circularities.lisp: Much changes, now works properly.
+	* default-backend.lisp: New file contains storing definitions
+	from store.lisp. Changes to simple-string storing, magic-number changed.
+	* plumbing.lisp: New file, framework stuff.
+	* xml-backend.lisp: New file. New backend for writing out Common-Lisp
+	objects in xml format.
+	* tests.lisp : More and more tests.
+	
+2004-06-04 Sean Ross <sross at common-lisp.net>
+	* circularities.lisp: spelling fix.
+	* cl-store.asd: Specialized operation-done-p to stop some errors in asdf.
+	* package.lisp: Imports for openmcl from Robert Sedgewick,
+	Along with extra imports for cmucl.
+
+2004-05-21 Sean Ross <sross at common-lisp.net>
+	* store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp, 
+	* tests.lisp, utils.lisp, cl-store.asd:
+	   Added ability to specify the type code of an object 
+	   when using defstore. Added code to autogenerate the 
+	   accessor methods for CLISP when restoring classes.
+	   EQ floats are now restored correctly.
+	
+2004-05-18 Sean Ross <sross at common-lisp.net>
+	* store.lisp, fix-clisp.lisp, sbcl/sockets.lisp:
+	Added fix for sbcl to use non-blocking IO when working with sockets.
+	Created directory structure and moved fix-clisp
+
+2004-05-17 Sean Ross <sross at common-lisp.net>
+	* store.lisp, fast-io.lisp, circularities.lisp, package.lisp,
+	fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp:
+	Initial import

Added: trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/abcl/mop.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,29 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+(defmacro use-primitive (partial-name)
+  (let* ((pname (symbol-name partial-name))
+         (standard-name (symbolicate "SLOT-DEFINITION-" pname))
+         (primitive (find-symbol
+                     (format nil "%SLOT-DEFINITION-~a" pname)
+                     :system)))
+    `(defmethod ,standard-name (slotdef)
+       (,primitive slotdef))))
+
+(use-primitive name)
+(use-primitive allocation)
+(use-primitive initform)
+(use-primitive initargs)
+(use-primitive readers)
+(use-primitive writers)
+
+(defun class-slots (object)
+  (system:%class-slots object))
+
+;; This doesn't seem to be available in ABCL
+(defmethod slot-definition-type (slotdef)
+  t)
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/acl/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,29 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+(defun setup-special-floats ()
+  (flet ((short-float-values ()
+           (list (cons 'excl::*infinity-single* +short-float-inf+)
+                 (cons 'excl::*negative-infinity-single +short-float-neg-inf+)
+                 (cons 'excl::*nan-single* +short-float-nan+)))
+         (single-float-values ()
+           (list (cons 'excl::*infinity-single* +single-float-inf+)
+                 (cons 'excl::*negative-infinity-single +single-float-neg-inf+)
+                 (cons 'excl::*nan-single* +single-float-nan+)))
+         (double-float-values ()
+           (list (cons 'excl::*infinity-double*+double-float-inf+)
+                 (cons 'excl::*negative-infinity-double* +double-float-neg-inf+)
+                 (cons 'excl::*nan-double* +double-float-nan+)))
+         (long-float-values ()
+           (list (cons 'excl::*infinity-double* +long-float-inf+)
+                 (cons 'excl::*negative-infinity-double* +long-float-neg-inf+)
+                 (cons 'excl::*nan-double* +long-float-nan+))))
+    (setf *special-floats*
+          (append (short-float-values)
+                  (single-float-values)
+                  (double-float-values)
+                  (long-float-values)))))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/allegrocl/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,29 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+(defun setup-special-floats ()
+  (flet ((short-float-values ()
+           (list (cons #.excl::*infinity-single* +short-float-inf+)
+                 (cons #.excl::*negative-infinity-single* +short-float-neg-inf+)
+                 (cons #.excl::*nan-single* +short-float-nan+)))
+         (single-float-values ()
+           (list (cons #.excl::*infinity-single* +single-float-inf+)
+                 (cons #.excl::*negative-infinity-single* +single-float-neg-inf+)
+                 (cons #.excl::*nan-single* +single-float-nan+)))
+         (double-float-values ()
+           (list (cons #.excl::*infinity-double* +double-float-inf+)
+                 (cons #.excl::*negative-infinity-double* +double-float-neg-inf+)
+                 (cons #.excl::*nan-double* +double-float-nan+)))
+         (long-float-values ()
+           (list (cons #.excl::*infinity-double* +long-float-inf+)
+                 (cons #.excl::*negative-infinity-double* +long-float-neg-inf+)
+                 (cons #.excl::*nan-double* +long-float-nan+))))
+    (setf *special-floats*
+          (append (short-float-values)
+                  (single-float-values)
+                  (double-float-values)
+                  (long-float-values)))))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/backends.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/backends.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,166 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; CL-STORE now has a concept of backends.
+;; store and restore now take an optional  backend as an
+;;  argument to do the actual restoring. Examples of use are 
+;; in default-backend.lisp and xml-backend.lisp
+
+(in-package :cl-store)
+
+(defun required-arg (name)
+  (error "~S is a required argument" name))
+
+(defclass backend ()
+  ((name :accessor name :initform "Unknown" :initarg :name :type symbol)
+   (magic-number :accessor magic-number :initarg :magic-number :type integer)
+   (compatible-magic-numbers :accessor compatible-magic-numbers
+                             :initarg :compatible-magic-numbers :type list)
+   (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers
+                      :type list)
+   (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons)
+                :initform (required-arg :stream-type)))
+  (:documentation "Core class which custom backends must extend"))
+
+(deftype backend-designator ()
+  `(or symbol backend))
+
+(defparameter *registered-backends* nil 
+  "An assoc list mapping backend-names to the backend objects")
+
+(defun find-backend (name &optional errorp)
+  (declare (type symbol name))
+  "Return backup called NAME. If there is no such backend NIL is returned 
+if ERRORP is false, otherwise an error is signalled."
+  (or (cdr (assoc name *registered-backends*))
+      (if errorp 
+          (error "Backend named ~S does not exist." name)
+          nil)))
+
+(defun backend-designator->backend (designator)
+  (check-type designator backend-designator)
+  (etypecase designator
+    (symbol (find-backend designator t))
+    (backend designator)))
+
+
+#+lispworks
+(defun get-store-macro (name)
+  "Return the defstore-? macro which will be used by a custom backend"
+  (let ((macro-name (symbolicate 'defstore- name)))
+    `(defmacro ,macro-name ((var type stream &optional qualifier) 
+                            &body body)
+       (with-gensyms (gbackend)
+         `(dspec:def (,',macro-name (,var ,type ,stream))
+            (defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
+              ((,gbackend ,',name) (,var ,type) ,stream)
+              ,(format nil "Definition for storing an object of type ~A with ~
+ backend ~A" type ',name)
+              (declare (ignorable ,gbackend))
+              , at body))))))
+
+#-lispworks
+(defun get-store-macro (name)
+  "Return the defstore-? macro which will be used by a custom backend"
+  (let ((macro-name (symbolicate 'defstore- name)))
+    `(defmacro ,macro-name ((var type stream &optional qualifier) 
+                            &body body)
+       (with-gensyms (gbackend)
+         `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
+              ((,gbackend ,',name) (,var ,type) ,stream)
+              ,(format nil "Definition for storing an object of type ~A with ~
+ backend ~A" type ',name)
+              (declare (ignorable ,gbackend))
+              , at body)))))
+
+#+lispworks
+(defun get-restore-macro (name)
+  "Return the defrestore-? macro which will be used by a custom backend"
+  (let ((macro-name (symbolicate 'defrestore- name)))
+    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
+       (with-gensyms (gbackend gtype)
+         `(dspec:def (,',macro-name (,type ,place))
+            (defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
+              ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
+              (declare (ignorable ,gbackend ,gtype))
+              , at body))))))
+
+#-lispworks
+(defun get-restore-macro (name)
+  "Return the defrestore-? macro which will be used by a custom backend"
+  (let ((macro-name (symbolicate 'defrestore- name)))
+    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
+       (with-gensyms (gbackend gtype)
+         `(defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
+            ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
+            (declare (ignorable ,gbackend ,gtype))
+            , at body)))))
+
+
+(defun register-backend (name class magic-number stream-type old-magic-numbers 
+                              compatible-magic-numbers)
+  (declare (type symbol name))
+  (let ((instance (make-instance class
+                                 :name name
+                                 :magic-number magic-number
+                                 :old-magic-numbers old-magic-numbers
+                                 :compatible-magic-numbers compatible-magic-numbers
+                                 :stream-type  stream-type)))
+    (if (assoc name *registered-backends*)
+        (cerror "Redefine backend" "Backend ~A is already defined." name)
+        (push (cons name instance) *registered-backends*))
+    instance))
+
+(defun alias-backend (old alias)
+  (let ((backend (find-backend old t)))
+    (pushnew (cons alias backend) *registered-backends*
+             :test #'equalp)
+    t))
+
+(defun get-class-form (name fields extends)
+  `(defclass ,name ,extends
+    ,fields
+    (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)."
+                             name))))
+
+
+#+lispworks
+(defun get-dspec-alias-and-parser (name)
+  (let ((store-name (symbolicate 'defstore- name))
+        (restore-name (symbolicate 'defrestore- name)))
+    `( (dspec:define-dspec-alias ,store-name (arglist)
+         `(method cl-store::internal-store-object ,arglist))
+       (dspec:define-form-parser ,store-name (arglist)
+         `(,,store-name ,arglist))
+
+       (dspec:define-dspec-alias ,restore-name (arglist)
+         `(method cl-store::internal-restore-object ,arglist))
+
+       (dspec:define-form-parser ,restore-name (arglist)
+         `(,,restore-name ,arglist)))))
+
+
+(defmacro defbackend (name &key (stream-type ''(unsigned-byte 8))
+                           (magic-number nil) fields (extends '(backend))
+                           (old-magic-numbers nil) (compatible-magic-numbers nil))
+  "Defines a new backend called NAME. Stream type must be either 'char or 'binary. 
+FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will
+be written down stream as verification and checked on restoration.
+EXTENDS is a class to extend, which must be backend or a class which extends
+backend"
+  (assert (symbolp name))
+  `(eval-when (:load-toplevel :execute)
+     (eval-when (:compile-toplevel :load-toplevel :execute)
+       #+lispworks ,@(get-dspec-alias-and-parser name)
+       ,(get-class-form name fields extends)
+       ,(get-store-macro name)
+       ,(get-restore-macro name))
+     (register-backend ',name ',name ,magic-number 
+                       ,stream-type ',old-magic-numbers ',compatible-magic-numbers)))
+
+(defmacro with-backend (backend &body body)
+  "Run BODY with *default-backend* bound to BACKEND"
+  `(let* ((*default-backend* (backend-designator->backend ,backend)))
+    , at body))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/circularities.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/circularities.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,260 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; Defines a special backend type which specializes various methods
+;; in plumbing.lisp to make it nice and easy to 
+;; resolve possible circularities in objects.
+;; Most of the work is done using the resolving-object
+;; macro which knows how to handle an object which 
+;; is a referrer to a previously restored value.
+;; Backends wanting to make use of this should take
+;; a look at default-backend.lisp and xml-backend.lisp
+;; paying special attention to the defbackend form and the 
+;; defrestore definitions for cons, array, simple-vector
+;; array and hash-table.
+;;
+;; As a note this will ignore integers, symbols or characters
+;; as referrer values. It will handle all other EQ number although
+;; software depending on eq numbers are not conforming 
+;; programs according to the Hyperspec(notes in EQ).
+
+(in-package :cl-store)
+
+(defvar *check-for-circs* t)
+
+(defstruct delay 
+  value (completed nil))
+
+(defmacro delay (&rest body)
+  `(make-delay :value #'(lambda () , at body)))
+
+(defun force (delay)
+  (unless (delay-completed delay)
+    (setf (delay-value delay) (funcall (the function (delay-value delay)))
+          (delay-completed delay) t))
+  (delay-value delay))
+
+
+;; The definitions for setting and setting-hash sits in resolving-object.
+(defmacro setting (place get)
+  "Resolve the possible referring object retrieved by GET and 
+  set it into PLACE. Only usable within a resolving-object form."
+  (declare (ignore place get))
+  #+ecl nil
+  #-ecl (error "setting can only be used inside a resolving-object form."))
+
+(defmacro setting-hash (getting-key getting-value)
+  "Insert the value retrieved by GETTING-VALUE with the key 
+  retrieved by GETTING-KEY, resolving possible circularities.
+  Only usable within a resolving-object form."
+  (declare (ignore getting-key getting-value))
+  #+ecl nil
+  #-ecl (error "setting-hash can only be used inside a resolving-object form."))
+
+(defmacro resolving-object ((var create) &body body)
+  "Execute body attempting to resolve circularities found in 
+   form CREATE."
+  (with-gensyms (value key)
+    `(macrolet ((setting (place getting)
+                  `(let ((,',value ,getting))
+                     (if (referrer-p ,',value)
+                         (if *check-for-circs*
+                             (push (delay (setf ,place
+                                                (referred-value ,',value
+                                                                *restored-values*)))
+                                   *need-to-fix*)
+                             (restore-error "Found a circular values with *check-for-circs* = nil"))
+                         (setf ,place ,',value))))
+                (setting-hash (getting-key getting-place)
+                  `(let ((,',key ,getting-key))
+                     (if (referrer-p ,',key)
+                         (let ((,',value ,getting-place))
+                           (unless *check-for-circs*
+                             (restore-error "Found a circular values with *check-for-circs* = nil"))
+                           (push (delay (setf (gethash (referred-value ,',key *restored-values*)
+                                                       ,',var)
+                                              (if (referrer-p ,',value)
+                                                  (referred-value ,',value *restored-values*)
+                                                  ,',value)))
+                                 *need-to-fix*))
+                         (setting (gethash ,',key ,',var) ,getting-place)))))
+       (let ((,var ,create))
+         , at body
+         ,var))))
+
+(defstruct referrer val)
+
+(defun referred-value (referrer hash)
+  "Return the value REFERRER is meant to be by looking in HASH."
+  (gethash (referrer-val referrer)
+           hash))
+
+(defclass resolving-backend (backend) 
+  ()
+  (:documentation "A backend which does the setup for resolving circularities."))
+
+(declaim (type (or fixnum null) *stored-counter*))
+(defvar *stored-counter*)
+(defvar *stored-values*)
+
+(defvar *store-hash-size* 50)
+
+(defvar *grouped-store-hash*)
+(defvar *grouped-restore-hash*)
+
+(defun create-serialize-hash ()
+  (make-hash-table :test #'eql :size *store-hash-size*))
+
+(defmacro with-serialization-unit ((&key store-hash restore-hash)
+                                   &body body)
+  "Executes body in a single serialization unit allowing various internal data
+structures to be reused.
+The keys store-hash and restore-hash are expected to be either nil or
+hash-tables as produced by the function create-serialize-hash."
+  `(let ((*grouped-store-hash* (or ,store-hash (create-serialize-hash)))
+         (*grouped-restore-hash* (or ,restore-hash (create-serialize-hash))))
+     , at body))
+
+(defun get-store-hash ()
+  (when *check-for-circs*
+    (if (boundp '*grouped-store-hash*)
+        (clrhash *grouped-store-hash*)
+        (create-serialize-hash))))
+
+(defun get-restore-hash ()
+  (when *check-for-circs*
+    (if (boundp '*grouped-restore-hash*)
+        (clrhash *grouped-restore-hash*)
+        (create-serialize-hash))))
+
+(defmethod backend-store :around ((backend resolving-backend) (place t) (obj t))
+  (call-next-method))
+
+(defmethod backend-store ((backend resolving-backend) (place stream) (obj t))
+  "Store OBJ into PLACE. Does the setup for counters and seen values."
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let ((*stored-counter* 0) 
+        (*stored-values* (get-store-hash)))
+    (store-backend-code backend place)
+    (backend-store-object backend obj place)
+    obj))
+
+(defun seen (obj)
+  "Has this object already been stored?"
+  (declare (optimize speed (safety 0) (debug 0)))
+  (incf *stored-counter*)
+  (gethash obj *stored-values*))
+
+(defun update-seen (obj)
+  "Register OBJ as having been stored."
+  (declare (optimize speed (safety 0) (debug 0)))
+  (setf (gethash obj *stored-values*) *stored-counter*)
+  nil)
+
+(deftype not-circ ()
+  "Type grouping integers and characters, which we
+  don't bother to check if they have been stored before"
+  '(or integer character))
+
+(defun needs-checkp (obj)
+  "Do we need to check if this object has been stored before?"
+  (not (typep obj 'not-circ)))
+
+(defgeneric store-referrer (backend obj place)
+  (:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.")
+  (:method ((backend resolving-backend) (obj t) (place t))
+    (store-error  "store-referrer must be specialized for backend ~(~A~)."
+                  (name backend))))
+
+
+(defun get-ref (obj)
+  (declare (optimize speed (safety 0) (debug 0)))
+  (if (needs-checkp obj)
+      (multiple-value-bind (val win) (seen obj)
+        (if (or val win)
+            val
+            (update-seen obj)))
+      nil))
+
+(defmethod backend-store-object ((backend resolving-backend) (obj t) (place t))
+  "Store object if we have not seen this object before, otherwise retrieve
+  the referrer object for it and store that using store-referrer."
+  (aif (and *check-for-circs* (get-ref obj))
+       (store-referrer backend it place)
+       (internal-store-object backend obj place)))
+       
+;; Restoration.
+(declaim (type (or fixnum null) *restore-counter*))
+(defvar *restore-counter*)
+(defvar *need-to-fix*)
+(defvar *restored-values*)
+(defvar *restore-hash-size* 50)
+
+(defmethod backend-restore ((backend resolving-backend) (place stream))
+  "Restore an object from PLACE using BACKEND. Does the setup for 
+  various variables used by resolving-object."
+  (let ((*restore-counter* 0)
+        (*need-to-fix* nil)
+        (*restored-values* (get-restore-hash)))
+    (check-magic-number backend place)
+    (prog1
+      (backend-restore-object backend place)
+      (dolist (fn *need-to-fix*)
+        (force fn)))))
+
+(defun update-restored (spot val)
+  (declare (optimize speed (safety 0) (debug 0)))
+  (setf (gethash spot *restored-values*) val))
+
+(defun handle-normal (backend reader place)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let ((spot (incf *restore-counter*))
+        (vals (new-val (internal-restore-object backend reader place))))
+    (update-restored spot vals)
+    vals))
+
+(defgeneric referrerp (backend reader)
+  (:method ((backend t) (reader t))
+   (error "referrerp must be specialized for backend ~A." (name backend)))) 
+
+(defun handle-restore (place backend)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let ((reader (get-next-reader backend place)))
+    (declare (type symbol reader))
+    (cond ((referrerp backend reader) 
+           (incf *restore-counter*)
+           (new-val (internal-restore-object backend reader place)))
+          ((not (int-or-char-p backend reader))
+           (handle-normal backend reader place))
+          (t (new-val (internal-restore-object backend reader place))))))
+
+(defmethod backend-restore-object ((backend resolving-backend) (place t))
+  "Retrieve a object from PLACE, does housekeeping for circularity fixing."
+  (declare (optimize speed (safety 1) (debug 0)))
+  (if *check-for-circs*
+      (handle-restore place backend)
+      (call-next-method)))
+
+; This used to be called int-sym-or-char-p
+; but was renamed to handle eq symbols (gensym's mainly).
+; The basic concept is that we don't bother
+; checking for circularities with integers or
+; characters since these aren't gauranteed to be eq 
+; even if they are the same object. 
+; (notes for eq in CLHS).
+(defgeneric int-or-char-p (backend fn)
+  (:method ((backend backend) (fn symbol))
+    "Is function FN registered to restore an integer or character in BACKEND."
+    (member fn '(integer character)))) 
+
+(defun new-val (val)
+  "Tries to get a referred value to reduce unnecessary cirularity fixing."
+  (declare (optimize speed (safety 1) (debug 0)))
+  (if (referrer-p val)
+      (multiple-value-bind (new-val win) (referred-value val *restored-values*)
+        (if (or new-val win)
+            new-val
+            val))
+      val))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/cl-store-xml.noasd	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,69 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK.
+(in-package #:cl-user)
+
+(defpackage #:cl-store-xml.system
+  (:use #:cl #:asdf))
+
+(in-package #:cl-store-xml.system)
+
+(defclass non-required-file (cl-source-file) ()
+  (:documentation
+   "File containing implementation dependent code which may or may not be there."))
+
+(defun lisp-system-shortname ()
+  #+mcl mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl)
+
+(defmethod component-pathname ((component non-required-file))
+  (let ((pathname (call-next-method))
+        (name (string-downcase (lisp-system-shortname))))
+    (merge-pathnames
+     (make-pathname :directory (list :relative name))
+     pathname)))
+
+(defmethod perform ((op compile-op) (component non-required-file))
+  (when (probe-file (component-pathname component))
+    (call-next-method)))
+
+(defmethod perform ((op load-op) (component non-required-file))
+  (when (probe-file (component-pathname component))
+    (call-next-method)))
+
+(defmethod operation-done-p ((o operation) (c non-required-file))
+  (when (probe-file (component-pathname c))
+    (call-next-method)))
+
+
+(defsystem cl-store-xml
+  :name "CL-STORE-XML"
+  :author "Sean Ross <sdr at jhb.ucs.co.za>"
+  :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
+  :description "Xml Backend for cl-store"
+  :version "0.2.9"
+  :licence "MIT"
+  :components ((:file "xml-package")
+               (:file "xml-backend" :depends-on ("xml-package"))
+               (:non-required-file "custom-xml" :depends-on ("xml-backend")))
+  :depends-on (:cl-store :xmls))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store-xml))))
+  (provide 'cl-store-xml))
+
+(defmethod perform ((op test-op) (sys (eql (find-system :cl-store-xml))))
+  (oos 'load-op :cl-store-xml-tests)
+  (oos 'test-op :cl-store-xml-tests))
+
+(defsystem cl-store-xml-tests
+  :components ((:file "xml-tests"))
+  :depends-on (cl-store-tests cl-store-xml))
+
+(defmethod perform ((op test-op) 
+                    (sys (eql (find-system :cl-store-xml-tests))))
+  (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
+               (symbol-value (find-symbol "*XML-BACKEND*" "CL-STORE-XML")))
+      (error "Test-op Failed.")))
+
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/cl-store.asd
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/cl-store.asd	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,75 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+(in-package #:cl-user)
+
+(defpackage #:cl-store.system
+  (:use #:cl #:asdf)
+  (:export #:non-required-file))
+
+
+(in-package #:cl-store.system)
+
+#-(or lispworks mcl cmu clisp sbcl allegro ecl openmcl abcl)
+(error "This is an unsupported lisp implementation.
+Currently only MCL, OpenMCL, Lispworks, CMUCL, SBCL,
+CLISP, ECL and AllegroCL are supported.")
+
+(defclass non-required-file (cl-source-file) ()
+  (:documentation
+   "File containing implementation dependent code which may or may not be there."))
+
+(defun lisp-system-shortname ()
+  #+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl
+  #+allegro :acl #+ecl :ecl #+openmcl :openmcl #+abcl :abcl)
+
+(defmethod component-pathname ((component non-required-file))
+  (let ((pathname (call-next-method))
+        (name (string-downcase (lisp-system-shortname))))
+    (merge-pathnames
+     (make-pathname :directory (list :relative name))
+     pathname)))
+
+(defmethod perform ((op compile-op) (component non-required-file))
+  (when (probe-file (component-pathname component)) 
+    (call-next-method)))
+
+(defmethod perform ((op load-op) (component non-required-file))
+  (when (probe-file (component-pathname component))
+    (call-next-method)))
+
+(defmethod operation-done-p ((o operation) (c non-required-file))
+  (when (probe-file (component-pathname c))
+    (call-next-method)))
+
+(defsystem cl-store
+  :name "CL-STORE"
+  :author "Sean Ross <sross at common-lisp.net>"
+  :maintainer "Sean Ross <sross at common-lisp.net>"
+  :version "0.8.4"
+  :description "Serialization package"
+  :long-description "Portable CL Package to serialize data"
+  :licence "MIT"
+  :serial t
+  :components ((:file "package")
+               (:file "utils")
+               #+(or abcl (and clisp (not mop)))
+               (:file "mop")
+               (:file "backends")
+               (:file "plumbing")
+               (:file "circularities")
+               (:file "default-backend")
+               (:non-required-file "custom")))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store))))
+  (funcall (find-symbol "SETUP-SPECIAL-FLOATS" :cl-store))
+  (provide 'cl-store))
+
+(defmethod perform ((op test-op) (sys (eql (find-system :cl-store))))
+  (oos 'load-op :cl-store-tests)
+  (oos 'test-op :cl-store-tests))
+
+(defsystem cl-store-tests
+  :depends-on (rt cl-store)
+  :components ((:file "tests")))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/clisp/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,51 @@
+(in-package :cl-store)
+
+(defun cl-function-p (fn)
+  (eql #.(find-package :cl)
+       (symbol-package (nth-value 2 (function-lambda-expression fn)))))
+
+(defstore-cl-store (obj function stream)
+  (if (cl-function-p obj)
+      (dump-builtin-function obj stream)
+      (dump-closure obj stream)))
+
+(defun dump-builtin-function (obj stream)
+  (output-type-code +built-in-function-code+ stream)
+  (store-object (get-function-name obj) stream))
+
+(defun dump-closure (obj stream)
+  (output-type-code +function-code+ stream)
+  (flet ((so (object)
+           (store-object object stream)))
+    (mapc #'so (multiple-value-list (function-lambda-expression obj)))
+    (if (compiled-function-p obj)
+        (flet ((es (func) ;; extract-and-store
+                 (store-object (funcall func obj) stream)))
+          (mapc #'es
+                (list #'sys::closure-consts
+                      #'sys::closure-codevec
+                      #'sys::closure-documentation
+                      #'sys::closure-lambda-list)))
+        (dotimes (i 4) (so nil)))))
+
+(defrestore-cl-store (function stream)
+  (flet ((ro () (restore-object stream)))
+    (let ((lambda-exp (ro))
+          (closure-p (ro))
+          (name (ro))
+          (consts (ro))
+          (codevec (ro))
+          (doc (ro))
+          (lambda-list (ro)))
+      (declare (ignore closure-p))
+      (if codevec ;; compiled
+          ;; TODO What is a suitable default seclass? Currently ()
+          (sys::%make-closure name codevec consts () lambda-list doc)
+          ;; TODO Any functions to do this programmatically?  How to
+          ;; store/restore dynamic, lexical, etc environment.
+          (eval lambda-exp)))))
+
+(defrestore-cl-store (built-in-function stream)
+  (fdefinition (restore-object stream)))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/clisp/mop.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,72 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+;; this is such a pain.
+
+(defgeneric slot-definition-name (slot))
+(defgeneric slot-definition-allocation (slot))
+
+(defmethod slot-definition-name ((slot vector))
+  (aref slot 0))
+
+(defmethod slot-definition-allocation ((slot vector))
+  (if (keywordp (aref slot 4))
+      :instance
+      :class))
+
+
+(defun compute-slots (class)
+  (std-compute-slots class))
+                  
+(defun slot-definition-x (val slot)
+  (cadr (member val slot)))
+
+
+(defmethod slot-definition-allocation ((slot cons))
+  (or (slot-definition-x :allocation slot)
+      :instance))
+
+(defmethod slot-definition-initargs ((slot cons))
+  (slot-definition-x :initargs slot))
+
+(defmethod slot-definition-name ((slot cons))
+  (slot-definition-x :name slot))
+
+(defmethod slot-definition-readers ((slot cons))
+  (slot-definition-x :readers slot))
+
+(defmethod slot-definition-writers ((slot cons))
+  (slot-definition-x :writers slot))
+
+(defmethod slot-definition-type ((slot cons))
+  (or (slot-definition-x :type slot)
+      t))
+
+(defun class-direct-superclasses (class)
+  (or (clos::class-direct-superclasses class)
+      (list (find-class 'standard-object))))
+
+
+(defun add-methods-for-class (class vals)
+  (let ((readers (mappend #'(lambda (x)
+                              (second (member :readers x)))
+                          vals))
+        (writers (mappend #'(lambda (x)
+                              (second (member :writers x)))
+                          vals)))
+    (loop for x in readers do
+          (eval `(defmethod ,x ((clos::object ,class))
+                  (slot-value clos::object ',x))))
+    (loop for x in writers do
+          (eval `(defmethod ,x (clos::new-value (clos::object ,class))
+                  (setf (slot-value clos::object ',x) clos::new-value))))
+    (find-class class)))
+
+(defmethod generic-function-name ((gf generic-function))
+  (multiple-value-bind (l cp name) (function-lambda-expression gf)
+    (declare (ignore l cp))
+    name))
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/cmucl/custom-xml.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,37 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store-xml)
+
+
+(defstore-xml (obj structure-object stream)
+  (with-tag ("STRUCTURE-OBJECT" stream)
+    (princ-and-store "CLASS" (type-of obj) stream)
+    (xml-dump-type-object obj stream)))
+
+(defrestore-xml (structure-object place)
+  (restore-xml-type-object place))
+
+
+(defstore-xml (obj single-float stream)
+  (with-tag ("SINGLE-FLOAT" stream)
+    (princ-and-store "BITS" (kernel::single-float-bits obj)
+                     stream)))
+
+(defrestore-xml (single-float stream)
+  (kernel::make-single-float
+   (restore-first (get-child "BITS" stream))))
+
+(defstore-xml (obj double-float stream)
+  (with-tag ("DOUBLE-FLOAT" stream)
+    (princ-and-store "HIGH-BITS" (kernel::double-float-high-bits obj)
+                     stream)
+    (princ-and-store "LOW-BITS" (kernel::double-float-low-bits obj)
+                     stream)))
+
+(defrestore-xml (double-float stream)
+  (kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream))
+                             (restore-first (get-child "LOW-BITS" stream))))
+         
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/cmucl/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,119 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+; special floats
+(defun create-float-values (value &rest codes)
+  "Returns a alist of special float to float code mappings."
+  (ext:with-float-traps-masked (:overflow :invalid)
+    (let ((neg-inf (expt value 3)))
+      (mapcar 'cons
+              (list (expt (abs value) 2)
+                    neg-inf
+                    (/ neg-inf neg-inf))
+              codes))))
+
+;; Custom Structures
+(defstore-cl-store (obj structure-object stream)
+  (output-type-code +structure-object-code+ stream)
+  (store-type-object obj stream))
+
+(defrestore-cl-store (structure-object stream)
+  (restore-type-object stream))
+
+;; Structure definitions
+(defun get-layout (obj)
+  (slot-value obj 'pcl::wrapper))
+
+(defun get-info (obj)
+  (declare (type kernel:layout obj))
+  (slot-value obj 'ext:info))
+
+(defun dd-name (dd)
+  (slot-value dd 'kernel::name))
+
+(defvar *cmucl-struct-inherits*
+  (list (get-layout (find-class t))
+        (get-layout (find-class 'kernel:instance))
+        (get-layout (find-class 'cl:structure-object))))
+
+(defstruct (struct-def (:conc-name sdef-))
+  (supers (required-arg :supers) :type list)
+  (info (required-arg :info) :type kernel:defstruct-description))
+
+(defun info-or-die (obj)
+  (let ((wrapper (get-layout obj)))
+    (if wrapper
+        (or (get-info wrapper) 
+            (store-error "No defstruct-definition for ~A." obj))
+        (store-error "No wrapper for ~A." obj))))
+
+(defun save-able-supers (obj)
+  (set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits)
+                          'list)
+                  *cmucl-struct-inherits*))
+
+(defun get-supers (obj)
+  (loop for x in (save-able-supers obj) 
+     collect (let ((name (dd-name (get-info x))))
+               (if *store-class-superclasses* 
+                   (find-class name)
+                   name))))
+
+(defstore-cl-store (obj structure-class stream)
+  (output-type-code +structure-class-code+ stream)
+  (store-object (make-struct-def :info (info-or-die obj)
+                                 :supers (get-supers obj))
+                stream))
+
+(defstore-cl-store (obj struct-def stream)
+  (output-type-code +struct-def-code+ stream)
+  (store-object (sdef-supers obj) stream)
+  (store-object (sdef-info obj) stream))
+
+;; Restoring 
+(defun cmu-struct-defs (dd)
+  (append (kernel::define-constructors dd)
+          (kernel::define-raw-accessors dd)
+          (kernel::define-class-methods dd)))
+
+(defun create-make-foo (dd)
+  (let ((*compile-print* nil))
+    (funcall (compile nil `(lambda () ,@(cmu-struct-defs dd))))
+    (find-class (dd-name dd))))
+
+(defun cmu-define-structure (dd supers)
+  (cond ((or *nuke-existing-classes*  
+             (not (find-class (dd-name dd) nil)))
+         ;; create-struct
+         (kernel::%defstruct dd supers)
+         ;; compiler stuff
+         ;;(kernel::%compiler-defstruct dd) 
+         ;; create make-?
+         (create-make-foo dd))
+        (t (find-class (dd-name dd)))))
+  
+(defun super-layout (super)
+  (etypecase super
+    (symbol (get-layout (find-class super)))
+    (structure-class 
+     (super-layout (dd-name (info-or-die super))))))
+
+(defun super-layouts (supers)
+  (loop for super in supers 
+     collect (super-layout super)))
+
+(defrestore-cl-store (structure-class stream)
+  (restore-object stream))
+    
+(defrestore-cl-store (struct-def stream)
+  (let* ((supers (super-layouts (restore-object stream)))
+         (dd (restore-object stream)))
+    (cmu-define-structure dd (if supers 
+                                 (coerce (append  *cmucl-struct-inherits*
+                                                  supers)
+                                         'vector)
+                                 (coerce *cmucl-struct-inherits* 'vector)))))
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/default-backend.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/default-backend.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,787 @@
+7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; The cl-store backend. 
+(in-package :cl-store)
+
+(defbackend cl-store :magic-number 1395477571
+            :stream-type '(unsigned-byte 8)
+            :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155
+                                1349740876 1884506444 1347643724 1349732684 1953713219
+                                1416850499)
+            :extends (resolving-backend)
+            :fields ((restorers :accessor restorers 
+                                :initform (make-hash-table :size 100))))
+
+(defun register-code (code name &optional (errorp nil))
+  (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp)
+       (error "Code ~A is already defined for ~A." code name)
+       (setf (gethash code (restorers (find-backend 'cl-store)))
+             name))
+  code)
+
+
+;;  Type code constants
+(defparameter +referrer-code+ (register-code 1 'referrer))
+(defparameter +special-float-code+ (register-code 2 'special-float))
+(defparameter +unicode-string-code+ (register-code 3 'unicode-string))
+(defparameter +integer-code+ (register-code 4 'integer))
+(defparameter +simple-string-code+ (register-code 5 'simple-string))
+(defparameter +float-code+ (register-code 6 'float))
+(defparameter +ratio-code+ (register-code 7 'ratio))
+(defparameter +character-code+ (register-code 8 'character))
+(defparameter +complex-code+ (register-code 9 'complex))
+(defparameter +symbol-code+ (register-code 10 'symbol))
+(defparameter +cons-code+ (register-code 11 'cons))
+(defparameter +pathname-code+ (register-code 12 'pathname))
+(defparameter +hash-table-code+ (register-code 13 'hash-table))
+(defparameter +standard-object-code+ (register-code 14 'standard-object))
+(defparameter +condition-code+ (register-code 15 'condition))
+(defparameter +structure-object-code+ (register-code 16 'structure-object))
+(defparameter +standard-class-code+ (register-code 17 'standard-class))
+(defparameter +built-in-class-code+ (register-code 18 'built-in-class))
+(defparameter +array-code+ (register-code 19 'array))
+(defparameter +simple-vector-code+ (register-code 20 'simple-vector))
+(defparameter +package-code+ (register-code 21 'package))
+(defparameter +simple-byte-vector-code+ (register-code 22 'simple-byte-vector))
+
+;; fast storing for 32 bit ints
+(defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer))
+(defparameter +built-in-function-code+ (register-code 25 'built-in-function))
+(defparameter +function-code+ (register-code 26 'function nil))
+(defparameter +gf-code+ (register-code 27 'generic-function nil))
+
+;; Used by SBCL and CMUCL.
+(defparameter +structure-class-code+ (register-code 28 'structure-class))
+(defparameter +struct-def-code+ (register-code 29 'struct-def))
+
+(defparameter +gensym-code+ (register-code 30 'gensym))
+
+(defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string))
+(defparameter +simple-base-string-code+ (register-code 35 'simple-base-string))
+
+;; setups for type code mapping
+(defun output-type-code (code stream)
+  (declare (type ub32 code))
+  (write-byte (ldb (byte 8 0) code) stream))
+
+(declaim (inline read-type-code))
+(defun read-type-code (stream)
+  (read-byte stream))
+
+(defmethod referrerp ((backend cl-store) (reader t))
+  (declare (optimize speed (safety 0) (space 0) (debug 0)))
+  (eql reader 'referrer))
+
+(defparameter *restorers* (restorers (find-backend 'cl-store)))
+
+;; get-next-reader needs to return a symbol which will be used by the
+;; backend to lookup the function that was defined by
+;; defrestore-cl-store to restore it, or nil if not found. 
+(defun lookup-code (code)
+  (declare (optimize speed (safety 0) (space 0) (debug 0)))
+  (gethash code *restorers*))
+
+(defmethod get-next-reader ((backend cl-store) (stream stream))
+  (declare (optimize speed (safety 0) (space 0) (debug 0)))
+  (let ((type-code (read-type-code stream)))
+    (or (lookup-code type-code)
+        (error "Type code ~A is not registered." type-code))))
+
+
+;; referrer, Required for a resolving backend
+(defmethod store-referrer ((backend cl-store) (ref t) (stream t))
+  (output-type-code +referrer-code+ stream)
+  (dump-int ref stream))
+
+(defrestore-cl-store (referrer stream)
+  (make-referrer :val (undump-int stream)))
+
+
+
+;; integers
+;; The theory is that most numbers will fit in 32 bits 
+;; so we we have a little optimization for it
+
+;; We need this for circularity stuff.
+(defmethod int-or-char-p ((backend cl-store) (type symbol))
+  (declare (optimize speed (safety 0) (space 0) (debug 0)))
+  (or (eql type '32-bit-integer)
+      (eql type 'integer)
+      (eql type 'character)))
+
+(defstore-cl-store (obj integer stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (if (typep obj 'sb32)
+      (store-32-bit-integer obj stream)
+      (store-arbitrary-integer obj stream)))
+
+(defun dump-int (obj stream)
+  (declare (optimize speed (safety 0) (debug 0)))
+  (etypecase obj 
+    ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream))
+    ((unsigned-byte 32) (write-byte 2 stream) (store-32-bit obj stream))))
+
+(defun undump-int (stream)
+  (declare (optimize speed (safety 0) (debug 0)))
+  (ecase (read-byte stream)
+    (1 (read-byte stream))
+    (2 (read-32-bit stream nil))))
+
+(defun store-32-bit-integer (obj stream)
+  (declare (optimize speed (safety 1) (debug 0)) (type sb32 obj))
+  (output-type-code +32-bit-integer-code+ stream)
+  (write-byte (if (minusp obj) 1 0) stream)
+  (dump-int (abs obj) stream))
+
+(defrestore-cl-store (32-bit-integer stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-)
+           (undump-int stream)))
+
+
+(defun num->bits (num )
+  (loop for val = (abs num) then (ash val -8 )
+        for count from 0
+        until (zerop val)
+        collect (logand val #XFF) into bits
+        finally (return (values bits count))))
+
+(defun store-arbitrary-integer (obj stream)
+  (declare (type integer obj) (stream stream)
+           (optimize speed))
+  (output-type-code +integer-code+ stream)
+  (multiple-value-bind (bits count) (num->bits obj)
+    (store-object (if (minusp obj) (- count) count)
+                  stream)
+    (dolist (x bits) (store-32-bit x stream))))
+
+
+(defrestore-cl-store (integer buff)
+  (declare (optimize speed))
+  (let ((count (restore-object buff)))
+    (loop repeat (abs count)
+          with sum = 0
+          for pos from 0 by 8
+          for bit = (read-32-bit buff nil)
+          finally (return (if (minusp count) (- sum) sum))
+          :do
+          (incf sum (* bit (expt 2 pos))))))
+
+        
+
+(defun bits->num (bits)
+  (loop with sum = 0
+        for pos from 0 by 8
+        for bit in bits
+        finally (return sum)
+        :do (incf sum (* bit (expt 2 pos)))))
+
+
+
+;; Floats (*special-floats* are setup in the custom.lisp files)
+
+(defconstant +short-float-inf+ 0)
+(defconstant +short-float-neg-inf+ 1)
+(defconstant +short-float-nan+ 2)
+
+(defconstant +single-float-inf+ 3)
+(defconstant +single-float-neg-inf+ 4)
+(defconstant +single-float-nan+ 5)
+
+(defconstant +double-float-inf+ 6)
+(defconstant +double-float-neg-inf+ 7)
+(defconstant +double-float-nan+ 8)
+
+(defconstant +long-float-inf+ 9)
+(defconstant +long-float-neg-inf+ 10)
+(defconstant +long-float-nan+ 11)
+
+(defvar *special-floats* nil)
+
+;; Implementations are to provide an implementation for the create-float-value
+;; function
+(defun create-float-values (value &rest codes)
+  "Returns a alist of special float to float code mappings."
+  (declare (ignore value codes))
+  nil)
+
+(defun setup-special-floats ()
+  (setf *special-floats*
+        (nconc (create-float-values most-negative-short-float +short-float-inf+
+                                    +short-float-neg-inf+ +short-float-nan+)
+               (create-float-values most-negative-single-float +single-float-inf+
+                                    +single-float-neg-inf+ +single-float-nan+)
+               (create-float-values most-negative-double-float +double-float-inf+
+                                    +double-float-neg-inf+ +double-float-nan+)
+               (create-float-values most-negative-long-float +long-float-inf+
+                                    +long-float-neg-inf+ +long-float-nan+))))
+
+(defstore-cl-store (obj float stream)
+  (declare (optimize speed))
+  (block body
+    (let (significand exponent sign)
+      (handler-bind (((or simple-error arithmetic-error type-error)
+                      #'(lambda (err)
+                          (declare (ignore err))
+                          (when-let (type (cdr (assoc obj *special-floats*)))
+                            (output-type-code +special-float-code+ stream)
+                            (write-byte type stream)
+                            (return-from body)))))
+        (multiple-value-setq (significand exponent sign)
+            (integer-decode-float obj))
+        (output-type-code +float-code+ stream)
+        (write-byte (float-type obj) stream)
+        (store-object significand stream)
+        (store-object (float-radix obj) stream)
+        (store-object exponent stream)
+        (store-object sign stream)))))
+
+(defrestore-cl-store (float stream)
+  (float (* (the float (get-float-type (read-byte stream)))
+            (* (the integer (restore-object stream))
+               (expt (the integer (restore-object stream))
+                     (the integer (restore-object stream))))
+            (the integer (restore-object stream)))))
+
+(defrestore-cl-store (special-float stream)
+  (or (car (rassoc (read-byte stream) *special-floats*))
+      (restore-error "Float ~S is not a valid special float.")))
+
+
+;; ratio
+(defstore-cl-store (obj ratio stream)
+  (output-type-code +ratio-code+ stream)
+  (store-object (numerator obj) stream)
+  (store-object (denominator obj) stream))
+
+(defrestore-cl-store (ratio stream)
+  (/ (the integer (restore-object stream))
+     (the integer (restore-object stream))))
+
+;; chars
+(defstore-cl-store (obj character stream)
+  (output-type-code +character-code+ stream)    
+  (store-object (char-code obj) stream))
+
+(defrestore-cl-store (character stream)
+  (code-char (restore-object stream)))
+
+;; complex
+(defstore-cl-store (obj complex stream)
+  (output-type-code +complex-code+ stream)    
+  (store-object (realpart obj) stream)
+  (store-object (imagpart obj) stream))
+
+(defrestore-cl-store (complex stream)
+  (complex (restore-object stream)
+           (restore-object stream)))
+
+;; symbols
+(defstore-cl-store (obj symbol stream)
+  (declare (optimize speed))
+  (cond ((symbol-package obj)
+         (output-type-code +symbol-code+ stream)
+         (store-object (symbol-name obj) stream)
+         (store-object (package-name (symbol-package obj))
+                       stream))
+        ;; Symbols with no home package 
+        (t (output-type-code +gensym-code+ stream)
+           (store-object (symbol-name obj) stream))))
+
+(defrestore-cl-store (symbol stream)
+  (values (intern (restore-object stream)
+                  (restore-object stream))))
+
+(defrestore-cl-store (gensym stream)
+  (make-symbol (restore-object stream)))
+
+
+;; Lists
+(defun dump-list (list length last stream)
+  (declare (optimize speed (safety 1) (debug 0))
+           (type cons list))
+  (output-type-code +cons-code+ stream)
+  (store-object length stream)
+  (loop repeat length 
+        for x on list do
+        (store-object (car x) stream))
+  (store-object last stream))
+
+(defun restore-list (stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let* ((conses (restore-object stream))
+         (ret ())
+         (tail ret))
+    (dotimes (x conses)
+      (let ((obj (restore-object stream)))
+        ;; we can't use setting here since we wan't to
+        ;; be fairly efficient when adding objects to the
+        ;; end of the list.
+        (when (and *check-for-circs* (referrer-p obj))
+          (let ((x x))
+            (push (delay (setf (nth x ret)
+                               (referred-value obj *restored-values*)))
+                  *need-to-fix*)))
+        (if ret
+            (setf (cdr tail) (list obj) 
+                  tail (cdr tail))
+            (setf ret (list obj)
+                  tail (last ret)))))
+    (let ((last1 (restore-object stream)))
+      ;; and check for the last possible circularity
+      (if (and *check-for-circs* (referrer-p last1))
+          (push (delay (setf (cdr tail)
+                             (referred-value last1 *restored-values*)))
+                *need-to-fix*)
+          (setf (cdr tail) last1)))
+    ret))
+
+(defstore-cl-store (list cons stream)
+  (multiple-value-bind (length last) (safe-length list)
+    (dump-list list length last stream)))
+
+(defrestore-cl-store (cons stream)
+  (restore-list stream))
+
+
+;; pathnames
+(defstore-cl-store (obj pathname stream)
+  (output-type-code +pathname-code+ stream)
+  (store-object #-sbcl (pathname-host obj)
+                #+sbcl (host-namestring obj) stream)
+  (store-object (pathname-device obj) stream)
+  (store-object (pathname-directory obj) stream)
+  (store-object (pathname-name obj) stream)
+  (store-object (pathname-type obj) stream)
+  (store-object (pathname-version obj) stream))
+
+(defrestore-cl-store (pathname stream)
+  (make-pathname
+   :host (restore-object stream)
+   :device (restore-object stream)
+   :directory (restore-object stream)
+   :name (restore-object stream)
+   :type (restore-object stream)
+   :version (restore-object stream)))
+
+
+;; hash tables
+(defstore-cl-store (obj hash-table stream)
+  (declare (optimize speed))
+  (output-type-code +hash-table-code+ stream)    
+  (store-object (hash-table-rehash-size obj) stream)
+  (store-object (hash-table-rehash-threshold obj) stream)
+  (store-object (hash-table-size obj) stream)
+  (store-object (hash-table-test obj) stream)
+  (store-object (hash-table-count obj) stream)
+  (loop for key being the hash-keys of obj
+        using (hash-value value) do
+        (store-object key stream)
+        (store-object value stream)))
+
+(defrestore-cl-store (hash-table stream)
+  (let ((rehash-size (restore-object stream))
+        (rehash-threshold (restore-object stream))
+        (size (restore-object stream))
+        (test (restore-object stream))
+        (count (restore-object stream)))
+    (declare (type integer count size))
+    (let ((hash (make-hash-table :test test
+                                 :rehash-size rehash-size
+                                 :rehash-threshold rehash-threshold
+                                 :size size)))
+      (resolving-object (x hash)
+        (loop repeat count do
+              ;; Unfortunately we can't use the normal setting here
+              ;; since there could be a circularity in the key
+              ;; and we need to make sure that both objects are 
+              ;; removed from the stream at this point.
+              (setting-hash (restore-object stream) 
+                            (restore-object stream))))
+      hash)))
+
+;; The dumping of objects works by serializing  the type of the object which
+;; is followed by applicable slot-name and value (depending on whether the
+;; slot is bound, it's allocation and *store-class-slots*). Once each slot
+;; is serialized a counter is incremented which is stored  at the end.
+;; When restoring the object a new instance is allocated and then
+;; restore-type-object starts reading objects from the stream.
+;; If the restored object is a symbol the it names a slot and it's value
+;; is pulled out and set on the newly allocated object.
+;; If the restored object is an integer then this is the end marker
+;; for the object and the number of slots restored is checked against
+;; this counter.
+
+;; Object and Conditions
+(defun store-type-object (obj stream)
+  (declare (optimize speed))
+  (let ((all-slots (serializable-slots obj))
+        (length 0))
+    (store-object (type-of obj) stream)
+    (dolist (slot all-slots)
+      (let ((slot-name (slot-definition-name slot)))
+        (when (and (slot-boundp obj slot-name)
+                   (or *store-class-slots*
+                       (not (eql (slot-definition-allocation slot)
+                                 :class))))
+          (store-object (slot-definition-name slot) stream)
+          (store-object (slot-value obj slot-name) stream)
+          (incf length))))
+    (store-object length stream)))
+
+(defstore-cl-store (obj standard-object stream)
+  (output-type-code +standard-object-code+ stream)    
+  (store-type-object obj stream))
+
+(defstore-cl-store (obj condition stream)
+  (output-type-code +condition-code+ stream)    
+  (store-type-object obj stream))
+
+(defun restore-type-object (stream)
+  (declare (optimize speed))
+  (let* ((class (find-class (restore-object stream)))
+         (new-instance (allocate-instance class)))
+    (resolving-object (obj new-instance)
+      (loop for count from 0 do
+            (let ((slot-name (restore-object stream)))
+              (etypecase slot-name
+                (integer (assert (= count slot-name) (count slot-name)
+                           "Number of slots restored does not match slots stored.")
+                         (return))
+                (symbol 
+                 ;; slot-names are always symbols so we don't
+                 ;; have to worry about circularities
+                 (setting (slot-value obj slot-name) (restore-object stream)))))))
+    new-instance))
+
+(defrestore-cl-store (standard-object stream)
+  (restore-type-object stream))
+
+(defrestore-cl-store (condition stream)
+  (restore-type-object stream))
+
+
+;; classes
+(defstore-cl-store (obj standard-class stream)
+  (output-type-code +standard-class-code+ stream)
+  (store-object (class-name obj) stream)
+  (store-object (mapcar #'get-slot-details (class-direct-slots obj))
+                stream)
+  (store-object (mapcar (if *store-class-superclasses*
+                            #'identity 
+                            #'class-name)
+                        (class-direct-superclasses obj))
+                stream)
+  (store-object (type-of obj) stream))
+
+(defrestore-cl-store (standard-class stream)
+  (let* ((class (restore-object stream))
+         (slots (restore-object stream))
+         (supers (restore-object stream))
+         (meta (restore-object stream))
+         (keywords '(:direct-slots :direct-superclasses
+                     :metaclass))
+         (final (loop for keyword in keywords
+                      for slot in (list slots 
+                                        (or supers (list 'standard-object))
+                                        meta)
+                      nconc (list keyword slot))))
+    (cond ((find-class class nil)
+           (cond (*nuke-existing-classes*
+                  (apply #'ensure-class class final)
+                  #+(and clisp (not mop)) (add-methods-for-class class slots))
+                 (t (find-class class))))
+          (t (apply #'ensure-class class final)
+             #+(and clisp (not mop)) (add-methods-for-class class slots)))))
+
+;; built in classes
+
+(defstore-cl-store (obj built-in-class stream)
+  (output-type-code +built-in-class-code+ stream)
+  (store-object (class-name obj) stream))
+
+#-ecl ;; for some reason this doesn't work with ecl
+(defmethod internal-store-object ((backend cl-store) (obj (eql (find-class 'hash-table))) stream)
+  (output-type-code +built-in-class-code+ stream)
+  (store-object 'cl:hash-table stream))
+
+(defrestore-cl-store (built-in-class stream)
+  (find-class (restore-object stream)))
+
+
+;; Arrays, vectors and strings.
+(defstore-cl-store (obj array stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (typecase obj
+    (simple-base-string (store-simple-base-string obj stream))
+    (simple-string (store-simple-string obj stream))
+    (simple-vector (store-simple-vector obj stream))
+    ((simple-array (unsigned-byte 8) (*)) (store-simple-byte-vector obj stream))
+    (t (store-array obj stream))))
+
+
+(defun store-array (obj stream)
+  (declare (optimize speed (safety 0) (debug 0))
+           (type array obj))
+  (output-type-code +array-code+ stream)
+  (if (and (= (array-rank obj) 1)
+           (array-has-fill-pointer-p obj))
+      (store-object (fill-pointer obj) stream)
+      (store-object nil stream))
+  (store-object (array-element-type obj) stream)
+  (store-object (adjustable-array-p obj) stream)
+  (store-object (array-dimensions obj) stream)
+  (dolist (x (multiple-value-list (array-displacement obj)))
+    (store-object x stream))
+  (store-object (array-total-size obj) stream)
+  (loop for x from 0 below (array-total-size obj) do
+        (store-object (row-major-aref obj x) stream)))
+
+ 
+
+
+(defrestore-cl-store (array stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let* ((fill-pointer (restore-object stream))
+         (element-type (restore-object stream))
+         (adjustable (restore-object stream))
+         (dimensions (restore-object stream))
+         (displaced-to (restore-object stream))
+         (displaced-offset (restore-object stream))
+         (size (restore-object stream))
+         (res (make-array dimensions  
+                          :element-type element-type
+                          :adjustable adjustable
+                          :fill-pointer fill-pointer)))
+    (declare (type cons dimensions) (type array-tot-size size))
+    (when displaced-to 
+      (adjust-array res dimensions :displaced-to displaced-to
+                    :displaced-index-offset displaced-offset))
+    (resolving-object (obj res)
+      (loop for x from 0 below size do
+            (let ((pos x))
+              (setting (row-major-aref obj pos) (restore-object stream)))))))
+
+(defun store-simple-vector (obj stream)
+  (declare (optimize speed (safety 0) (debug 0))
+           (type simple-vector obj))
+  (output-type-code +simple-vector-code+ stream)
+  (store-object (length obj) stream)
+  (loop for x across obj do
+    (store-object x stream)))
+
+(defrestore-cl-store (simple-vector stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let* ((size (restore-object stream))
+         (res (make-array size)))
+    (declare (type array-size size))
+    (resolving-object (obj res)
+      (dotimes (i size)
+        ;; we need to copy the index so that
+        ;; it's value at this time is preserved.
+        (let ((x i)) 
+          (setting (aref obj x) (restore-object stream)))))
+    res))
+
+(defun store-simple-byte-vector (obj stream)
+  (declare (optimize speed (safety 0) (debug 0))
+           (type (simple-array (unsigned-byte 8) (*)) obj))
+  (output-type-code +simple-byte-vector-code+ stream)
+  (store-object (length obj) stream)
+  (loop for x across obj do
+        (write-byte x stream)))
+ 
+(defrestore-cl-store (simple-byte-vector stream)
+  (declare (optimize speed (safety 1) (debug 0)))
+  (let* ((size (restore-object stream))
+         (res (make-array size :element-type '(unsigned-byte 8))))
+    (declare (type array-size size))
+    (resolving-object (obj res)
+      (dotimes (i size)
+        ;; we need to copy the index so that
+        ;; it's value at this time is preserved.
+        (let ((x i)) 
+          (setting (aref obj x) (read-byte stream)))))
+    res))
+
+;; Dumping (unsigned-byte 32) for each character seems
+;; like a bit much when most of them will be 
+;; base-chars. So we try to cater for them.
+(defvar *char-marker* (code-char 255)
+  "Largest character that can be represented in 8 bits")
+
+(defun unicode-string-p (string)
+  "An implementation specific test for a unicode string."
+  (declare (optimize speed (safety 0) (debug 0))
+           (type simple-string string))
+  #+cmu nil ;; cmucl doesn't support unicode yet.
+  #+lispworks (not (typep string 'lw:8-bit-string))
+  #-(or cmu lispworks) (some #'(lambda (x) (char> x *char-marker*)) string))
+
+(defun store-simple-string (obj stream)
+  (declare (type simple-string obj)
+           (optimize speed (safety 1) (debug 0)))
+  (cond ((unicode-string-p obj)
+         (output-type-code +unicode-string-code+ stream)
+         (dump-string #'dump-int obj stream))
+        (t (output-type-code +simple-string-code+ stream)
+           (dump-string #'write-byte obj stream))))
+
+(defun store-simple-base-string (obj stream)
+  (declare (type simple-string obj)
+           (optimize speed (safety 1) (debug 0)))
+  (cond ((unicode-string-p obj)
+         (output-type-code +unicode-base-string-code+ stream)
+         (dump-string #'dump-int obj stream))
+        (t (output-type-code +simple-base-string-code+ stream)
+           (dump-string #'write-byte obj stream))))
+
+(defun dump-string (dumper obj stream)
+  (declare (simple-string obj) (function dumper) (stream stream)
+           (optimize speed (safety 1) (debug 0)))
+  (dump-int (the array-size (length obj)) stream)
+  (loop for x across obj do (funcall dumper (char-code x) stream)))
+
+(defrestore-cl-store (simple-string stream)
+  (declare (optimize speed))
+  (undump-string #'read-byte 'character stream))
+
+(defrestore-cl-store (unicode-string stream)
+  (declare (optimize speed))
+  (undump-string #'undump-int 'character stream))
+
+(defrestore-cl-store (simple-base-string stream)
+  (declare (optimize speed))
+  (undump-string #'read-byte 'base-char stream))
+
+(defrestore-cl-store (unicode-base-string stream)
+  (declare (optimize speed))
+  (undump-string #'undump-int 'base-char stream))
+
+(defun undump-string (reader type stream)
+  (declare (type function reader) (type stream stream)
+           (optimize speed (safety 1) (debug 0)))
+  (let* ((length (the array-size (undump-int stream)) )
+         (res (make-string length :element-type type)))
+    (declare (type simple-string res))
+    (dotimes (x length)
+      (setf (schar res x) (code-char (funcall reader stream))))
+    res))
+
+;; packages (from Thomas Stenhaug)
+(defstore-cl-store (obj package stream)
+  (output-type-code +package-code+ stream)  
+  (store-object (package-name obj) stream)
+  (store-object (package-nicknames obj) stream)
+  (store-object (mapcar (if *store-used-packages* #'identity #'package-name)
+                        (package-use-list obj))
+                stream)
+  (store-object (internal-symbols obj) stream)
+  (store-object (package-shadowing-symbols obj) stream)
+  (store-object (external-symbols obj) stream))
+
+(defun remove-remaining (times stream)
+  (declare (optimize speed) (type fixnum times))
+  (dotimes (x times)
+    (restore-object stream)))
+
+(defrestore-cl-store (package stream)
+  (let* ((package-name (restore-object stream))
+         (existing-package (find-package package-name)))
+    (cond ((or (not existing-package)
+               (and existing-package *nuke-existing-packages*))
+           (restore-package package-name stream :force *nuke-existing-packages*))
+          (t (remove-remaining 5 stream)
+             existing-package))))
+
+(defun internal-symbols (package)
+  (let ((acc (make-array 100 :adjustable t :fill-pointer 0))
+        (used (package-use-list package)))
+    (do-symbols (symbol package)
+      (unless (find (symbol-package symbol) used)
+        (vector-push-extend symbol acc)))
+    acc))
+
+(defun external-symbols (package)
+  (let ((acc (make-array 100 :adjustable t :fill-pointer 0)))
+    (do-external-symbols (symbol package)
+      (vector-push-extend symbol acc))
+    acc))
+
+(defun restore-package (package-name stream &key force)
+  (when (and force (find-package package-name))
+    (delete-package package-name))
+  (let ((package (make-package package-name
+			       :nicknames (restore-object stream)
+			       :use (restore-object stream))))
+    (loop for symbol across (restore-object stream) do
+      (import symbol package))
+    (shadow (restore-object stream) package)
+    (loop for symbol across (restore-object stream) do
+      (export symbol package))
+    package))
+
+;; Function storing hack.
+;; This just stores the function name if we can find it
+;; or signal a store-error.
+(defun parse-name (name)
+  (let ((name (subseq name 21)))
+    (declare (type simple-string name))
+    (if (search name "SB!" :end1 3)
+        (replace name "SB-" :end1 3)
+        name)))
+
+#+sbcl
+(defvar *sbcl-readtable* (copy-readtable nil))
+#+sbcl
+(set-macro-character #\# #'(lambda (c s) 
+                             (declare (ignore c s))
+                             (store-error "Invalid character in function name."))
+                     nil
+                     *sbcl-readtable*)
+
+(defun get-function-name (obj)
+  (multiple-value-bind (l cp name) (function-lambda-expression obj) 
+    (declare (ignore l cp))
+    (cond ((and name (or (symbolp name) (consp name))) name)
+          ;;  Try to deal with sbcl's naming convention
+          ;; of built in functions (pre 0.9)
+          #+sbcl
+          ((and name (stringp name)
+                (search "top level local call " (the simple-string name)))
+           (let ((new-name (parse-name name))
+                 (*readtable* *sbcl-readtable*))
+             (unless (string= new-name "")
+               (handler-case (read-from-string new-name)
+                 (error (c) 
+                   (declare (ignore c))
+                   (store-error "Unable to determine function name for ~A."
+                                obj))))))
+          (t (store-error "Unable to determine function name for ~A."
+                          obj)))))
+  
+
+#-clisp
+(defstore-cl-store (obj function stream)
+  (output-type-code +function-code+ stream)
+  (store-object (get-function-name obj) stream))
+
+#-clisp
+(defrestore-cl-store (function stream)
+  (fdefinition (restore-object stream)))
+
+;; Generic function, just dumps the gf-name
+(defstore-cl-store (obj generic-function stream)
+  (output-type-code +gf-code+ stream)
+  (aif (generic-function-name obj)
+       (store-object it stream)
+       (store-error "No generic function name for ~A." obj)))
+
+(defrestore-cl-store (generic-function stream)
+  (fdefinition (restore-object stream)))
+
+
+(setf *default-backend* (find-backend 'cl-store))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/doc/cl-store.texi	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,796 @@
+\input texinfo          @c -*- texinfo -*-
+ at c %**start of header
+ at setfilename cl-store.texi
+ at settitle CL-STORE Manual
+
+
+ at dircategory Software development
+ at direntry
+* cl-store: (cl-store).  CL Serialization Package
+ at end direntry
+
+ at copying
+Copyright  @copyright{} (c) (C) 2004 Sean Ross All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met: 
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.  
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. The names of the authors and contributors may not be used to endorse
+   or promote products derived from this software without specific prior
+   written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+ at end copying
+
+ at c 
+ at titlepage
+ at title CL-STORE: CL Serialization Package
+
+ at page
+ at vskip 0pt plus 1filll
+ at insertcopying
+ at end titlepage
+
+ at contents
+
+ at ifnottex
+
+ at node Top
+ at top CL-STORE: CL Serialization Package
+
+ at insertcopying
+
+ at menu
+* Introduction:         Introduction
+* Getting Started:      Getting Started
+* API:                  API
+* Customizing:          Customizing
+* New Backends:         New Backends
+* Notes:                Notes
+* Credits:              Credits
+* Index::
+
+ at end menu
+
+ at end ifnottex
+
+ at node Introduction
+ at chapter Introduction
+
+CL-STORE is a portable serialization package for Common Lisp which
+allows the reading and writing of most objects found in Common Lisp
+resolving any circularities which it detects. It is intended to serve
+the same purpose as Java's ObjectOutput and ObjectInputStream, although
+it's somewhat more extensible.
+
+The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store}
+where one can find details about mailing lists, cvs repositories and various releases.
+
+This documentation is for CL-STORE version 0.6 .
+
+Enjoy
+ Sean.
+ at section Example
+ at lisp
+(defclass myclass () ((a :accessor a :initarg :a)))
+(cl-store:store (make-instance 'myclass :a 3) "/tmp/test.out")
+
+(a (cl-store:restore "/tmp/test.out"))
+ at end lisp
+
+
+ at section Supported Objects
+ at itemize @bullet 
+ at item Numbers (floats, integers, complex, NaN floats, rationals)
+ at item Strings (Supports Unicode Strings)
+ at item Characters
+ at item Symbols
+ at item Packages
+ at item HashTables
+ at item Lists
+ at item Vectors And Arrays
+ at item Instances of CLOS Classes
+ at item CLOS Classes
+ at item Structure Instances
+ at item Structure Definitions (CMUCL and SBCL only)
+ at item Functions (stores the function name)
+ at item Generic Functions (stores generic-function-name)
+ at end itemize
+
+ at section Supported Implementations
+ at itemize @bullet
+ at item SBCL
+ at item CMUCL
+ at item CLISP
+ at item Lispworks
+ at item Allegro CL
+ at item OpenMCL
+ at item ECL
+ at end itemize
+
+
+ at node Getting Started
+ at chapter Getting Started
+
+CL-STORE uses @uref{http://cliki.net/asdf,,asdf} as it's system definition tool and 
+is required whenever you load the package.  
+You will need to download it, or if you have @uref{http://sbcl.org,,sbcl}
+ at code{(require 'asdf)}
+
+
+ at section Downloading
+ at itemize
+ at item ASDF-INSTALL 
+CL-STORE is available through asdf-install. If you are new
+to Common Lisp this is the suggested download method. With asdf-install loaded run 
+ at code{(asdf-install:install :cl-store)}
+This will download and install the package for you. Asdf-install will try to verify 
+that the package signature is correct and that you trust the author. If the key is 
+not found or the trust level is not sufficient a continuable error will be signalled. 
+You can choose to ignore the error and continue to install the package. 
+See the documentation of asdf-install for more details.
+
+ at item DOWNLOAD
+
+The latest cl-store release will always be available from @uref{http://common-lisp.net,,cl.net}.
+Download and untar in an appropriate directory then symlink @file{cl-store.asd}
+to a directory on @code{asdf:*central-registry*} 
+(see the documentation for asdf for details about setting up asdf).
+
+ at item CVS
+
+If you feel the need to be on the bleeding edge you can use
+anonymous CVS access, see the @uref{http://common-lisp.net/project/cl-store,,Home Page}
+for more details for accessing the archive. Once downloaded follow the symlink instructions above.
+
+ at end itemize
+
+ at section Installing
+Once downloaded and symlinked you can load CL-STORE at anytime using
+ at code{(asdf:oos 'asdf:load-op :cl-store)}
+This will compile CL-STORE the first time it is loaded.
+
+ at section Testing
+Once installed you can run the regression tests for it. 
+The tests depend on the @uref{http://cliki.net/rt,,Regression Tests}
+ asdf package which is asdf-installable. The tests can be run be executing
+ at code{(asdf:oos 'asdf:test-op :cl-store)}
+
+If any tests fail please send a message to one of the Mailing Lists.
+
+
+ at node API
+ at chapter API
+
+ at section Variables
+ at anchor{Variable *nuke-existing-classes*}
+ at vindex *nuke-existing-classes*
+ at deftp {Variable} *nuke-existing-classes* @emph{Default NIL}
+Determines wether or not to override existing classes when restoring a CLOS Class. If
+ at code{*nuke-existing-classes*} is not NIL the current definition will be overridden.
+ at end deftp 
+
+ at anchor{Variable *store-class-superclasses*}
+ at vindex *store-class-superclasses*
+ at deftp {Variable} *store-class-superclasses* @emph{Default NIL}
+If @code{*store-class-superclasses*} is not NIL when storing a CLOS Class all
+superclasses will be stored.
+ at end deftp 
+
+ at anchor{Variable *store-class-slots*}
+ at vindex *store-class-slots*
+ at deftp {Variable} *store-class-slots* @emph{Default T}
+If @code{*store-class-slots*} is NIL slots which are class allocated will
+not be serialized when storing objects.
+ at end deftp
+
+
+ at anchor{Variable *nuke-existing-packages*}
+ at vindex *nuke-existing-packages*
+ at deftp {Variable} *nuke-existing-packages* @emph{Default NIL}
+If @code{*nuke-existing-packages*} is non-nil then packages which
+already exist will be deleted when restoring packages.
+ at end deftp
+
+ at anchor{Variable *store-used-packages*}
+ at vindex *store-used-packages*
+ at deftp {Variable} *store-used-packages* @emph{Default NIL}
+The variable determines how packages on a package use
+list will be serialized. If non-nil the the package will
+be fully serialized, otherwise only the name will be stored.
+ at end deftp
+
+ at anchor{Variable *store-hash-size*}
+ at vindex *store-hash-size*
+ at deftp {Variable} *store-hash-size* @emph{Default 50}
+The default size of the hash-table created to keep track of
+objects which have already been stored. By binding the 
+variable to a suitable value you can avoid the consing
+involved by rehashing hash-tables.
+ at end deftp
+
+ at anchor{Variable *restore-hash-size*}
+ at vindex *restore-hash-size*
+ at deftp {Variable} *restore-hash-size* @emph{Default 50}
+The default size of the hash-table created to keep track of
+objects which have already been restored. By binding the 
+variable to a suitable value you can avoid the consing
+involved by rehashing hash-tables.
+ at end deftp
+
+
+ at anchor{Variable *check-for-circs*}
+ at vindex *check-for-circs*
+ at deftp {Variable} *check-for-circs* @emph{Default t}
+Binding this variable to nil when storing or restoring
+an object inhibits all checks for circularities which gives a 
+severe boost to performance. The downside of this is that no 
+restored objects will be eq and attempting to store circular objects 
+will hang. The speed improvements are definitely worth it if you 
+know that there will be no circularities or shared references in 
+your data (eg spam-filter hash-tables). 
+ at end deftp
+
+ at anchor{Variable *default-backend*}
+ at vindex *default-backend*
+ at deftp {Variable} *default-backend*
+The backend that will be used by default.
+ at end deftp
+
+
+ at section Functions
+ at anchor{Generic store}
+ at deffn {Generic} store object place &optional (backend *default-backend*)
+Stores @emph{object} into @emph{place} using @emph{backend}. @emph{Place}
+must be either a @code{stream} or a @code{pathname-designator}. All
+conditions signalled from store can be handled by catching @code{store-error}.
+If the @code{store-error} is not handled the causing error will be signalled.
+ at end deffn
+
+ at anchor{Generic restore}
+ at deffn {Generic} restore place &optional (backend *default-backend*)
+Restores an object serialized using @code{store} from @emph{place} using @emph{backend}.
+ at emph{Place} must be either a @code{stream} or a @code{pathname-designator}.
+Restore is setffable eg.
+ at lisp 
+(store 0 "/tmp/counter")
+(incf (restore "/tmp/counter"))
+ at end lisp
+All conditions signalled from restore can be handled by catching @code{restore-error}.
+If the @code{restore-error} is not handled the causing error will be signalled.
+ at end deffn
+
+
+ at anchor{Function find-backend}
+ at deffn {Function} find-backend name &optional (errorp nil)
+Return backup called @emph{name}. If there is no such backend NIL is returned 
+if @emph{errorp} is false, otherwise an error is signalled.
+ at end deffn
+
+ at anchor{Function caused-by}
+ at deffn {Function} caused-by cl-store-error
+Returns the @code{condition} which caused @code{cl-store-error} to be signalled.
+ at end deffn
+
+
+ at section Macros
+ at anchor{Macro with-backend}
+ at deffn {Macro} with-backend backend &body body
+Execute @emph{body} with @code{*default-backend*} bound to the 
+backend designated by @emph{backend}.
+ at end deffn
+
+
+ at section Conditions
+ at anchor{Condition cl-store-error}
+ at deftp {Condition} cl-store-error
+Class Precedence: @code{condition}
+
+Root CL-STORE Condition all errors occuring while storing or restoring
+can be handled by catching @code{cl-store-error}
+ at end deftp
+
+ at anchor{Condition store-error}
+ at deftp {Condition} store-error
+Class Precedence: @code{cl-store-error}
+
+A @code{store-error} will be signalled when an error occurs within
+ at code{store} or @code{multiple-value-store}. The causing error can be
+obtained using @code{(caused-by condition)}
+ at end deftp
+
+ at anchor{Condition restore-error}
+ at deftp {Condition} restore-error
+Class Precedence: @code{cl-store-error}
+
+A @code{restore-error} will be signalled when an error occurs within
+ at code{restore}. The causing error can be obtained using 
+ at code{(caused-by condition)}
+ at end deftp
+
+
+ at node Customizing
+ at chapter Customizing
+
+ at section About Customizing
+Each backend in CL-STORE can be customized to store various values in a 
+custom manner. By using the @code{defstore-<backend-name>} and 
+ at code{defrestore-<backend-name>} macros you can define your own methods for 
+storing various objects. This may require a marginal understanding of the 
+backend you wish to extend.
+
+eg. 
+ at lisp
+(in-package :cl-user)
+
+(use-package :cl-store)
+
+(setf *default-backend* (find-backend 'cl-store))
+
+;; Create the custom class
+(defclass random-obj () ((a :accessor a :initarg :a)))
+
+;; Register random object. This is specific to the
+;; cl-store-backend.
+(defvar *random-obj-code* (register-code 110 'random-obj))
+
+;; Create a custom storing method for random-obj
+;; outputting the code previously registered.
+(defstore-cl-store (obj random-obj stream)
+  (output-type-code *random-obj-code* stream)
+  (store-object (a obj) stream))
+
+;; Define a restoring method.
+(defrestore-cl-store (random-obj stream)
+  (random (restore-object stream)))
+
+;; Test it out.
+(store (make-instance 'random-obj :a 10) "/tmp/random")
+
+(restore "/tmp/random")
+=> ; some number from 0 to 9
+
+ at end lisp
+If you need to get fancier take a look at the macroexpansion of the customizing macros.
+ at vskip 0pt plus 1filll
+
+ at section Customizing API
+
+This API is primarily concerned with the cl-store-backend although other backends 
+will be similar in structure.
+
+ at subsection Functions
+ at anchor{Function register-code}
+ at deffn {Function} register-code code name &optional (errorp t)
+Registers @emph{name} under the code @emph{code} into the cl-store-backend. 
+The backend will use this mapping when restoring values. 
+Will signal an error if code is already registered and @emph{errorp} is not NIL.
+Currently codes 1 through 35 are in use.
+ at end deffn
+
+ at anchor{Function output-type-code}
+ at deffn {Function} output-type-code type-code stream 
+Writes @emph{type-code} into @emph{stream}.
+This must be done when writing out objects so that the type of the
+object can be identified on deserialization.
+ at end deffn
+
+ at anchor{Function store-32-bit}
+ at deffn {Function} store-32-bit integer stream
+Outputs the the low 32 bits from @emph{integer} into @emph{stream}. 
+ at end deffn
+
+ at anchor{Function read-32-bit}
+ at deffn {Function} read-32-bit stream 
+Reads a 32-bit integer from @emph{stream}.
+ at end deffn
+
+ at anchor{Generic store-object} 
+ at deffn {Generic} store-object object place
+Stores @emph{object} into @emph{place}. This should be used inside 
+ at code{defstore-cl-store} to output parts of objects. @code{store} 
+should not be used.
+ at end deffn
+
+ at anchor{Generic restore-object}
+ at deffn {Generic} restore-object place 
+Restore an object, written out using @code{store-object} from @emph{place}. 
+ at end deffn
+
+ at anchor{Generic get-slot-details}
+ at deffn {Generic} get-slot-details slot-definition
+Generic function which returns a list of slots details
+which can be used as an argument to @code{ensure-class}. 
+Currently it is only specialized on slot-definition
+ at end deffn
+
+ at anchor{Generic serializable-slots}
+ at deffn {Generic} serializable-slots object
+Method which returns a list of slot-definition objects
+which will be serialized for @emph{object}. The default 
+is to call @code{serializable-slots-using-class}.
+ at end deffn
+
+ at anchor{Generic serializable-slots-using-class}
+ at deffn {Generic} serializable-slots-using-class object class
+Returns a list of slot-definition objects which will 
+be serialized for object and class. 
+Example.
+When serializing cl-sql objects to disk or to another 
+lisp session the view-database slot should not be serialized.
+Instead of specializing serializable-slots for each view-class
+created you can do this.
+ at lisp
+(defmethod serializable-slots-using-class 
+     ((object t) (class clsql-sys::standard-db-class))
+  (delete 'clsql-sys::view-database (call-next-method)
+          :key 'slot-definition-name))
+ at end lisp
+ at end deffn
+
+
+ at vskip 0pt plus 1filll
+
+ at subsection Macros
+ at anchor{Macro defstore-cl-store}
+ at deffn {Macro} defstore-cl-store (var type stream &key qualifier) &body body
+Create a custom storing mechanism for @emph{type} which must be a legal 
+Class Name. @emph{Body} will be called when an object of class @emph{type}
+is stored using @code{store-object} with @emph{var} bound to the object to
+be stored and @emph{stream} bound to the stream to output to. If @emph{qualifier}
+is given it must be a legal qualifier to @code{defmethod}. 
+Example.
+ at lisp
+(defstore-cl-store (obj ratio stream)
+   (output-type-code +ratio-code+ stream)
+   (store-object (numerator obj) stream)
+   (store-object (denominator obj) stream))
+
+ at end lisp
+ at end deffn
+
+ at anchor{Macro defrestore-cl-store}
+ at deffn {Macro} defrestore-cl-store (type stream) &body body 
+Create a custom restoring mechanism for the @emph{type} 
+registered using @code{register-code}. at emph{Body} will be executed with 
+ at emph{stream} being the input stream to restore an object from. 
+
+Example.
+ at lisp
+(defrestore-cl-store (ratio stream)
+  (/ (restore-object stream)
+     (restore-object stream)))
+ at end lisp
+ at end deffn 
+
+ at anchor{Macro resolving-object}
+ at deffn {Macro} resolving-object (var create) &body body 
+Executes @emph{body} resolving circularities detected in @emph{object}. 
+Resolving-object works by creating a closure, containing code to set a 
+particular place in @emph{object}, which is then pushed onto a list. 
+Once the object has been fully restored all functions on this list are called and the
+circularities are resolved.
+Example.
+ at lisp
+(defrestore-cl-store (cons stream)
+  (resolving-object (object (cons nil nil))
+    (setting (car object) (restore-object stream))
+    (setting (cdr object) (restore-object stream))))
+ at end lisp
+ at end deffn
+
+ at vskip 0pt plus 1filll
+
+ at anchor{Macro setting}
+ at deffn {Macro} setting place get
+This macro can only be used inside @code{resolving-object}. It sets the value 
+designated by @emph{place} to @emph{get} for the object that is being resolved.
+
+Example.
+ at lisp
+(defrestore-cl-store (simple-vector stream)
+  (let* ((size (restore-object stream))
+        (res (make-array size)))
+    (resolving-object (object res)
+     (loop repeat size for i from 0 do
+       ;; we need to copy the index so that
+       ;; it's value is preserved for after the loop.
+       (let ((x i))
+         (setting (aref object x) (restore-object stream)))))
+    res))
+ at end lisp
+ at end deffn
+
+ at anchor{Macro setting-hash}
+ at deffn {Macro} setting-hash getting-key getting-value
+ at code{setting-hash} works identically to setting although it is used
+exclusively on hash-tables due to the fact that both the key and the value
+being restored could be a circular reference. 
+Example.
+ at lisp
+(defrestore-cl-store (hash-table stream)
+  (let ((rehash-size (restore-object stream))
+        (rehash-threshold (restore-object stream))
+        (size (restore-object stream))
+        (test (restore-object stream))
+        (count (restore-object stream)))
+    (let ((hash (make-hash-table :test (symbol-function test)
+                                 :rehash-size rehash-size
+                                 :rehash-threshold rehash-threshold
+                                 :size size)))
+      (resolving-object (obj hash)
+        (loop repeat count do
+              (setting-hash (restore-object stream) 
+                            (restore-object stream))))
+      hash)))
+ at end lisp
+ at end deffn
+
+
+ at node New Backends
+ at chapter New Backends
+
+ at section About
+You can define your own backends in cl-store to do custom object 
+I/O. Theoretically one can add a backend that can do socket
+based communication with any language provided you know the 
+correct format to output objects in. If the framework is not 
+sufficient to add your own backend just drop me a line and 
+we will see what we can do about it.
+
+
+ at section The Process
+
+ at subsection Add the backend
+Use @code{defbackend} to define the new backend choosing the output 
+format, an optional magic number, extra fields for the backend 
+and a backend to extend which defaults to the base backend.
+eg. (from the cl-store-backend)
+ at lisp 
+(defbackend cl-store :magic-number 1347643724
+                :stream-type '(unsigned-byte 8)
+                :old-magic-numbers (1912923 1886611788 1347635532)
+                :extends resolving-backend
+                :fields ((restorers :accessor restorers :initform (make-hash-table))))
+ at end lisp
+
+ at subsection Recognizing Objects.
+Decide how to recognize objects on restoration.
+When restoring objects the backend has a responsibility 
+to return a symbol identifying the @code{defrestore} method
+to call by overriding the @code{get-next-reader} method.
+In the cl-store backend this is done by keeping a mapping of type codes to symbols.
+When storing an object the type code is written down the stream first and then the restoring details for that particular object.
+The @code{get-next-reader} method is then specialized to read the type code and look up the symbol in a hash-table kept
+on the backend. 
+
+eg. (from the cl-store-backend)
+ at lisp
+(defvar *cl-store-backend* (find-backend 'cl-store))
+;; This is a util method to register the code with a symbol
+(defun register-code (code name &optional (errorp t))
+  (aif (and (gethash code (restorers *cl-store-backend*)) errorp)
+       (error "Code ~A is already defined for ~A." code name)
+       (setf (gethash code (restorers *cl-store-backend*))
+             name))
+  code)
+;; An example of registering the code 7 with ratio
+(defconstant +ratio-code+ (register-code 7 'ratio))
+
+;; Extending the get-next-reader method
+(defmethod get-next-reader ((backend cl-store) (stream stream))
+  (let ((type-code (read-type-code stream)))
+    (or (gethash type-code (restorers backend))
+        (values nil (format nil "Type ~A" type-code)))))
+
+(defstore-cl-store (obj ratio stream)
+  (output-type-code +ratio-code+ stream) ;; output the type code
+  (store-object (numerator obj) stream)
+  (store-object (denominator obj) stream))
+
+ at end lisp
+
+
+ at subsection Extending the Resolving backend
+If you are extending the @code{resolving-backend} you have a couple of extra
+responsibilities to ensure that circular references are resolved correctly.
+ at code{Store-referrer} must be extended for your backend to output the referrer
+code. This must be done as if it were a @code{defstore} for a referrer.
+A @code{defrestore-<backend-name>} must also be defined for the referrer which
+must return a referrer created with @code{make-referrer}. Once that is 
+done you can use @code{resolving-object} and @code{setting} to resolve
+circularities in objects.
+
+eg (from the cl-store backend)
+ at lisp
+(defconstant +referrer-code+ (register-code 1 'referrer nil))
+(defmethod store-referrer (ref stream (backend cl-store))
+  (output-type-code +referrer-code+ stream)
+  (store-32-bit ref stream))
+
+(defrestore-cl-store (referrer stream)
+  (make-referrer :val (read-32-bit stream nil)))
+ at end lisp
+
+ at section Example: Simple Pickle Format
+As a short example we will define a backend that can handle simple objects 
+using the python pickle format.
+
+ at subsection Define the backend
+ at lisp
+(in-package :cl-user)
+(use-package :cl-store)
+
+(defbackend pickle :stream-type 'character)
+ at end lisp
+ at vskip 0pt plus 2filll
+
+ at subsection Recognize Objects
+This is just a simple example to be able to handle single strings
+stored with Python's pickle module. 
+
+ at lisp
+(defvar *pickle-mapping*
+  '((#\S . string)))
+
+(defmethod get-next-reader ((backend pickle) (stream stream))
+  (let ((type-code (read-char stream)))
+    (or (cdr (assoc type-code *pickle-mapping*))
+        (values nil (format nil "Type ~A" type-code)))))
+
+(defrestore-pickle (noop stream))
+
+(defstore-pickle (obj string stream)
+  (format stream "S'~A'~%p0~%." obj))
+
+(defrestore-pickle (string stream)
+  (let ((val (read-line stream)))
+    (read-line stream) ;; remove the PUSH op
+    (read-line stream) ;; remove the END op
+    (subseq val 1 (1- (length val)))))
+ at end lisp
+
+ at subsection Test the new Backend.
+This can be tested with the code
+ at lisp
+Python
+>>> import pickle
+>>> pickle.dump('Foobar', open('/tmp/foo.p', 'w'))
+
+Lisp
+* (cl-store:restore "/tmp/foo.p" 'pickle)
+=> "Foobar"
+And 
+
+Lisp 
+* (cl-store:store "BarFoo" "/tmp/foo.p" 'pickle)
+
+Python
+>>> pickle.load(open('/tmp/foo.p'))
+'BarFoo'
+ at end lisp
+
+ at vskip 0pt plus 2filll
+
+ at section API
+
+ at subsection Functions
+ at anchor{Generic backend-restore}
+ at deffn {Generic} backend-restore backend place
+Restore the object found in stream @emph{place} using backend @emph{backend}.
+Checks the magic-number and invokes @code{backend-restore-object}. Called by @code{restore}, override
+for custom restoring.
+ at end deffn
+
+ at anchor{Generic backend-restore-object}
+ at deffn {Generic} backend-restore backend place
+Find the next function to call to restore the next object with  @emph{backend} and invoke it with @emph{place}.
+Called by @code{restore-object}, override this method to do custom restoring (see @file{circularities.lisp}
+for an example).
+ at end deffn
+
+ at anchor{Generic backend-store}
+ at deffn {Generic} backend-store backend place obj
+Stores the backend code and calls @code{store-object}. This is called by @code{store}. Override for 
+custom storing.
+ at end deffn
+
+ at anchor{Generic backend-store-object}
+ at deffn {Generic} backend-store-object backend obj place
+Called by @code{store-object}, override this to do custom storing 
+(see @file{circularities.lisp} for an example). 
+ at end deffn
+
+ at anchor{Generic get-next-reader}
+ at deffn {Generic} get-next-reader backend place
+Method which must be specialized for @emph{backend} to return the next symbol
+designating a @code{defrestore} instance to restore an object from @emph{place}.
+If no reader is found return a second value which will be included in the error.
+ at end deffn
+
+ 
+ at subsection Macros
+ at anchor{Macro defbackend}
+ at deffn {Macro} defbackend name &key (stream-type (required-arg "stream-type")) magic-number fields (extends 'backend) old-magic-numbers 
+eg. @code{(defbackend pickle :stream-type 'character)}
+This creates a new backend called @emph{name}, @emph{stream-type} describes the type of stream that the
+backend will serialize to which must be suitable as an argument to open. @emph{Magic-number}, when present, must be of type
+(unsigned-byte 32) which will be written as a verifier for the backend. @emph{Fields} are extra fields to be 
+added to the new class which will be created. By default the @emph{extends} keyword is @emph{backend},the root backend, but
+this can be any legal backend. @emph{Old-magic-numbers} holds previous magic-numbers that have been used by the backend
+to identify incompatible versions of objects stored.
+ at end deffn
+
+ at node Notes
+ at chapter Notes
+
+ at section Backend Designators
+The @emph{backend} argument to store, restore and with-backend 
+is a backend designator which can be one of.
+ at itemize @bullet
+ at item A backend returned by @code{(find-backend name)}
+ at item A symbol designating a backend (the first argument to defbackend).
+ at end itemize
+
+ at section Known Issues
+ at itemize @bullet
+ at item  CLISP, OpenMCL, Allegro CL cannot store structure instances.
+ at item  Structure definitions are only supported in SBCL and CMUCL.
+ at item  Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized.
+ at end itemize
+
+ at section Delivery with Lispworks
+Restoring lists in delivered images can be problematic since the tree shaker
+can remove the symbol cl:nil (this seems to only happen with delivery-level > 4). 
+To work around this add the following keywords to the delivery call.
+ at lisp
+  :packages-to-keep '(:cl)
+  :keep-symbols '(cl:nil)
+ at end lisp
+
+ at section Regarding String Serialization
+Users are required to be extremely careful when serializing strings from one
+lisp implementation to another since the array-element-type will be tracked
+for strings and the Hyperspec does not specify an upper limit for base-chars.
+This can be a problem if you serialize a simple-base-string containing wide 
+characters, in an implementation which specifies no limit on base-char, 
+to an implementation with a limit.
+If you have a solution I would be happy to hear it.
+
+ at node Credits
+ at chapter Credits
+Thanks To
+ at itemize @bullet
+ at item Common-Lisp.net: For project hosting.
+ at item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks.
+ at item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends.
+ at item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements.
+ at item Killian Sprotte: Type specification fixups.
+ at end itemize
+
+ at node Index
+ at chapter Index
+
+ at section Function Index
+ at printindex fn
+
+ at section Variable Index
+ at printindex vr
+
+ at bye

Added: trunk/thirdparty/cl-store_0.8.4/doc/index.html
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/doc/index.html	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,40 @@
+<?xml version="1.0"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title>CL-STORE</title>
+ <link rel="stylesheet" type="text/css" href="style.css"/>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
+</head>
+
+<body>
+ <div class="header">
+  <h1>CL-STORE</h1>
+  <h2>A Common Lisp Serialization Package</h2>
+ </div>
+ 
+   
+ <h2>Documentation</h2>
+  <ul>
+   <li>Basic details can be found in the <a href="../README">README</a> file.</li>
+   <li><a href="cl-store.texi">Texinfo Manual</a></li>
+   <li>List of <a href="../ChangeLog">Changes</a></li>
+  </ul>
+ 
+
+ <h2>When things break (or don't work as expected)</h2>
+  <ul>
+   <li>Try a <a href="http://www.common-lisp.net/mailman/listinfo/cl-store-devel">mailing list</a></li>
+   <li>Drop <a href="mailto:sross at common-lisp.net">me</a> a line</li>
+  </ul>
+ 
+ 
+   <div class="footer">
+    <address>sross at common-lisp.net</address>
+   </div>
+
+
+ </body>
+
+</html>

Added: trunk/thirdparty/cl-store_0.8.4/doc/style.css
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/doc/style.css	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,77 @@
+
+.header {
+	font-size: medium;
+    background-color:#00396D;
+	color:#E9B800;
+	border-style:solid;
+	border-width: 5px;
+	border-color:#002244;
+	padding: 1mm 1mm 1mm 5mm;
+}
+.about {
+	font-size: large;
+	border-style:solid;
+	border-width: 0px;
+	border-color:#00396D;
+}
+
+
+.code {
+    font-family: monospace;
+	border-style:solid;
+	border-width: 5px;
+	border-color:#00396D;
+}
+
+
+.footer {
+	font-size: small;
+	font-style: italic;
+	text-align: right;
+	background-color:#00396D;
+	color:#ffffff;
+	border-style:solid;
+	border-width: 2px;
+	border-color:#002244;
+	padding: 1mm 1mm 1mm 1mm;
+}
+
+a:link, a:visited {
+  text-decoration: none; 
+}
+
+a:hover, a:active { 
+  text-decoration: underline; 
+}
+
+.footer a:link {
+	font-weight:bold;
+	color:#ffffff;
+	text-decoration:underline;
+}
+
+.footer a:visited {
+	font-weight:bold;
+	color:#ffffff; 
+	text-decoration:underline;
+}
+
+.footer a:hover { 
+	font-weight:bold; 
+	color:#002244; 
+	text-decoration:underline; }
+
+.check {font-size: x-small;
+	text-align:right;}
+
+.check a:link { font-weight:bold;
+		color:#a0a0ff;
+		text-decoration:underline; }
+
+.check a:visited { font-weight:bold;
+		   color:#a0a0ff;
+		   text-decoration:underline; }
+
+.check a:hover { font-weight:bold;
+		 color:#000000;
+		 text-decoration:underline; }

Added: trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/ecl/mop.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,29 @@
+(in-package :cl-store)
+
+(defun slot-definition-name (slot)
+  (nth 0 slot))
+
+(defun slot-definition-allocation (slot)
+  (nth 6 slot))
+
+(defun slot-definition-initform (slot)
+  (nth 2 slot))
+
+(defun slot-definition-initargs (slot)
+  (nth 1 slot))
+
+(defun slot-accessors (slot)
+  (nth 3 slot))
+
+(defun slot-definition-writers (slot)
+  (append (slot-accessors slot)
+          (nth 5 slot)))
+
+(defun slot-definition-readers (slot)
+  (append (slot-accessors slot)
+          (nth 4 slot)))
+
+(defun slot-definition-type (slot)
+  (nth 7 slot))
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/licence
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/licence	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,26 @@
+Copyright (c) 2004 Sean Ross
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. The names of the authors and contributors may not be used to endorse 
+   or promote products derived from this software without specific prior 
+   written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

Added: trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/lispworks/custom-xml.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,63 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store-xml)
+
+(defstore-xml (obj structure-object stream)
+  (with-tag ("STRUCTURE-OBJECT" stream)
+    (princ-and-store "CLASS" (type-of obj) stream)
+    (let ((slots (structure:structure-class-slot-names (class-of obj))))
+      (with-tag ("SLOTS" stream)
+        (dolist (slot-name slots)
+          (with-tag ("SLOT" stream)
+            (princ-and-store "NAME" slot-name stream)
+            (princ-and-store "VALUE" (slot-value obj slot-name) stream)))))))
+
+(defrestore-xml (structure-object place)
+  (let* ((class (find-class (restore-first (get-child "CLASS" place))))
+         (new-instance (structure::allocate-instance class)))
+    (resolving-object new-instance
+      (dolist (slot (xmls:node-children (get-child "SLOTS" place)))
+        (let ((slot-name (restore-first (get-child "NAME" slot))))
+          (setting (slot-value slot-name) 
+                   (restore-first (get-child "VALUE" slot))))))))
+
+
+
+(defstore-xml (obj float stream)
+  (block body
+    (handler-bind ((simple-error
+                    #'(lambda (err)
+                        (declare (ignore err))
+                        (cond
+                         ((cl-store::positive-infinity-p obj)
+                          (with-tag ("POSITIVE-INFINITY" stream))
+                          (return-from body)) 
+                         ((cl-store::negative-infinity-p obj)
+                          (with-tag ("NEGATIVE-INFINITY" stream))
+                          (return-from body))
+                         ((cl-store::float-nan-p obj)
+                          (with-tag ("FLOAT-NAN" stream))
+                          (return-from body))
+                         (t nil)))))
+        (multiple-value-bind (signif exp sign) 
+            (integer-decode-float obj)
+          (with-tag ("FLOAT" stream)
+            (princ-and-store "SIGNIFICAND" signif stream)
+            (princ-and-store "EXPONENT" exp stream)
+            (princ-and-store "SIGN" sign stream)
+            (princ-and-store "TYPE" (float-type obj) stream))))))
+
+(defrestore-xml (positive-infinity stream)
+  (declare (ignore stream))
+  cl-store::+positive-infinity+)
+
+(defrestore-xml (negative-infinity stream)
+  (declare (ignore stream))
+  cl-store::+negative-infinity+)
+
+(defrestore-xml (float-nan stream)
+  (declare (ignore stream))
+  cl-store::+nan-float+)
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/lispworks/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,37 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+;; Special float handling
+(defun create-float-values (value &rest codes)
+  (let ((neg-inf (expt value 3)))
+    (mapcar 'cons
+            (list (expt (abs value) 2)
+                  neg-inf
+                  (/ neg-inf neg-inf))
+            codes)))
+
+;; Custom structure storing from Alain Picard.
+(defstore-cl-store (obj structure-object stream)
+  (output-type-code +structure-object-code+ stream)
+  (let* ((slot-names (structure:structure-class-slot-names (class-of obj))))
+    (store-object (type-of obj) stream)
+    (store-object (length slot-names) stream)
+    (dolist (slot-name slot-names)
+      (store-object slot-name stream)
+      (store-object (slot-value obj slot-name) stream))))
+
+(defrestore-cl-store (structure-object stream)
+  (let* ((class (find-class (restore-object stream)))
+         (length (restore-object stream))
+         (new-instance (structure::allocate-instance class)))
+    (loop repeat length do
+          (let ((slot-name (restore-object stream)))
+            ;; slot-names are always symbols so we don't
+            ;; have to worry about circularities
+            (resolving-object (obj new-instance)
+              (setting (slot-value obj slot-name) (restore-object stream)))))
+    new-instance))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/openmcl/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,13 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+(in-package :cl-store)
+
+(defstore-cl-store (obj structure-object stream)
+ (output-type-code +structure-object-code+ stream)
+ (store-type-object obj stream))
+
+(defrestore-cl-store (structure-object stream)
+  (restore-type-object stream))
+
+
+; EOF

Added: trunk/thirdparty/cl-store_0.8.4/package.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/package.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,200 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;(in-package :cl-store.system)
+
+(defpackage #:cl-store
+  (:use #:cl) 
+  (:export #:backend #:magic-number #:stream-type
+           #:restorers #:resolving-backend #:find-backend #:defbackend
+           #:*restore-counter* #:*need-to-fix* #:*restored-values*
+           #:with-backend #:*default-backend*
+           #:*current-backend* #:*store-class-slots*
+           #:*nuke-existing-classes* #:*store-class-superclasses*
+           #:cl-store-error #:store-error #:restore-error #:store
+           #:restore #:backend-store #:store-backend-code #:store-object
+           #:backend-store-object 
+           #:restore #:backend-restore #:cl-store #:referrerp
+           #:check-magic-number #:get-next-reader #:int-or-char-p
+           #:restore-object #:backend-restore-object #:serializable-slots
+           #:defstore-cl-store #:defrestore-cl-store #:register-code
+           #:output-type-code #:store-referrer #:resolving-object
+           #:internal-store-object #:setting #:simple-standard-string
+           #:float-type #:get-float-type #:make-referrer #:setting-hash
+           #:multiple-value-store #:caused-by
+           #:store-32-bit #:read-32-bit #:*check-for-circs*
+           #:*store-hash-size* #:*restore-hash-size* #:get-slot-details
+           #:*store-used-packages* #:*nuke-existing-packages*
+           #:serializable-slots-using-class
+
+           ;; Hooks into lower level circularity tracking
+           ;; to reduce consing.
+           #:with-serialization-unit #:create-serialize-hash
+
+           #:alias-backend)
+  
+  #+sbcl (:import-from #:sb-mop
+                       #:generic-function-name
+                       #:slot-definition-allocation
+                       #:slot-definition
+                       #:compute-slots
+                       #:slot-definition-initform
+                       #:slot-definition-initargs
+                       #:slot-definition-name
+                       #:slot-definition-readers
+                       #:slot-definition-type
+                       #:slot-definition-writers
+                       #:class-direct-default-initargs
+                       #:class-direct-slots
+                       #:class-direct-superclasses
+                       #:class-slots
+                       #:ensure-class)
+
+  #+ecl (:import-from #:clos
+                      #:generic-function-name
+                      #:compute-slots
+                      #:class-direct-default-initargs
+                      #:class-direct-slots
+                      #:class-direct-superclasses
+                      #:class-slots
+                      #:ensure-class)
+  
+  #+cmu  (:import-from #:pcl
+                       #:generic-function-name
+                       #:slot-definition-allocation
+                       #:compute-slots
+                       #:slot-definition
+                       #:slot-definition-initform
+                       #:slot-definition-initargs
+                       #:slot-definition-name
+                       #:slot-definition-readers
+                       #:slot-definition-type
+                       #:slot-definition-writers
+                       #:class-direct-default-initargs
+                       #:class-direct-slots
+                       #:class-direct-superclasses
+                       #:class-slots
+                       #:ensure-class)
+  
+  #+cmu (:shadowing-import-from #:pcl
+                                #:class-name
+                                #:find-class
+                                #:standard-class
+                                #:class-of)
+  
+  #+openmcl (:import-from #:openmcl-mop
+                          #:generic-function-name
+                          #:slot-definition-allocation
+                          #:compute-slots
+                          #:slot-definition
+                          #:slot-definition-initform
+                          #:slot-definition-initargs
+                          #:slot-definition-name
+                          #:slot-definition-readers
+                          #:slot-definition-type
+                          #:slot-definition-writers
+                          #:class-direct-default-initargs
+                          #:class-direct-slots
+                          #:class-direct-superclasses
+                          #:class-slots
+                          #:ensure-class)
+
+  #+digitool (:import-from #:ccl
+                           #:generic-function-name
+                           #:slot-definition-allocation
+                           #:compute-slots
+                           #:slot-definition
+                           #:slot-definition-initform
+                           #:slot-definition-initargs
+                           #:slot-definition-name
+                           #:slot-definition-readers
+                           #:slot-definition-type
+                           #:slot-definition-writers
+                           #:class-direct-default-initargs
+                           #:class-direct-slots
+                           #:class-direct-superclasses
+                           #:class-slots
+                           #:ensure-class)
+  
+  #+(and clisp (not mop)) (:import-from #:clos
+                        #:slot-value
+                        #:std-compute-slots
+                        #:slot-boundp
+                        #:class-name
+                        #:class-direct-default-initargs
+                        #:class-direct-slots
+                        #:class-slots
+                        #:ensure-class)
+  
+  #+lispworks (:import-from #:clos
+               #:generic-function-name
+               #:slot-definition-allocation
+               #:compute-slots
+               #:slot-definition
+               #:slot-definition-initform
+               #:slot-definition-initargs
+               #:slot-definition-name
+               #:slot-definition-readers
+               #:slot-definition-type
+               #:slot-definition-writers
+               #:class-direct-default-initargs
+               #:class-direct-slots
+               #:class-slots
+               #:class-direct-superclasses
+               #:ensure-class)
+
+  #+(and clisp mop) (:import-from #:clos
+                     #:generic-function-name
+                     #:slot-definition-allocation
+                     #:compute-slots
+                     #:slot-definition
+                     #:slot-definition-initform
+                     #:slot-definition-initargs
+                     #:slot-definition-name
+                     #:slot-definition-readers
+                     #:slot-definition-type
+                     #:slot-definition-writers
+                     #:class-direct-default-initargs
+                     #:class-direct-slots
+                     #:class-slots
+                     #:class-direct-superclasses
+                     #:ensure-class)
+  
+  #+allegro (:import-from #:mop
+                          #:generic-function-name
+                          #:slot-definition-allocation
+                          #:slot-definition
+                          #:compute-slots
+                          #:slot-definition-initform
+                          #:slot-definition-initargs
+                          #:slot-definition-name
+                          #:slot-definition-readers
+                          #:slot-definition-type
+                          #:slot-definition-writers
+                          #:class-direct-default-initargs
+                          #:class-direct-slots
+                          #:class-direct-superclasses
+                          #:class-slots
+                          #:ensure-class)
+  #+abcl (:import-from #:mop
+
+                       ;; All the commented out methods are defined in
+                       ;; abcl/custom.lisp
+                       
+                       #:generic-function-name
+                       ;;#:slot-definition-allocation
+                       #:slot-definition
+                       #:compute-slots
+                       ;;#:slot-definition-initform
+                       ;;#:slot-definition-initargs
+                       ;;#:slot-definition-name
+                       ;;#:slot-definition-readers
+                       ;;#:slot-definition-type
+                       ;;#:slot-definition-writers
+                       #:class-direct-default-initargs
+                       #:class-direct-slots
+                       #:class-direct-superclasses
+                       ; #:class-slots
+                       #:ensure-class)
+  )
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/plumbing.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/plumbing.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,222 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information 
+
+;;  The framework where everything hangs together.
+;; 
+
+(in-package :cl-store)
+
+(defvar *store-used-packages* nil
+  "If non-nil will serialize each used package otherwise will
+only store the package name")
+(defvar *nuke-existing-packages* nil
+  "Whether or not to overwrite existing packages on restoration.")
+(defvar *nuke-existing-classes* nil
+  "Do we overwrite existing class definitions on restoration.")
+(defvar *store-class-superclasses* nil
+  "Whether or not to store the superclasses of a stored class.")
+(defvar *store-class-slots* t
+  "Whether or not to serialize slots which are class allocated.")
+
+(declaim (type backend *default-backend* *current-backend*))
+(defvar *default-backend*)
+(defvar *current-backend*)
+
+
+;; conditions
+;; From 0.2.3 all conditions which are signalled from 
+;; store or restore will signal a store-error or a 
+;; restore-error respectively inside a handler-bind.
+(defun cl-store-report (condition stream)
+  (declare (stream stream))
+  (aif (caused-by condition)
+       (format stream "~A" it)
+       (apply #'format stream (format-string condition) 
+              (format-args condition))))
+
+(define-condition cl-store-error (error)
+  ((caused-by :accessor caused-by :initarg :caused-by 
+              :initform nil)
+   (format-string :accessor format-string :initarg :format-string 
+                  :initform "Unknown")
+   (format-args :accessor format-args :initarg :format-args :initform nil))
+  (:report cl-store-report)
+  (:documentation "Root cl-store condition"))
+
+(define-condition store-error (cl-store-error)
+  ()
+  (:documentation "Error thrown when storing an object fails."))
+
+(define-condition restore-error (cl-store-error)
+  ()
+  (:documentation "Error thrown when restoring an object fails."))
+
+(defun store-error (format-string &rest args)
+  (error 'store-error :format-string format-string :format-args args))
+
+(defun restore-error (format-string &rest args)
+  (error 'restore-error :format-string format-string :format-args args))
+
+
+;; entry points
+(defun store-to-file (obj place backend)
+  (declare (type backend backend)
+           (optimize speed))
+  (let ((element-type (stream-type backend)))
+    (with-open-file (s place :element-type element-type
+                       :direction :output :if-exists :supersede)
+      (backend-store backend s obj))))
+
+(defgeneric store (obj place &optional designator) 
+  (:documentation "Store OBJ into Stream PLACE using backend BACKEND.")
+  (:method ((obj t) (place t) &optional (designator *default-backend*))
+   "Store OBJ into Stream PLACE using backend BACKEND."
+   (declare (optimize speed))
+   (let* ((backend (backend-designator->backend designator))
+          (*current-backend* backend)
+          (*read-eval* nil))
+     (handler-bind ((error (lambda (c)
+                             (signal 'store-error :caused-by c))))
+       (backend-store backend place obj)))))
+
+
+(defgeneric backend-store (backend place obj)
+  (:method ((backend backend) (place stream) (obj t))
+    "The default. Checks the streams element-type, stores the backend code
+     and calls store-object."
+    (declare (optimize speed))
+    (store-backend-code backend place)
+    (store-object obj place backend)
+    obj)
+  (:method ((backend backend) (place string) (obj t))
+    "Store OBJ into file designator PLACE."
+    (store-to-file obj place backend))
+  (:method ((backend backend) (place pathname) (obj t))
+    "Store OBJ into file designator PLACE."
+    (store-to-file obj place backend))
+  (:documentation "Method wrapped by store, override this method for 
+    custom behaviour (see circularities.lisp)."))
+
+(defgeneric store-backend-code (backend stream)
+  (:method ((backend backend) (stream t))
+    (declare (optimize speed))
+    (when-let (magic (magic-number backend))
+      (store-32-bit magic stream)))
+  (:documentation 
+   "Store magic-number of BACKEND, when present, into STREAM."))
+
+(defun store-object (obj stream &optional (backend *current-backend*))
+  "Store OBJ into STREAM. Not meant to be overridden, 
+   use backend-store-object instead"
+  (backend-store-object backend obj stream))
+
+(defgeneric backend-store-object (backend obj stream)
+  (:documentation
+   "Wrapped by store-object, override this to do custom storing 
+   (see circularities.lisp for an example).")
+  (:method ((backend backend) (obj t) (stream t))
+    "The default, just calls internal-store-object."
+    (declare (optimize speed))
+    (internal-store-object backend obj stream)))
+
+
+(defgeneric internal-store-object (backend obj place)
+  (:documentation "Method which is specialized by defstore-? macros.")
+  (:method ((backend backend) (obj t) (place t))
+    "If call falls back here then OBJ cannot be serialized with BACKEND."
+    (store-error "Cannot store objects of type ~A with backend ~(~A~)."
+                 (type-of obj) (name backend))))
+
+;; restoration
+(defgeneric restore (place &optional backend)
+  (:documentation 
+   "Restore and object FROM PLACE using BACKEND. Not meant to be 
+   overridden, use backend-restore instead")
+  (:method (place &optional (designator *default-backend*))
+    "Entry point for restoring objects (setfable)."
+    (declare (optimize speed))
+    (let* ((backend (backend-designator->backend designator))
+           (*current-backend* backend)
+           (*read-eval* nil))
+      (handler-bind ((error (lambda (c)
+                              (signal 'restore-error :caused-by c))))
+        (backend-restore backend place)))))
+
+  
+(defgeneric backend-restore (backend place)
+  (:documentation "Wrapped by restore. Override this to do custom restoration")
+  (:method ((backend backend) (place stream))
+    "Restore the object found in stream PLACE using backend BACKEND.
+     Checks the magic-number and invokes backend-restore-object"
+    (declare (optimize speed))
+    (check-magic-number backend place)
+    (backend-restore-object backend place))
+  (:method ((backend backend) (place string))
+    "Restore the object found in file designator PLACE using backend BACKEND."
+    (restore-from-file place backend))
+  (:method ((backend backend) (place pathname))
+    "Restore the object found in file designator PLACE using backend BACKEND."
+    (restore-from-file place backend)))
+
+(defun restore-from-file (place backend)
+  (declare (optimize speed))
+  (let ((element-type (stream-type backend)))
+    (with-open-file (s place :element-type element-type :direction :input)
+      (backend-restore backend s))))
+     
+(defun (setf restore) (new-val place &optional (backend *default-backend*))
+  (store new-val place backend))
+
+(defgeneric check-magic-number (backend stream)
+  (:method ((backend backend) (stream t))
+    (let ((magic-number (magic-number backend)))
+      (declare (type (or null ub32) magic-number))
+      (when magic-number
+        (let ((val (read-32-bit stream nil)))
+          (declare (type ub32 val))
+          (cond ((= val magic-number) nil)
+                ((member val (compatible-magic-numbers backend))
+                 nil)
+                ((member val (old-magic-numbers backend))
+                 (restore-error "Stream contains an object stored with an ~
+incompatible version of backend ~A." (name backend)))
+                (t (restore-error "Stream does not contain a stored object~
+ for backend ~A."
+                                  (name backend))))))))
+  (:documentation   
+   "Check to see if STREAM actually contains a stored object for BACKEND."))
+
+(defun lookup-reader (val readers)
+  (gethash val readers))
+
+(defgeneric get-next-reader (backend place)
+  (:documentation 
+   "Method which must be specialized for BACKEND to return 
+   the next function to restore an object from PLACE.
+   If no reader is found return a second value which will be included 
+   in the error.")
+  (:method ((backend backend) (place t))
+   (declare (ignore place))
+    "The default, throw an error."
+    (restore-error "get-next-reader must be specialized for backend ~(~A~)."
+                   (name backend))))
+
+;; Wrapper for backend-restore-object so we don't have to pass
+;; a backend object around all the time
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun restore-object (place &optional (backend *current-backend*))
+    "Restore the object in PLACE using BACKEND"
+    (backend-restore-object backend place)))
+
+(defgeneric backend-restore-object (backend place)
+  (:documentation
+   "Find the next function to call with BACKEND and invoke it with PLACE.")
+  (:method ((backend backend) (place t))
+    "The default"
+    (internal-restore-object backend (get-next-reader backend place) place)))
+
+(defgeneric internal-restore-object (backend type place))
+
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/readme
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/readme	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,62 @@
+README for Package CL-STORE.
+Author: Sean Ross 
+Homepage: http://www.common-lisp.net/project/cl-store/
+Version: 0.6
+
+0. About.
+   CL-STORE is an portable serialization package which 
+   should give you the ability to store all common-lisp
+   data types (well not all yet) into streams.
+   See the cl-store manual (docs/cl-store.texi) for more in depth information.
+   
+   !!! NOTE: The cl-store-xml backend is deprecated.
+
+1. Usage
+   The main entry points are 
+    - [Method] cl-store:store (obj place &optional (backend *default-backend*)) 
+          => obj
+       Where place is a path designator or stream and
+       backend is one of the registered backends.
+
+    - [Method] cl-store:restore (place &optional (backend *default-backend*)) 
+          => restored-objects
+       Where place and backend is as above.
+
+    - cl-store:restore is setfable, which I think makes
+      for a great serialized hit counter.
+      eg. (incf (restore place))
+  
+    NOTE.
+     All errors signalled within store and restore can 
+     be handled by catching store-error and restore-error respectively.
+
+2. Optimizing.
+    
+   While cl-store is generally quickish it still has a tendency to 
+   do a lot of consing. Thanks to profilers this has been pinned down 
+   to the rehashing of the hash-tables which track object circularities.
+   From 0.4.0 cl-store has three new variables *store-hash-size*, *restore-hash-size*
+   and *check-for-circs*, proper usage of these new variables can greatly reduce
+   the consing (and time taken) when storing and restoring large objects.
+  
+   - *store-hash-size* and *restore-hash-size
+     At the beginning of storing and restoring an eq hash-table is created with a 
+     default size of 50 to track objects which have been (re)stored. On large objects however
+     the rehashing of these hash-tables imposes a severe drain on performance.
+     By binding these two variables to appropriately large values 
+     about (100010 for a hash-table with 100000 int->string mappings) you
+     can obtain a decent performance improvement. This may require a bit 
+     of fiddling to find the best tradeoff between rehashing and creating 
+     a large hash-table.
+ 
+   - *check-for-circs*
+     Binding this variable to nil when storing or restoring
+     an object inhibits all checks for circularities which gives a 
+     severe boost to performance. The downside of this is that no 
+     restored objects will be eq and attempting to store circular objects 
+     will hang. The speed improvements are definitely worth it if you 
+     know that there will be no circularities or shared references in 
+     your data (eg spam-filter hash-tables). 
+
+Enjoy
+ Sean.

Added: trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/sbcl/custom-xml.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,38 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store-xml)
+
+
+(defstore-xml (obj structure-object stream)
+  (with-tag ("STRUCTURE-OBJECT" stream)
+    (princ-and-store "CLASS" (type-of obj) stream)
+    (xml-dump-type-object obj stream)))
+
+
+(defrestore-xml (structure-object place)
+  (restore-xml-type-object place))
+
+
+(defstore-xml (obj single-float stream)
+  (with-tag ("SINGLE-FLOAT" stream)
+    (princ-and-store "BITS" (sb-kernel::single-float-bits obj)
+                     stream)))
+
+(defrestore-xml (single-float stream)
+  (sb-kernel::make-single-float
+   (restore-first (get-child "BITS" stream))))
+
+(defstore-xml (obj double-float stream)
+  (with-tag ("DOUBLE-FLOAT" stream)
+    (princ-and-store "HIGH-BITS" (sb-kernel::double-float-high-bits obj)
+                     stream)
+    (princ-and-store "LOW-BITS" (sb-kernel::double-float-low-bits obj)
+                     stream)))
+
+(defrestore-xml (double-float stream)
+  (sb-kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream))
+                                (restore-first (get-child "LOW-BITS" stream))))
+         
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/sbcl/custom.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,162 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store)
+
+; special floats
+(defun create-float-values (value &rest codes)
+  "Returns a alist of special float to float code mappings."
+  (sb-int:with-float-traps-masked (:overflow :invalid)
+    (let ((neg-inf (expt value 3)))
+      (mapcar 'cons
+              (list (expt (abs value) 2)
+                    neg-inf
+                    (/ neg-inf neg-inf))
+              codes))))
+
+;; Custom structure storing
+
+(defstore-cl-store (obj structure-object stream)
+  (output-type-code +structure-object-code+ stream)
+  (store-type-object obj stream))
+
+(defrestore-cl-store (structure-object stream)
+  (restore-type-object stream))
+
+
+;; Structure definition storing
+(defun get-layout (obj)
+  (slot-value obj 'sb-pcl::wrapper))
+
+(defun get-info (obj)
+  (declare (type sb-kernel:layout obj))
+  (slot-value obj 'sb-int:info))
+
+(defun dd-name (dd)
+  (slot-value dd 'sb-kernel::name))
+
+(defvar *sbcl-struct-inherits*
+  `(,(get-layout (find-class t))
+    ,@(when-let (class (find-class 'sb-kernel:instance nil))
+        (list (get-layout class)))
+    ,(get-layout (find-class 'cl:structure-object))))
+
+(defstruct (struct-def (:conc-name sdef-))
+  (supers (required-arg :supers) :type list)
+  (info (required-arg :info) :type sb-kernel:defstruct-description))
+
+(defun info-or-die (obj)
+  (let ((wrapper (get-layout obj)))
+    (if wrapper
+        (or (get-info wrapper) 
+            (store-error "No defstruct-definition for ~A." obj))
+        (store-error "No wrapper for ~A." obj))))
+
+(defun save-able-supers (obj)
+  (set-difference (coerce (slot-value (get-layout obj) 'sb-kernel::inherits)
+                          'list)
+                  *sbcl-struct-inherits*))
+
+(defun get-supers (obj)
+  (loop for x in (save-able-supers obj) 
+     collect (let ((name (dd-name (get-info x))))
+               (if *store-class-superclasses* 
+                   (find-class name)
+                   name))))
+
+(defstore-cl-store (obj structure-class stream)
+  (output-type-code +structure-class-code+ stream)
+  (store-object (make-struct-def :info (info-or-die obj)
+                                 :supers (get-supers obj))
+                stream))
+
+(defstore-cl-store (obj struct-def stream)
+  (output-type-code +struct-def-code+ stream)
+  (store-object (sdef-supers obj) stream)
+  (store-object (sdef-info obj) stream))
+
+;; Restoring 
+(defun sbcl-struct-defs (info)
+  (append (sb-kernel::constructor-definitions info)
+          (sb-kernel::class-method-definitions info)))
+
+(defun create-make-foo (dd)
+  (declare (optimize speed))
+  (funcall (compile nil `(lambda () ,@(sbcl-struct-defs dd))))
+  (find-class (dd-name dd)))
+
+;;; with apologies to christophe rhodes ...
+;; takes a source location as a third argument.
+(eval-when (:compile-toplevel)
+  (defun split (string &optional max (ws '(#\Space #\Tab)))
+    (flet ((is-ws (char) (find char ws)))
+      (nreverse
+       (let ((list nil) (start 0) (words 0) end)
+         (loop
+          (when (and max (>= words (1- max)))
+            (return (cons (subseq string start) list)))
+          (setf end (position-if #'is-ws string :start start))
+          (push (subseq string start end) list)
+          (incf words)
+          (unless end (return list))
+          (setf start (1+ end))))))))
+
+;; From 0.9.6.25 sb-kernel::%defstruct
+;; takes a source location as a third argument.
+(eval-when (:compile-toplevel)
+  (labels ((make-version (string)
+             (map-into (make-list 4 :initial-element 0)
+                       #'(lambda (part)
+                           (parse-integer part :junk-allowed t))
+                       (split string nil '(#\.))))
+           (version>= (v1 v2)
+             (loop for x in (make-version v1)
+                   for y in (make-version v2)
+                   when (> x y) :do (return t)
+                   when (> y x) :do (return nil)
+                   finally (return t))))
+    (when (version>= (lisp-implementation-version)
+                     "0.9.6.25")
+      (pushnew :defstruct-has-source-location *features*))))
+
+(defun sb-kernel-defstruct (dd supers source)
+  (declare (ignorable source))
+  #+defstruct-has-source-location 
+  (sb-kernel::%defstruct dd supers source)
+  #-defstruct-has-source-location
+  (sb-kernel::%defstruct dd supers))
+
+(defun sbcl-define-structure (dd supers)
+  (cond ((or *nuke-existing-classes*  
+             (not (find-class (dd-name dd) nil)))
+         ;; create-struct
+         (sb-kernel-defstruct dd supers nil)
+         ;; compiler stuff
+         (sb-kernel::%compiler-defstruct dd supers) 
+         ;; create make-?
+         (create-make-foo dd))
+        (t (find-class (dd-name dd)))))
+         
+(defun super-layout (super)
+  (etypecase super
+    (symbol (get-layout (find-class super)))
+    (structure-class 
+     (super-layout (dd-name (info-or-die super))))))
+
+(defun super-layouts (supers)
+  (loop for super in supers 
+     collect (super-layout super)))
+
+(defrestore-cl-store (structure-class stream)
+  (restore-object stream))
+    
+(defrestore-cl-store (struct-def stream)
+  (let* ((supers (super-layouts (restore-object stream)))
+         (dd (restore-object stream)))
+    (sbcl-define-structure dd (if supers 
+                                  (coerce (append  *sbcl-struct-inherits*
+                                                   supers)
+                                          'vector)
+                                  (coerce *sbcl-struct-inherits* 'vector)))))
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/sysdef.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/sysdef.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,13 @@
+(in-package :sysdef-user)
+
+(define-system :CL-STORE (cl-store-system )
+  (:author "Sean Ross <sross at common-lisp.net>")
+  (:version 0 8 3)
+  (:documentation "Portable CL Package to serialize data")
+  (:licence "MIT")
+  (:components  "package" "utils"
+                #+(or abcl (and clisp (not mop))) "mop"
+                "backends" "plumbing" "circularities" "default-backend"
+                ("custom" non-required-file))
+  (:pathname #.(directory-namestring *compile-file-truename*))
+  (:needs (sysdef::test-action :rt)))

Added: trunk/thirdparty/cl-store_0.8.4/tests.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/tests.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,716 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+(defpackage :cl-store-tests
+  (:use :cl :regression-test :cl-store))
+
+(in-package :cl-store-tests)
+
+(rem-all-tests)
+(defvar *test-file* "filetest.cls")
+
+(defun restores (val)
+  (store val *test-file*)
+  (let ((restored (restore *test-file*)))
+    (or (and (numberp val) (= val restored))
+        (and (stringp val) (string= val restored))
+        (and (characterp val) (char= val restored))
+        (eql val restored)
+        (equal val restored)
+        (equalp val restored))))
+
+(defmacro deftestit (name val)
+  `(deftest ,name (restores ,val) t))
+
+;; integers
+(deftestit integer.1 1)
+(deftestit integer.2 0)
+(deftestit integer.3 23423333333333333333333333423102334)
+(deftestit integer.4 -2322993)
+(deftestit integer.5 most-positive-fixnum)
+(deftestit integer.6 most-negative-fixnum)
+(deftestit integer.7 #x100000000) 
+
+;; ratios
+(deftestit ratio.1 1/2)
+(deftestit ratio.2 234232/23434)
+(deftestit ratio.3 -12/2)
+(deftestit ratio.4 -6/11)
+(deftestit ratio.5 23222/13)
+
+;; complex numbers
+(deftestit complex.1 #C(0 1))
+(deftestit complex.2 #C(0.0 1.0))
+(deftestit complex.3 #C(32 -23455))
+(deftestit complex.4 #C(-222.32 2322.21))
+(deftestit complex.5 #C(-111 -1123))
+(deftestit complex.6 #C(-11.2 -34.5))
+
+
+;; short floats
+
+;; single-float
+(deftestit single-float.1 3244.32)
+(deftestit single-float.2 0.12)
+(deftestit single-float.3 -233.001)
+(deftestit single-float.4 most-positive-single-float)
+(deftestit single-float.5 most-negative-single-float)
+
+;; double-float
+(deftestit double-float.1 2343.3d0)
+(deftestit double-float.2 -1211111.3343d0)
+(deftestit double-float.3 99999999999123456789012345678222222222222290.0987654321d0)
+(deftestit double-float.4 -99999999999123456789012345678222222222222290.0987654321d0)
+(deftestit double-float.5 most-positive-double-float)
+(deftestit double-float.6 most-negative-double-float)
+
+;; long floats
+
+;; infinite floats
+#+(or sbcl cmu lispworks allegro)
+(progn 
+  #+sbcl (sb-int:set-floating-point-modes :traps nil)
+  #+cmu (ext:set-floating-point-modes :traps nil)
+  (deftestit infinite-float.1 (expt most-positive-single-float 3))
+  (deftestit infinite-float.2 (expt most-positive-double-float 3))
+  (deftestit infinite-float.3 (expt most-negative-single-float 3))
+  (deftestit infinite-float.4 (expt most-negative-double-float 3))
+  (deftestit infinite-float.5 (/ (expt most-positive-single-float 3)
+                                 (expt most-positive-single-float 3)))
+  (deftestit infinite-float.6 (/ (expt most-positive-double-float 3)
+                                 (expt most-positive-double-float 3))))
+
+
+;; characters
+(deftestit char.1 #\Space)
+(deftestit char.2 #\f )
+(deftestit char.3 #\Rubout)
+(deftestit char.4 (code-char 255)) 
+
+
+;; various strings
+(deftestit string.1 "foobar")
+(deftestit string.2 "how are you")
+(deftestit string.3 "foo
+bar")
+
+(deftestit string.4
+  (make-array 10 :initial-element #\f :element-type 'character
+              :fill-pointer 3))
+
+#+(or (and sbcl sb-unicode) lispworks clisp acl)
+(progn
+  (deftestit unicode.1 (map #-lispworks 'string
+                            #+lispworks 'lw:text-string
+                            #'code-char (list #X20AC #X3BB)))
+  (deftestit unicode.2 (intern (map #-lispworks 'string
+                                    #+lispworks 'lw:text-string
+                                    #'code-char (list #X20AC #X3BB))
+                               :cl-store-tests)))
+
+;; vectors
+(deftestit vector.1 #(1 2 3 4))
+
+
+(deftestit vector.2 (make-array 5 :element-type 'fixnum 
+                                :initial-contents (list 1 2 3 4 5)))
+
+(deftestit vector.3
+  (make-array 5
+              :element-type 'fixnum
+              :fill-pointer 2
+              :initial-contents (list 1 2 3 4 5)))
+
+
+(deftestit vector.4 #*101101101110)
+(deftestit vector.5 #*)
+(deftestit vector.6 #())
+
+
+;; (array octect (*))
+
+(deftestit vector.octet.1 (make-array 10 :element-type '(unsigned-byte 8)))
+           
+
+;; arrays
+(deftestit array.1
+  (make-array '(2 2) :initial-contents '((1 2) (3 4))))
+
+(deftestit array.2
+  (make-array '(2 2) :initial-contents '((1 1) (1 1))))
+
+(deftestit array.3
+  (make-array '(2 2) :element-type '(mod 10) :initial-element 3))
+
+(deftestit array.4
+  (make-array  '(2 3 5) 
+              :initial-contents
+              '(((1 2 #\f 5 12.0) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1))
+                ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1) 
+                 (#\Newline 1 7 #\4 #\0)))))
+
+(deftestit array.5
+  (let* ((a1 (make-array 5))
+         (a2 (make-array 4 :displaced-to a1
+                         :displaced-index-offset 1))
+         (a3 (make-array 2 :displaced-to a2
+                         :displaced-index-offset 2)))
+    a3))
+    
+         
+
+
+;; symbols
+
+(deftestit symbol.1  t)
+(deftestit symbol.2  nil)
+(deftestit symbol.3  :foo)
+(deftestit symbol.4  'cl-store-tests::foo)
+(deftestit symbol.5  'make-hash-table)
+(deftestit symbol.6 '|foo bar|)
+(deftestit symbol.7 'foo\ bar\ baz)
+
+(deftest gensym.1 (progn
+                    (store (gensym "Foobar") *test-file*)
+                    (let ((new (restore *test-file*)))
+                      (list (symbol-package new)
+                            (mismatch "Foobar" (symbol-name new)))))
+         (nil 6))
+
+; This failed in cl-store < 0.5.5
+(deftest gensym.2 (let ((x (gensym)))
+                    (store (list x x) *test-file*)
+                    (let ((new (restore *test-file*)))
+                      (eql (car new) (cadr new))))
+         t)
+
+
+;; cons
+
+(deftestit cons.1 '(1 2 3))
+(deftestit cons.2 '((1 2 3)))
+(deftestit cons.3 '(#\Space 1 1/2 1.3 #(1 2 3)))
+  
+(deftestit cons.4  '(1 . 2))
+(deftestit cons.5  '(t . nil))
+(deftestit cons.6 '(1 2 3 . 5))
+(deftest cons.7 (let ((list (cons nil nil)))
+                  (setf (car list) list)
+                  (store list *test-file*)
+                  (let ((ret (restore *test-file*)))
+                    (eq ret (car ret))))
+         t)
+
+
+;; hash tables
+; for some reason (make-hash-table) is not equalp 
+; to (make-hash-table) with ecl.
+
+#-ecl
+(deftestit hash.1 (make-hash-table))
+
+#-ecl
+(defvar *hash* (let ((in (make-hash-table :test #'equal 
+                                          :rehash-threshold 0.4 :size 20
+                                          :rehash-size 40)))
+                 (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
+                 in))
+#-ecl
+(deftestit hash.2 *hash*)
+
+
+;; packages
+(deftestit package.1 (find-package :cl-store))
+
+(defpackage foo 
+  (:nicknames foobar)
+  (:use :cl)
+  (:shadow cl:format)
+  (:export bar))
+
+(defun package-restores ()
+  (let (( *nuke-existing-packages* t))
+    (store (find-package :foo) *test-file*)
+    (delete-package :foo)
+    (restore *test-file*)
+    (list (package-name (find-package :foo))
+          (mapcar #'package-name (package-use-list :foo))
+          (package-nicknames :foo)
+          (equalp (remove-duplicates (package-shadowing-symbols :foo))
+                  (list (find-symbol "FORMAT" "FOO")))
+          (equalp (cl-store::external-symbols (find-package :foo))
+                  (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))))
+
+
+; unfortunately it's difficult to portably test the internal symbols
+; in a package so we just assume that it's OK.
+(deftest package.2 
+         (package-restores)
+         ("FOO" ("COMMON-LISP") ("FOOBAR") t t))
+
+;; objects 
+(defclass foo ()
+  ((x :accessor get-x :initarg :x)))
+
+(defclass bar (foo)
+  ((y :accessor get-y :initform nil :initarg :y)))
+
+(defclass quux ()
+  (a))
+
+(defclass baz (quux)
+  ((z :accessor get-z :initarg :z :allocation :class)))
+
+
+
+(deftest standard-object.1
+  (let ((val (store (make-instance 'foo :x 3) *test-file*)))
+    (= (get-x val) (get-x (restore *test-file*))))
+  t)
+
+(deftest standard-object.2
+  (let ((val (store (make-instance 'bar
+                                   :x (list 1 "foo" 1.0)
+                                   :y (vector 1 2 3 4))
+                    *test-file*)))
+    (let ((ret (restore *test-file*)))
+      (and (equalp (get-x val) (get-x ret))
+           (equalp (get-y val) (get-y ret)))))
+  t)
+
+(deftest standard-object.3 
+  (let ((*store-class-slots* nil)
+        (val (make-instance 'baz :z 9)))
+    (store val *test-file*)
+    (make-instance 'baz :z 2)
+    (= (get-z (restore *test-file*))
+       2))
+  t)
+
+(deftest standard-object.4
+  (let ((*store-class-slots* t)
+        (val (make-instance 'baz :z 9)))
+    (store val *test-file*)
+    (make-instance 'baz :z 2)
+    (let ((ret (restore *test-file*)))
+      (= (get-z ret )
+         9)))
+  t)
+
+;; classes
+(deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) 
+                                 (restore *test-file*)
+                                 t)
+  t)
+
+(deftest standard-class.2 (progn (store (find-class 'bar) *test-file*)
+                                 (restore *test-file*)
+                                 t)
+  t)
+
+(deftest standard-class.3 (progn (store (find-class 'baz) *test-file*)
+                                 (restore *test-file*)
+                                 t)
+  t)
+
+
+
+;; conditions
+(deftest condition.1
+  (handler-case (/ 1 0)
+    (division-by-zero (c) 
+      (store c *test-file*)
+      (typep (restore *test-file*) 'division-by-zero)))
+  t)
+
+(deftest condition.2
+  (handler-case (car (read-from-string "3"))
+    ;; allegro pre 7.0 signalled a simple-error here
+    ((or type-error simple-error) (c)
+      (store c *test-file*)
+      (typep (restore *test-file*) 
+             '(or type-error simple-error))))
+  t)
+
+;; structure-object
+
+(defstruct a
+  a b c)
+
+(defstruct (b (:include a))
+  d e f)
+
+#+(or sbcl cmu lispworks openmcl) 
+(deftestit structure-object.1 (make-a :a 1 :b 2 :c 3))
+#+(or sbcl cmu lispworks openmcl)
+(deftestit structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6))
+#+(or sbcl cmu lispworks openmcl)
+(deftestit structure-object.3 (make-b :a 1 :b (make-a :a 1 :b 3 :c 2)
+                                      :c #\Space :d #(1 2 3) :e (list 1 2 3)
+                                      :f (make-hash-table)))
+
+;; setf test
+(deftestit setf.1 (setf (restore *test-file*) 0))
+(deftestit setf.2 (incf (restore *test-file*)))
+(deftestit setf.3 (decf (restore *test-file*) 2))
+
+(deftestit pathname.1 #P"/home/foo")
+(deftestit pathname.2 (make-pathname :name "foo"))
+(deftestit pathname.3 (make-pathname :name "foo" :type "bar"))
+                                      
+
+; built-in classes
+(deftestit built-in.1 (find-class 'hash-table))
+(deftestit built-in.2 (find-class 'integer))
+                                  
+
+;; find-backend tests
+(deftest find-backend.1 
+    (and (find-backend 'cl-store) t)
+  t)
+
+(deftest find-backend.2
+    (find-backend (gensym))
+  nil)
+
+(deftest find-backend.3
+    (handler-case (find-backend (gensym) t)
+      (error (c) (and c t))
+      (:no-error (val) (and val nil)))
+  t)
+
+
+
+;; circular objects
+(defvar circ1 (let ((x (list 1 2 3 4)))
+                (setf (cdr (last x)) x)))
+(deftest circ.1 (progn (store circ1 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (eql (cddddr x) x)))
+  t)
+
+(defvar circ2 (let ((x (list 2 3 4 4 5)))
+                (setf (second x) x)))
+(deftest circ.2 (progn (store circ2 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (eql (second x) x)))
+  t)
+
+
+
+(defvar circ3 (let ((x (list (list 1 2 3 4 )
+                             (list 5 6 7 8)
+                             9)))
+                (setf (second x) (car x))
+                (setf (cdr (last x)) x)
+                x))
+
+(deftest circ.3 (progn (store circ3 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (and (eql (second x) (car x))
+                              (eql (cdddr x) x))))
+  t)
+
+
+(defvar circ4 (let ((x (make-hash-table)))
+                (setf (gethash 'first x) (make-hash-table))
+                (setf (gethash 'second x) (gethash 'first x))
+                (setf (gethash 'inner (gethash 'first x)) x)
+                x))
+
+(deftest circ.4 (progn (store circ4 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (and (eql (gethash 'first x)
+                                  (gethash 'second x))
+                              (eql x
+                                  (gethash 'inner
+                                           (gethash 'first x))))))
+  t)
+
+(deftest circ.5  (let ((circ5 (make-instance 'bar)))
+                   (setf (get-y circ5) circ5)
+                   (store circ5 *test-file*)
+                   (let ((x (restore *test-file*)))
+                     (eql x (get-y x))))
+  t)
+
+
+(defvar circ6 (let ((y (make-array '(2 2 2)
+                                   :initial-contents '((("foo" "bar") 
+                                                        ("me" "you"))
+                                                       ((5 6) (7 8))))))
+                (setf (aref y 1 1 1) y)
+                (setf (aref y 0 0 0) (aref y 1 1 1))
+                y))
+
+
+(deftest circ.6 (progn (store circ6 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (and (eql (aref x 1 1 1) x)
+                              (eql (aref x 0 0 0) (aref x 1 1 1)))))
+  t)
+
+
+
+(defvar circ7 (let ((x (make-a)))
+                (setf (a-a x) x)))
+
+#+(or sbcl cmu lispworks)
+(deftest circ.7 (progn (store circ7 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (eql (a-a x) x)))
+  t)
+
+(defvar circ.8 (let ((x "foo"))
+                 (make-pathname :name x :type x)))
+
+
+;; clisp apparently creates a copy of the strings in a pathname 
+;; so a test for eqness is pointless.
+#-clisp
+(deftest circ.8 (progn (store circ.8 *test-file*)
+                       (let ((x (restore *test-file*)))
+                         (eql (pathname-name x)
+                              (pathname-type x))))
+  t)
+
+
+(deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2)))
+                  (setf (aref val 3) val)
+                  (setf (aref val 4) (aref val 0))
+                  (store val *test-file*)
+                  (let ((rest (restore *test-file*)))
+                    (and (eql rest (aref rest 3))
+                         (eql (aref rest 4) (aref rest 0)))))
+  t)
+                        
+(deftest circ.10 (let* ((a1 (make-array 5))
+                        (a2 (make-array 4 :displaced-to a1
+                                        :displaced-index-offset 1))
+                        (a3 (make-array 2 :displaced-to a2
+                                        :displaced-index-offset 2)))
+                   (setf (aref a3 1) a3)
+                   (store a3 *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (eql a3 (aref a3 1))))
+  t)
+
+(defvar circ.11 (let ((x (make-hash-table)))
+                  (setf (gethash x x) x)
+                  x))
+
+(deftest circ.11 (progn (store circ.11 *test-file*)
+                        (let ((val (restore *test-file*)))
+                          (eql val (gethash val val))))
+  t)
+
+(deftest circ.12 (let ((x (vector 1 2 "foo" 4 5)))
+                   (setf (aref x 0) x)
+                   (setf (aref x 1) (aref x 2))
+                   (store x *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (and (eql (aref ret 0) ret)
+                          (eql (aref ret 1) (aref ret 2)))))
+  t)
+
+
+(defclass foo.1 ()
+  ((a :accessor foo1-a)))
+
+;; a test from Robert Sedgwick which crashed in earlier
+;; versions (pre 0.2)
+(deftest circ.13 (let ((foo (make-instance 'foo.1))
+                       (bar (make-instance 'foo.1)))
+                   (setf (foo1-a foo) bar)
+                   (setf (foo1-a bar) foo)
+                   (store (list foo) *test-file*)
+                   (let ((ret (car (restore *test-file*))))
+                     (and (eql ret (foo1-a (foo1-a ret)))
+                          (eql (foo1-a ret)
+                              (foo1-a (foo1-a (foo1-a ret)))))))
+  t)
+
+#-abcl
+(deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#)))
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (and (eq ret (cddddr ret))
+                          (eq (fourth ret) ret))))
+         t)
+                   
+
+
+
+#-abcl
+(deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#)))
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (and (eq ret (cddddr ret))
+                          (eq (fourth ret)
+                              (car (fourth ret))))))
+         t)
+
+
+
+;; this had me confused for a while since what was
+;; restored #1=(1 (#1#) #1#) looks nothing like this list,
+;; but it turns out that it is correct
+#-abcl
+(deftest circ.16  (let ((list '#1=(1 #2=(#1#) . #2#)))
+                    (store list *test-file*)
+                    (let ((ret (restore *test-file*)))
+                      (and (eq ret (caadr ret))
+                           (eq ret (third ret)))))
+         t)
+
+;; large circular lists
+#-abcl
+(deftest large.1 (let ((list (make-list 100000)))
+                   (setf (cdr (last list)) list)
+                   (store list *test-file*)
+                   (let ((ret (restore *test-file*)))
+                     (eq (nthcdr 100000 ret) ret)))
+         t)
+
+;; large dotted lists
+#-abcl
+(deftestit large.2 (let ((list (make-list 100000)))
+                     (setf (cdr (last list)) 'foo)
+                     list))
+
+
+
+;; custom storing
+(defclass random-obj () ((size :accessor size :initarg :size)))
+
+(defparameter *random-obj-code* (register-code 100 'random-obj))
+
+(defstore-cl-store (obj random-obj buff)
+  (output-type-code *random-obj-code* buff)
+  (store-object (size obj) buff))
+
+(defrestore-cl-store (random-obj buff)
+  (random (restore-object buff)))
+
+  
+(deftest custom.1
+  (progn (store (make-instance 'random-obj :size 5) *test-file* )
+         (typep (restore *test-file*) '(integer 0 4)))
+  t)
+
+
+;; These tests are quite incorrect as there is no universal method
+;; test for function equality when they are not eq.
+;; While this will work for functions restored based on name
+;; it will most definitely not work for closures.
+;; So we just do limited tests on behaviour
+(deftestit function.1 #'car)
+
+
+(deftest function.2 
+         (progn (store #'cl-store::mkstr *test-file*)
+           (let ((fn (restore *test-file*)))
+             (every (lambda (args)
+                      (string= (apply fn args) (apply #'cl-store::mkstr args)))
+                    '(("foobar" "baz")
+                      ("a" "b" "c")
+                      ("1 2" "ab " "f oO")))))
+         t)
+                      
+;; Closures are clisp only.
+#+clisp
+(deftest function.3
+         (progn (store (list #'(lambda (x y) (funcall x (1+ y)))
+                             #'(lambda (x) (expt x 3)))
+                       *test-file*)
+           (destructuring-bind (fn-a fn-b) (restore *test-file*)
+             (funcall fn-a fn-b 3)))
+         64)
+
+(let ((x 1))
+  (defun foo ()
+    (incf x))
+  (defun bar ()
+    (decf x)))
+
+;; While this works on all Lisps only CLISP is actually creating
+;; a fresh function on the restore.
+#+clisp
+(deftest function.4
+         (progn (store (list #'foo #'bar) *test-file*)
+           (destructuring-bind (fn-a fn-b) (restore *test-file*)
+             (values (funcall fn-a)
+                     (funcall fn-a)
+                     (funcall fn-b))))
+         2 3 2)
+
+(deftestit gfunction.1 #'cl-store:restore)
+(deftestit gfunction.2 #'cl-store:store)
+#-clisp
+(deftestit gfunction.3 #'(setf get-y))
+
+
+(deftest nocirc.1 
+    (let* ((string "FOO")
+           (list `(,string . ,string))
+           (*check-for-circs* nil))
+      (store list *test-file*)
+      (let ((res (restore *test-file*)))
+        (and (not (eql (car res) (cdr res)))
+             (string= (car res) (cdr res)))))
+  t)
+
+
+(defstruct st.bar x)
+(defstruct (st.foo (:conc-name f-)
+                   (:constructor fooo (z y x))
+                   (:copier cp-foo)
+                   (:include st.bar)
+                   (:predicate is-foo)
+                   (:print-function (lambda (obj st dep)
+                                      (declare (ignore dep))
+                                      (print-unreadable-object (obj st :type t) 
+                                        (format st "~A" (f-x obj))))))
+  (y 0 :type integer) (z nil :type simple-string))
+
+
+#+(or sbcl cmu)
+(deftest struct-class.1
+    (let* ((obj (fooo "Z" 2 3))
+           (string (format nil "~A" obj)))
+      (let ((*nuke-existing-classes* t))
+        (store (find-class 'st.foo) *test-file*)
+        (fmakunbound 'cp-foo)
+        (fmakunbound 'is-foo)
+        (fmakunbound 'fooo)
+        (fmakunbound 'f-x)
+        (fmakunbound 'f-y)
+        (fmakunbound 'f-z)
+        (restore *test-file*)
+        (let* ((new-obj (cp-foo (fooo "Z" 2 3)))
+               (new-string (format nil "~A" new-obj)))
+          (list (is-foo new-obj) (equalp obj new-obj)
+                (string= new-string string)
+                (f-x new-obj) (f-y new-obj) (f-z new-obj)))))
+  (t t t 3 2 "Z"))
+
+(deftest serialization-unit.1
+         (with-serialization-unit ()
+           (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
+                                 :if-exists :supersede :direction :output)
+             (dotimes (x 100)
+               (cl-store:store x outs)))
+           (with-open-file (outs *test-file* :element-type '(unsigned-byte 8)
+                                 :if-exists :supersede)
+             (loop :repeat 100 :collect (cl-store:restore outs))))
+         #.(loop :for x :below  100 :collect  x))
+
+(defun run-tests (backend)
+  (with-backend backend
+    (regression-test:do-tests))
+  (when (probe-file *test-file*)
+    (ignore-errors (delete-file *test-file*))))
+
+
+(do-tests)
+;; EOF
+

Added: trunk/thirdparty/cl-store_0.8.4/utils.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/utils.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,165 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; Miscellaneous utilities used throughout the package.
+(in-package :cl-store)
+
+(defmacro aif (test then &optional else)
+  `(let ((it ,test))
+    (if it ,then ,else)))
+
+(defmacro with-gensyms (names &body body)
+  `(let ,(mapcar #'(lambda (x) `(,x (gensym))) names)
+    , at body))
+
+(defgeneric serializable-slots (object)
+  (declare (optimize speed))
+  (:documentation 
+   "Return a list of slot-definitions to serialize. The default
+    is to call serializable-slots-using-class with the object 
+    and the objects class")
+  (:method ((object standard-object))
+   (serializable-slots-using-class object (class-of object)))
+#+(or sbcl cmu openmcl)
+  (:method ((object structure-object))
+   (serializable-slots-using-class object (class-of object)))
+  (:method ((object condition))
+   (serializable-slots-using-class object (class-of object))))
+
+; unfortunately the metaclass of conditions in sbcl and cmu 
+; are not standard-class
+
+(defgeneric serializable-slots-using-class (object class)
+  (declare (optimize speed))
+  (:documentation "Return a list of slot-definitions to serialize.
+   The default calls compute slots with class")
+  (:method ((object t) (class standard-class))
+   (class-slots class))
+#+(or sbcl cmu openmcl) 
+  (:method ((object t) (class structure-class))
+   (class-slots class))
+#+sbcl
+  (:method ((object t) (class sb-pcl::condition-class))
+   (class-slots class))
+#+cmu
+  (:method ((object t) (class pcl::condition-class))
+   (class-slots class)))
+
+
+; Generify get-slot-details for customization (from Thomas Stenhaug)
+(defgeneric get-slot-details (slot-definition)
+  (declare (optimize speed))
+  (:documentation 
+   "Return a list of slot details which can be used 
+    as an argument to ensure-class")
+  (:method ((slot-definition #+(or ecl abcl (and clisp (not mop))) t 
+                             #-(or ecl abcl (and clisp (not mop))) slot-definition))
+   (list :name (slot-definition-name slot-definition)
+         :allocation (slot-definition-allocation slot-definition)
+         :initargs (slot-definition-initargs slot-definition)
+         ;; :initform. dont use initform until we can
+         ;; serialize functions
+         :readers (slot-definition-readers slot-definition)
+         :type (slot-definition-type slot-definition)
+         :writers (slot-definition-writers slot-definition)))
+  #+openmcl
+  (:method ((slot-definition ccl::structure-slot-definition))
+   (list :name (slot-definition-name slot-definition)
+         :allocation (slot-definition-allocation slot-definition)
+         :initargs (slot-definition-initargs slot-definition)
+         ;; :initform. dont use initform until we can
+         ;; serialize functions
+         ;; :readers (slot-definition-readers slot-definition)
+         :type (slot-definition-type slot-definition)
+         ;; :writers (slot-definition-writers slot-definition)
+         )))
+
+(defmacro when-let ((var test) &body body)
+  `(let ((,var ,test))
+     (when ,var
+       , at body)))
+
+
+;; because clisp doesn't have the class single-float or double-float.
+(defun float-type (float)
+  (etypecase float
+    (single-float 0)
+    (double-float 1)
+    (short-float 2)
+    (long-float 3)))
+
+(defun get-float-type (num)
+  (ecase num
+    (0 1.0)
+    (1 1.0d0)
+    (2 1.0s0)
+    (3 1.0l0)))
+
+(deftype ub32 ()
+  `(unsigned-byte 32))
+
+(deftype sb32 ()
+  `(signed-byte 32))
+
+(deftype array-size ()
+  "The maximum size of a vector"
+  `(integer 0 , array-dimension-limit))
+
+(deftype array-tot-size ()
+  "The maximum total size of an array"
+  `(integer 0 , array-total-size-limit))
+
+(defun store-32-bit (obj stream)
+  "Write OBJ down STREAM as a 32 bit integer."
+  (declare (optimize speed (debug 0) (safety 0))
+           (type ub32 obj))
+    (write-byte (ldb (byte 8 0) obj) stream)
+    (write-byte (ldb (byte 8 8) obj) stream)
+    (write-byte (ldb (byte 8 16) obj) stream)
+    (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
+
+(defmacro make-ub32 (a b c d)
+  `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d)))
+
+(defun read-32-bit (buf &optional (signed t))
+  "Read a signed or unsigned byte off STREAM."
+  (declare (optimize speed (debug 0) (safety 0)))
+  (let ((byte1 (read-byte buf))
+        (byte2 (read-byte buf))
+        (byte3 (read-byte buf))
+        (byte4 (read-byte buf)))
+    (declare (type (mod 256) byte1 byte2 byte3 byte4))
+    (let ((ret (make-ub32 byte4 byte3 byte2 byte1)))
+      (if (and signed (> byte1 127))
+          (logior (ash -1 32) ret)
+          ret))))
+
+(defun kwd (name)
+  (values (intern (string-upcase name) :keyword)))
+
+(defun mkstr (&rest args)
+  (with-output-to-string (s)
+    (dolist (x args)
+      (format s "~@:(~A~)" x))))
+
+(defun symbolicate (&rest syms)
+  "Concatenate all symbol names into one big symbol"
+  (values (intern (apply #'mkstr syms))))
+
+;; Taken straight from swank.lisp --- public domain
+;; and then slightly modified
+(defun safe-length (list)
+  "Similar to `list-length', but avoid errors on improper lists.
+Return two values: the length of the list and the last cdr.
+Modified to work on non proper lists."
+  (do ((n 0 (+ n 2))                    ;Counter.
+       (fast list (cddr fast))          ;Fast pointer: leaps by 2.
+       (slow list (cdr slow)))          ;Slow pointer: leaps by 1.
+      (nil)
+    (cond ((null fast) (return (values n nil)))
+          ((not (consp fast)) (return (values n fast)))
+          ((null (cdr fast)) (return (values (1+ n) (cdr fast))))
+          ((and (eq fast slow) (> n 0)) (return (values (/ n 2) list)))
+          ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast)))))))
+
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/xml-backend.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,486 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+;; THIS BACKEND IS DEPRECATED AND WILL NOT WORK
+;; ITS PRESENCE IS FOR POSTERITY ONLY
+(in-package :cl-store-xml)
+
+
+(defbackend xml :stream-type 'character :extends (resolving-backend))
+
+;; The xml backend does not use any type codes
+;; we figure it out when we read the tag of each object
+(defvar *xml-mapping* (make-hash-table :test #'equal))
+(defun add-xml-mapping (name)
+  (setf (gethash name *xml-mapping*)
+        (intern name :cl-store-xml)))
+
+(add-xml-mapping "REFERRER")
+(add-xml-mapping "INTEGER")
+(add-xml-mapping "FLOAT")
+(add-xml-mapping "SIMPLE-STRING")
+(add-xml-mapping "SYMBOL")
+(add-xml-mapping "CONS")
+(add-xml-mapping "RATIO")
+(add-xml-mapping "CHARACTER")
+(add-xml-mapping "COMPLEX")
+(add-xml-mapping "PATHNAME")
+(add-xml-mapping "FUNCTION")
+(add-xml-mapping "GENERIC-FUNCTION")
+
+(defmethod get-next-reader ((backend xml) (place list))
+  (or (gethash (car place) *xml-mapping*)
+      (error "Unknown tag ~A" (car place))))
+
+(defun princ-xml (tag value stream)
+  (format stream "<~A>" tag)
+  (xmls:write-xml value stream)
+  (format stream "</~A>" tag))
+
+(defun princ-and-store (tag obj stream)
+  (format stream "<~A>" tag)
+  (store-object obj stream)
+  (format stream "</~A>" tag))
+
+(defmacro with-tag ((tag stream) &body body)
+  `(progn 
+    (format ,stream "<~A>" ,tag)
+    , at body
+    (format ,stream "</~A>" ,tag)))
+
+(defun first-child (elmt)
+  (first (xmls:node-children elmt)))
+
+(defun second-child (elmt)
+  (second (xmls:node-children elmt)))
+
+(defun get-child (name elmt &optional (errorp t))
+  (or (assoc name (xmls:node-children elmt) :test #'equal)
+      (and errorp
+           (restore-error "No child called ~A in xml ~a"
+                          (list name elmt)))))
+
+(defun get-attr (name elmt)
+  (cadr (assoc name (xmls:node-attrs elmt) :test #'equal)))
+
+(declaim (inline restore-first))
+(defun restore-first (place)
+  (restore-object (first-child place)))
+
+(defmethod store-referrer ((backend xml) (ref t) (stream t))
+  (princ-xml "REFERRER" ref stream))
+
+(defrestore-xml (referrer place)
+  (make-referrer :val (parse-integer (third place))))
+
+(defmethod referrerp ((backend xml) (reader t))
+  (eql reader 'referrer))
+
+;; override backend restore to parse the incoming stream
+(defmethod backend-restore ((backend xml) (place stream))
+  (let ((*restore-counter* 0)
+        (*need-to-fix* nil)
+        (*print-circle* nil)
+        (*restored-values* (and *check-for-circs*
+                                (make-hash-table :test #'eq :size *restore-hash-size*))))
+    (multiple-value-prog1
+        (backend-restore-object backend
+                                (or (xmls:parse place)
+                                    (restore-error "Invalid xml")))
+      (dolist (fn *need-to-fix*)
+        (force fn)))))
+
+;; integer
+(defstore-xml (obj integer stream)
+  (princ-xml "INTEGER" obj stream))
+
+(defrestore-xml (integer from)
+  (values (parse-integer (first-child from))))
+
+;; floats
+(defvar *special-floats* nil) ;; setup in custom-xml files
+
+;; FIXME: add support for *special-floats*
+(defstore-xml (obj float stream)
+  (with-tag ("FLOAT" stream) (print obj stream)))
+
+(defrestore-xml (float from)
+  (cl-l10n:parse-number (first-child from)))
+
+#|
+(defstore-xml (obj single-float stream)
+  (store-float "SINGLE-FLOAT" obj stream))
+
+(defstore-xml (obj double-float stream)
+  (store-float "DOUBLE-FLOAT" obj stream))
+
+(defun store-float (type obj stream)
+  (block body
+    (let (significand exponent sign)
+      (handler-bind ((simple-error
+                      #'(lambda (err)
+                          (declare (ignore err))
+                          (when-let (type (cdr (assoc obj *special-floats*)))
+                            (output-float-type type stream)
+                            (return-from body)))))
+        (multiple-value-setq (significand exponent sign)
+            (integer-decode-float obj))
+        (with-tag (type stream)
+          (princ-and-store "SIGNIFICAND" significand stream)
+          (princ-and-store "RADIX"(float-radix obj) stream)
+          (princ-and-store "EXPONENT" exponent stream)
+          (princ-and-store "SIGN" sign stream))))))
+|#
+
+; FIXME: restore flaot
+
+;; ratio
+(defstore-xml (obj ratio stream)
+  (with-tag ("RATIO" stream)
+    (princ-and-store "NUMERATOR" (numerator obj) stream)
+    (princ-and-store "DENOMINATOR" (denominator obj) stream)))
+
+(defrestore-xml (ratio from)
+  (/ (restore-first (get-child "NUMERATOR" from))
+     (restore-first (get-child "DENOMINATOR" from))))
+
+;; char
+(defstore-xml (obj character stream)
+  (princ-and-store "CHARACTER" (char-code obj) stream))
+
+(defrestore-xml (character from)
+  (code-char (restore-first from)))
+
+
+;; complex
+(defstore-xml (obj complex stream)
+  (with-tag ("COMPLEX" stream)
+    (princ-and-store "REALPART" (realpart obj) stream)
+    (princ-and-store "IMAGPART" (imagpart obj) stream)))
+
+
+(defrestore-xml (complex from)
+  (complex (restore-first (get-child "REALPART" from))
+           (restore-first (get-child "IMAGPART" from))))
+
+
+;; symbols 
+(defstore-xml (obj symbol stream)
+  (with-tag ("SYMBOL" stream)
+    (princ-and-store "NAME" (symbol-name obj) stream)
+    (cl-store::when-let (package (symbol-package obj))
+      (princ-and-store "PACKAGE" (package-name package) stream))))
+
+(defrestore-xml (symbol from)
+  (let ((name (restore-first (get-child "NAME" from)))
+        (package (when (get-child "PACKAGE" from nil)
+                   (restore-first (get-child "PACKAGE" from)))))
+    (if package
+        (values (intern name package))
+        (make-symbol name))))
+
+;; lists
+(defstore-xml (obj cons stream)
+  (with-tag ("CONS" stream)
+    (princ-and-store "CAR" (car obj) stream)
+    (princ-and-store "CDR" (cdr obj) stream)))
+
+(defrestore-xml (cons from)
+  (resolving-object (x (cons nil nil))
+    (setting (car x) (restore-first (get-child "CAR" from)))
+    (setting (cdr x) (restore-first (get-child "CDR" from)))))
+
+;; simple string
+(defstore-xml (obj simple-string stream)
+  (princ-xml "SIMPLE-STRING" obj stream))
+
+(defrestore-xml (simple-string from)
+  (first-child from))
+
+
+;; pathnames
+(defstore-xml (obj pathname stream)
+  (with-tag ("PATHNAME" stream)
+    (princ-and-store "DEVICE" (pathname-device obj) stream)
+    (princ-and-store "DIRECTORY" (pathname-directory obj) stream)
+    (princ-and-store "NAME" (pathname-name obj) stream)
+    (princ-and-store "TYPE" (pathname-type obj) stream)
+    (princ-and-store "VERSION" (pathname-version obj) stream)))
+
+(defrestore-xml (pathname place)
+  (make-pathname 
+   :device (restore-first (get-child "DEVICE" place))
+   :directory (restore-first (get-child "DIRECTORY" place))
+   :name (restore-first (get-child "NAME" place))
+   :type (restore-first (get-child "TYPE" place))
+   :version (restore-first (get-child "VERSION" place))))
+
+
+; hash table
+(defstore-xml (obj hash-table stream)
+  (with-tag ("HASH-TABLE" stream)
+    (princ-and-store "REHASH-SIZE" (hash-table-rehash-size obj) stream)
+    (princ-and-store "REHASH-THRESHOLD" (hash-table-rehash-threshold obj) stream)
+    (princ-and-store "SIZE" (hash-table-size obj) stream)
+    (princ-and-store "TEST" (hash-table-test obj) stream)
+    (with-tag ("ENTRIES" stream)
+      (loop for key being the hash-keys of obj
+            using (hash-value value) do
+            (with-tag ("ENTRY" stream)
+              (princ-and-store "KEY" key stream)
+              (princ-and-store "VALUE" value stream))))))
+
+;; FIXME: restore hash tables
+
+;; objects and conditions
+
+(defun xml-dump-type-object (obj stream)
+  (let* ((all-slots (serializable-slots obj)))
+    (with-tag ("SLOTS" stream)
+      (dolist (slot all-slots)
+        (when (slot-boundp obj (slot-definition-name slot))
+          (when (or *store-class-slots* 
+                    (eql (slot-definition-allocation slot) :instance))
+            (with-tag ("SLOT" stream)
+              (let ((slot-name (slot-definition-name slot)))
+                (princ-and-store "NAME" slot-name stream)
+                (princ-and-store "VALUE" (slot-value obj slot-name) stream)))))))))
+
+(defstore-xml (obj standard-object stream)
+  (with-tag ("STANDARD-OBJECT" stream)
+    (princ-and-store "CLASS" (type-of obj) stream)
+    (xml-dump-type-object obj stream)))
+
+(defstore-xml (obj condition stream)
+  (with-tag ("CONDITION" stream)
+    (princ-and-store "CLASS" (type-of obj) stream)
+    (xml-dump-type-object obj stream)))
+
+
+;; FIXME: restore objects
+
+
+
+;; classes
+
+;; FIXME : Write me 
+
+;; built in classes
+(defstore-xml (obj built-in-class stream)
+  (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream))
+
+#-ecl ;; for some reason this doesn't work with ecl
+(defmethod internal-store-object ((backend xml) (obj (eql (find-class 'hash-table))) stream)
+  (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream))
+
+;; FIXME: restore built in classes
+
+;; arrays and vectors
+;; FIXME : Write me 
+
+;; packages
+;; FIXME : Write me 
+
+;; functions
+(defstore-xml (obj function stream)
+  (princ-and-store "FUNCTION" (get-function-name obj) stream))
+
+(defrestore-xml (function from)
+  (fdefinition (restore-first from)))
+
+;; generic functions
+(defstore-xml (obj generic-function stream)
+  (if (generic-function-name obj)
+      (princ-and-store "GENERIC-FUNCTION" 
+                       (generic-function-name obj) stream)
+      (store-error "No generic function name for ~A." obj)))
+
+(defrestore-xml (generic-function from) 
+  (fdefinition (restore-first from)))
+
+(setf *default-backend* (find-backend 'xml))
+
+#|
+
+;; required methods and miscellaneous util functions
+
+
+(defrestore-xml (hash-table place)
+  (let ((hash1 (make-hash-table 
+                :rehash-size (restore-first (get-child "REHASH-SIZE" place))
+                :rehash-threshold (restore-first 
+                                   (get-child "REHASH-THRESHOLD" place))
+                :size (restore-first (get-child "SIZE" place))
+                :test (symbol-function (restore-first (get-child "TEST" place))))))
+    (resolving-object (hash1 hash1)
+      (dolist (entry (xmls:node-children (get-child "ENTRIES" place)))
+        (let* ((key-place (first-child (first-child entry)))
+               (val-place (first-child (second-child entry))))
+          (setting-hash (restore-object key-place) 
+                        (restore-object val-place)))))
+    hash1))
+
+
+(defun restore-xml-type-object (place)
+  (let* ((class (find-class (restore-first (get-child "CLASS" place))))
+         (new-instance (allocate-instance class)))
+    (resolving-object new-instance
+      (dolist (slot (xmls:node-children (get-child "SLOTS" place)))
+        (let ((slot-name (restore-first (get-child "NAME" slot))))
+          (setting (slot-value slot-name) 
+                   (restore-first (get-child "VALUE" slot))))))
+    new-instance))
+
+(defrestore-xml (standard-object place)
+  (restore-xml-type-object place))
+
+(defrestore-xml (condition place)
+  (restore-xml-type-object place))
+
+;; classes
+(defun store-slot (slot stream)
+  (with-tag ("SLOT" stream)
+    (princ-and-store "NAME" (slot-definition-name slot) stream)
+    (princ-and-store "ALLOCATION" (slot-definition-allocation slot) stream)
+    (princ-and-store "TYPE" (slot-definition-type slot) stream)
+    (with-tag ("INITARGS" stream)
+      (dolist (x (slot-definition-initargs slot))
+        (princ-and-store "INITARG" x stream)))
+    (with-tag ("READERS" stream)
+      (dolist (x (slot-definition-readers slot))
+        (princ-and-store "READER" x stream)))
+    (with-tag ("WRITERS" stream)
+      (dolist (x (slot-definition-writers slot))
+        (princ-and-store "WRITER" x stream)))))
+
+(defstore-xml (obj standard-class stream)
+  (with-tag ("STANDARD-CLASS" stream)
+    (princ-and-store "NAME" (class-name obj) stream)
+    (with-tag ("SUPERCLASSES" stream)
+      (loop for x in (class-direct-superclasses obj) do
+            (unless (eql x (find-class 'standard-object))
+              (princ-and-store "SUPERCLASS" 
+                               (if *store-class-superclasses*
+                                   x
+                                   (class-name x))
+                               stream))))
+    (with-tag ("SLOTS" stream)
+      (dolist (x (class-direct-slots obj))
+        (store-slot x stream)))
+    (princ-and-store "METACLASS" (type-of obj) stream)))
+
+
+
+(defun xml-add-class (name slots superclasses metaclass)
+  (ensure-class name :direct-slots slots
+                :direct-superclasses superclasses
+                :metaclass metaclass)
+  #+clisp(add-methods-for-class name slots))
+
+(defun get-values (values)
+  (loop for value in (xmls:node-children values)
+        collect (restore-first value)))
+
+(defun get-slots (slots)
+  (loop for slot in (xmls:node-children slots) 
+        collect (list :name (restore-first (get-child "NAME" slot))
+                      :allocation (restore-first (get-child "ALLOCATION" slot))
+                      :type (restore-first (get-child "TYPE" slot))
+                      :initargs (get-values (get-child "INITARGS" slot))
+                      :readers (get-values (get-child "READERS" slot))
+                      :writers (get-values (get-child "WRITERS" slot)))))
+
+(defun get-superclasses (superclasses)
+  (loop for superclass in (xmls:node-children superclasses)
+        collect (restore-first superclass)))
+        
+(defrestore-xml (standard-class  place)
+  (let* ((name (restore-first (get-child "NAME" place)))
+         (superclasses (get-superclasses (get-child "SUPERCLASSES" place)))
+         (slots (get-slots (get-child "SLOTS" place)))
+         (metaclass (restore-first (get-child "METACLASS" place))))
+    (cond (*nuke-existing-classes*
+           (xml-add-class name slots superclasses metaclass))
+          (t (aif (find-class name nil)
+                  it
+                  (xml-add-class name slots superclasses metaclass))))))
+
+;; built-in-classes 
+(defstore-xml (obj built-in-class stream)
+  (princ-and-store "BUILT-IN-CLASS" (class-name obj) stream))
+
+(defrestore-xml (built-in-class place)
+  (find-class (restore-first place)))
+
+;; I don't know if this really qualifies as a built-in-class but it 
+;; does make things a bit easier
+(defmethod internal-store-object ((obj (eql (find-class 'hash-table))) stream 
+                                  (backend xml-backend))
+  (princ-and-store "BUILT-IN-CLASS" 'cl:hash-table stream))
+
+
+;; Arrays and vectors
+(defstore-xml (obj array stream)
+  (xml-dump-array obj stream))
+
+(defun xml-dump-array (obj stream)
+  (with-tag ("ARRAY" stream)
+    (princ-and-store "DIMENSIONS" (array-dimensions obj) stream)
+    (if (and (= (array-rank obj) 1)
+             (array-has-fill-pointer-p obj))
+        (princ-and-store "FILL-POINTER" (fill-pointer obj) stream)
+        (princ-and-store "FILL-POINTER" nil stream))
+    (princ-and-store "ELEMENT-TYPE" (array-element-type obj) stream)
+    (multiple-value-bind (to offset) (array-displacement obj)
+      (princ-and-store "DISPLACED-TO" to stream)
+      (princ-and-store "DISPLACED-OFFSET" offset stream))
+    (princ-and-store "ADJUSTABLE" (adjustable-array-p obj) stream)
+    (with-tag ("VALUES" stream)
+      (loop for x from 0 to (1- (array-total-size obj)) do
+            (princ-and-store "VALUE" (row-major-aref obj x) stream)))))
+
+(defrestore-xml (array place)
+  (let* ((dimensions (restore-first (get-child "DIMENSIONS" place)))
+         (fill-pointer (restore-first (get-child "FILL-POINTER" place)))
+         (element-type (restore-first (get-child "ELEMENT-TYPE" place)))
+         (displaced-to (restore-first (get-child "DISPLACED-TO" place)))
+         (displaced-offset (restore-first (get-child "DISPLACED-OFFSET"
+                                                     place)))
+         (adjustable (restore-first (get-child "ADJUSTABLE" place)))
+         (res (make-array dimensions  
+                          :element-type element-type
+                          :adjustable adjustable
+                          :fill-pointer fill-pointer)))
+    (when displaced-to
+      (adjust-array res dimensions :displaced-to displaced-to
+                    :displaced-index-offset displaced-offset))
+    (resolving-object res
+      (loop for value in (xmls:node-children (get-child "VALUES" place))
+            for count from 0 do
+            (let ((pos count))
+              (setting (row-major-aref pos)
+                       (restore-first value)))))))
+
+
+#-(or allegro clisp)
+(defstore-xml (obj simple-vector stream)
+  (with-tag ("SIMPLE-VECTOR" stream)
+    (princ-and-store "LENGTH" (length obj) stream)
+    (with-tag ("ELEMENTS" stream)
+      (loop for x across obj do
+            (princ-and-store "ELEMENT" x stream)))))
+
+#-(or allegro clisp)
+(defrestore-xml (simple-vector place)
+  (let* ((size (restore-first (get-child "LENGTH" place)))
+         (res (make-array size)))
+    (resolving-object res
+      (loop for element in (xmls:node-children (get-child "ELEMENTS" place))
+            for index from 1 do
+            (let ((copy (1- index)))
+              (setting (aref copy)
+                       (restore-first element)))))))
+                                      
+
+|#
+;; EOF

Added: trunk/thirdparty/cl-store_0.8.4/xml-package.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/xml-package.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,130 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(defpackage #:cl-store-xml
+  (:use #:cl #:cl-store)
+  (:export #:*xml-backend*
+           #:add-xml-mapping #:defstore-xml #:defrestore-xml #:princ-and-store
+           #:princ-xml #:restore-first #:with-tag #:first-child 
+           #:second-child #:get-child)
+  (:import-from #:cl-store #:when-let #:generic-function-name #:get-function-name
+                #:force #:setting #:resolving-object)
+  
+  #+sbcl (:import-from #:sb-mop
+                       #:generic-function-name
+                       #:slot-definition-name
+                       #:slot-definition-allocation
+                       #:slot-definition
+                       #:compute-slots
+                       #:slot-definition-initform
+                       #:slot-definition-initargs
+                       #:slot-definition-name
+                       #:slot-definition-readers
+                       #:slot-definition-type
+                       #:slot-definition-writers
+                       #:class-direct-default-initargs
+                       #:class-direct-slots
+                       #:class-direct-superclasses
+                       #:class-slots
+                       #:ensure-class)
+
+  #+ecl (:import-from #:clos
+                      #:generic-function-name
+                      #:compute-slots
+                      #:class-direct-default-initargs
+                      #:class-direct-slots
+                      #:class-direct-superclasses
+                      #:class-slots
+                      #:ensure-class)
+
+  #+cmu  (:import-from #:pcl
+                       #:generic-function-name
+                       #:slot-definition-name
+                       #:slot-definition-allocation
+                       #:compute-slots
+                       #:slot-definition
+                       #:slot-definition-initform
+                       #:slot-definition-initargs
+                       #:slot-definition-name
+                       #:slot-definition-readers
+                       #:slot-definition-type
+                       #:slot-definition-writers
+                       #:class-direct-default-initargs
+                       #:class-direct-slots
+                       #:class-direct-superclasses
+                       #:class-slots
+                       #:ensure-class)
+  
+  #+cmu (:shadowing-import-from #:pcl
+                                #:class-name
+                                #:find-class
+                                #:standard-class
+                                #:class-of)
+  
+  #+openmcl (:import-from #:openmcl-mop
+                          #:generic-function-name
+                          #:slot-definition-name
+                          #:slot-definition-allocation
+                          #:compute-slots
+                          #:slot-definition
+                          #:slot-definition-initform
+                          #:slot-definition-initargs
+                          #:slot-definition-name
+                          #:slot-definition-readers
+                          #:slot-definition-type
+                          #:slot-definition-writers
+                          #:class-direct-default-initargs
+                          #:class-direct-slots
+                          #:class-direct-superclasses
+                          #:class-slots
+                          #:ensure-class)
+  
+  #+clisp (:import-from #:clos
+                        #:slot-value
+                        #:std-compute-slots
+                        #:slot-boundp
+                        #:class-name
+                        #:class-direct-default-initargs
+                        #:class-direct-slots
+                        #:class-slots
+                        #:ensure-class)
+  
+  #+lispworks  (:import-from #:clos
+                             #:slot-definition-name
+                             #:generic-function-name
+                             #:slot-definition-allocation
+                             #:compute-slots
+                             #:slot-definition
+                             #:slot-definition-initform
+                             #:slot-definition-initargs
+                             #:slot-definition-name
+                             #:slot-definition-readers
+                             #:slot-definition-type
+                             #:slot-definition-writers
+                             #:class-direct-default-initargs
+                             #:class-direct-slots
+                             #:class-slots
+                             #:class-direct-superclasses
+                             #:ensure-class)
+  
+  #+allegro (:import-from #:mop
+                          #:slot-definition-name
+                          #:generic-function-name
+                          #:slot-definition-allocation
+                          #:slot-definition
+                          #:compute-slots
+                          #:slot-definition-initform
+                          #:slot-definition-initargs
+                          #:slot-definition-name
+                          #:slot-definition-readers
+                          #:slot-definition-type
+                          #:slot-definition-writers
+                          #:class-direct-default-initargs
+                          #:class-direct-slots
+                          #:class-direct-superclasses
+                          #:class-slots
+                          #:ensure-class)
+  )
+           
+
+;; EOF
\ No newline at end of file

Added: trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/cl-store_0.8.4/xml-tests.lisp	Mon Feb 18 09:40:18 2008
@@ -0,0 +1,17 @@
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;; See the file LICENCE for licence information.
+
+(in-package :cl-store-tests)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (use-package :cl-store-xml))
+
+(add-xml-mapping "RANDOM-OBJ")
+
+(defstore-xml (obj random-obj stream)
+  (princ-and-store "RANDOM-OBJ" (size obj) stream))
+
+(defrestore-xml (random-obj stream)
+  (random (restore-first stream)))
+
+;; EOF
\ No newline at end of file


From ksprotte at common-lisp.net  Mon Feb 18 15:34:14 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 10:34:14 -0500 (EST)
Subject: [bknr-cvs] r2555 - in trunk/bknr/datastore/src: . data
Message-ID: <20080218153414.A85E881003@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 10:34:10 2008
New Revision: 2555

Modified:
   trunk/bknr/datastore/src/bknr-datastore.asd
   trunk/bknr/datastore/src/data/encoding-test.lisp
Log:
some basic encoding tests are now in place


Modified: trunk/bknr/datastore/src/bknr-datastore.asd
==============================================================================
--- trunk/bknr/datastore/src/bknr-datastore.asd	(original)
+++ trunk/bknr/datastore/src/bknr-datastore.asd	Mon Feb 18 10:34:10 2008
@@ -29,7 +29,7 @@
                                             (:file "blob" :depends-on ("txn" "object" "package"))))))
 
 (defsystem :bknr-datastore-test  
-  :depends-on (:bknr-datastore :FiveAM)
+  :depends-on (:bknr-datastore :FiveAM :cl-store)
   :components ((:module "data" :components ((:file "encoding-test")
                                             ))))
 

Modified: trunk/bknr/datastore/src/data/encoding-test.lisp
==============================================================================
--- trunk/bknr/datastore/src/data/encoding-test.lisp	(original)
+++ trunk/bknr/datastore/src/data/encoding-test.lisp	Mon Feb 18 10:34:10 2008
@@ -1,8 +1,650 @@
 (in-package :bknr.datastore)
 
-(test:def-suite :bknr.datastore.encoding :in :bknr.datastore)
-(test:in-suite :bknr.datastore.encoding)
+(test:def-suite :bknr.datastore)
+(test:in-suite :bknr.datastore)
 
-(test:test dummy
-  (test:is (= 1 2)))
+(defun files-identical-content-p (path-a path-b)
+  "Are files of PATH-A and PATH-B byte per byte identical?"
+  (with-open-file (in-a path-a :element-type '(unsigned-byte 8))
+    (with-open-file (in-b path-b :element-type '(unsigned-byte 8))
+      (loop
+	 for byte-a = (read-byte in-a nil nil)
+	 for byte-b = (read-byte in-b nil nil)
+	 while (or byte-a byte-b)
+	 unless (and byte-a byte-b (= byte-a byte-b))
+	 return nil
+	 finally (return t)))))
+
+(defun congruent-p (a b)
+  "Are lisp value A and B (deeply) congruent?"
+  (let ((path-a "/tmp/a.pwgl-tmp")
+	(path-b "/tmp/b.pwgl-tmp"))
+    (cl-store:store a path-a)
+    (cl-store:store b path-b)
+    (prog1
+	(files-identical-content-p path-a path-b)
+      (delete-file path-a)
+      (delete-file path-b))))
+
+(defun copy-by-encoding (value)
+  (with-open-file (out "/tmp/bknr-encoding-test.tmp" :direction :output :if-exists :supersede
+                       :element-type '(unsigned-byte 8))
+    (encode value out))
+  (with-open-file (in "/tmp/bknr-encoding-test.tmp"
+                      :element-type '(unsigned-byte 8))
+    (decode in)))
+
+(defmacro test-encoding (name value)
+  `(test:test ,name
+     (test:is (congruent-p ,value (copy-by-encoding ,value)))))
+
+(test-encoding list.1 '(1 2 3))
+(test-encoding list.len.30 (loop repeat 30 collect 'x))
+(test-encoding list.len.254 (loop repeat 254 collect 'x))
+(test-encoding list.len.255 (loop repeat 255 collect 'x))
+(test-encoding list.len.256 (loop repeat 256 collect 'x))
+(test-encoding list.len.257 (loop repeat 257 collect 'x))
+(test-encoding list.len.3000 (loop repeat 3000 collect 'x))
+(test-encoding improper-list.1 '(1 2 3 4 . 5))
+
+(test-encoding cons.1 '(1 . 2))
+
+;;; from cl-store :)
+(test-encoding integer.1 1)
+(test-encoding integer.2 0)
+(test-encoding integer.3 23423333333333333333333333423102334)
+(test-encoding integer.4 -2322993)
+(test-encoding integer.5 most-positive-fixnum)
+(test-encoding integer.6 most-negative-fixnum)
+
+;; ratios - currently no supported
+;; (test-encoding ratio.1 1/2)
+;; (test-encoding ratio.2 234232/23434)
+;; (test-encoding ratio.3 -12/2)
+;; (test-encoding ratio.4 -6/11)
+;; (test-encoding ratio.5 23222/13)
+
+;; complex numbers - currently not supported
+;; (test-encoding complex.1 #C(0 1))
+;; (test-encoding complex.2 #C(0.0 1.0))
+;; (test-encoding complex.3 #C(32 -23455))
+;; (test-encoding complex.4 #C(-222.32 2322.21))
+;; (test-encoding complex.5 #C(-111 -1123))
+;; (test-encoding complex.6 #C(-11.2 -34.5))
+
+;; single-float
+(test-encoding single-float.1 3244.32)
+(test-encoding single-float.2 0.12)
+(test-encoding single-float.3 -233.001)
+(test-encoding single-float.4 most-positive-single-float)
+(test-encoding single-float.5 most-negative-single-float)
+
+;; double-float
+(test-encoding double-float.1 2343.3d0)
+(test-encoding double-float.2 -1211111.3343d0)
+(test-encoding double-float.3 99999999999123456789012345678222222222222290.0987654321d0)
+(test-encoding double-float.4 -99999999999123456789012345678222222222222290.0987654321d0)
+(test-encoding double-float.5 most-positive-double-float)
+(test-encoding double-float.6 most-negative-double-float)
+
+;; characters
+(test-encoding char.1 #\Space)
+(test-encoding char.2 #\f )
+(test-encoding char.3 #\Rubout)
+(test-encoding char.4 (code-char 255)) 
+
+;; various strings
+(test-encoding string.1 "foobar")
+(test-encoding string.2 "how are you")
+(test-encoding string.3 "foo
+bar")
+
+(test-encoding string.4
+               (make-array 10 :initial-element #\f :element-type 'character
+                           :fill-pointer 3))
+
+;; #+(or (and sbcl sb-unicode) lispworks clisp acl)
+;; (progn
+;;   (test-encoding unicode.1 (map #-lispworks 'string
+;;                             #+lispworks 'lw:text-string
+;;                             #'code-char (list #X20AC #X3BB)))
+;;   (test-encoding unicode.2 (intern (map #-lispworks 'string
+;;                                     #+lispworks 'lw:text-string
+;;                                     #'code-char (list #X20AC #X3BB))
+;;                                :pwgl-test-suite)))
+;; vectors
+(test-encoding vector.1 #(1 2 3 4))
+
+
+(test-encoding vector.2 (make-array 5 :element-type 'fixnum 
+                                    :initial-contents (list 1 2 3 4 5)))
+
+(test-encoding vector.4 #*101101101110)
+(test-encoding vector.3
+               (make-array 5
+                           :element-type 'fixnum
+                           :fill-pointer 2
+                           :initial-contents (list 1 2 3 4 5)))
+
+
+
+(test-encoding vector.5 #*)
+(test-encoding vector.6 #())
+
+
+;; arrays
+(test-encoding array.1
+               (make-array '(2 2) :initial-contents '((1 2) (3 4))))
+
+(test-encoding array.2
+               (make-array '(2 2) :initial-contents '((1 1) (1 1))))
+
+(test-encoding array.3
+               (make-array '(2 2) :element-type '(mod 10) :initial-element 3))
+
+(test-encoding array.4
+               (make-array  '(2 3 5) 
+                            :initial-contents
+                            '(((1 2 #\f 5 12.0) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1))
+                              ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1) 
+                               (#\Newline 1 7 #\4 #\0)))))
+
+(test-encoding array.5
+               (let* ((a1 (make-array 5))
+                      (a2 (make-array 4 :displaced-to a1
+                                      :displaced-index-offset 1))
+                      (a3 (make-array 2 :displaced-to a2
+                                      :displaced-index-offset 2)))
+                 a3))
+
+
+    
+         
+
+
+;; symbols
+
+(test-encoding symbol.1  t)
+(test-encoding symbol.2  nil)
+(test-encoding symbol.3  :foo)
+(test-encoding symbol.4  'bknr.datastore::foo)
+(test-encoding symbol.5  'make-hash-table)
+(test-encoding symbol.6 '|foo bar|)
+(test-encoding symbol.7 'foo\ bar\ baz)
+
+;; (deftest gensym.1 (progn
+;;                     (store (gensym "Foobar") *test-file*)
+;;                     (let ((new (restore *test-file*)))
+;;                       (list (symbol-package new)
+;;                             (mismatch "Foobar" (symbol-name new)))))
+;;          (nil 6))
+
+;; This failed in cl-store < 0.5.5
+;; (deftest gensym.2 (let ((x (gensym)))
+;;                     (store (list x x) *test-file*)
+;;                     (let ((new (restore *test-file*)))
+;;                       (eql (car new) (cadr new))))
+;;          t)
+
+
+;; cons
+
+(test-encoding cons.1 '(1 2 3))
+(test-encoding cons.2 '((1 2 3)))
+(test-encoding cons.3 '(#\Space 1 1.2 1.3 #(1 2 3)))
+  
+(test-encoding cons.4  '(1 . 2))
+(test-encoding cons.5  '(t . nil))
+(test-encoding cons.6 '(1 2 3 . 5))
+;; (deftest cons.7 (let ((list (cons nil nil))) ;  '#1=(#1#)))
+;;                   (setf (car list) list)
+;;                   (store list *test-file*)
+;;                   (let ((ret (restore *test-file*)))
+;;                     (eq ret (car ret))))
+;;          t)
+
+
+;; hash tables
+;; for some reason (make-hash-table) is not equalp 
+;; to (make-hash-table) with ecl.
+
+(test-encoding hash.1 (make-hash-table))
+
+(defvar *hash* (let ((in (make-hash-table :test #'equal 
+                                          :rehash-threshold 0.4 :size 20
+                                          :rehash-size 40)))
+                 (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
+                 in))
+
+(test-encoding hash.2 *hash*)
+
+
+;; ;; packages
+;; (test-encoding package.1 (find-package :cl-store))
+
+;; (defpackage foo 
+;;   (:nicknames foobar)
+;;   (:use :cl)
+;;   (:shadow cl:format)
+;;   (:export bar))
+
+;; (defun package-restores ()
+;;   (let (( *nuke-existing-packages* t))
+;;     (store (find-package :foo) *test-file*)
+;;     (delete-package :foo)
+;;     (restore *test-file*)
+;;     (list (package-name (find-package :foo))
+;;           (mapcar #'package-name (package-use-list :foo))
+;;           (package-nicknames :foo)
+;;           (equalp (remove-duplicates (package-shadowing-symbols :foo))
+;;                   (list (find-symbol "FORMAT" "FOO")))
+;;           (equalp (cl-store::external-symbols (find-package :foo))
+;;                   (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))))
+
+
+;; ; unfortunately it's difficult to portably test the internal symbols
+;; ; in a package so we just assume that it's OK.
+;; (deftest package.2 
+;;          (package-restores)
+;;          ("FOO" ("COMMON-LISP") ("FOOBAR") t t))
+
+;; ;; objects 
+(define-persistent-class foo ()
+  ((x :update)))
+
+(define-persistent-class bar (foo)
+  ((y :update)))
+
+;; (deftest standard-object.1
+;;   (let ((val (store (make-instance 'foo :x 3) *test-file*)))
+;;     (= (get-x val) (get-x (restore *test-file*))))
+;;   t)
+
+;; (deftest standard-object.2
+;;   (let ((val (store (make-instance 'bar
+;;                                    :x (list 1 "foo" 1.0)
+;;                                    :y (vector 1 2 3 4))
+;;                     *test-file*)))
+;;     (let ((ret (restore *test-file*)))
+;;       (and (equalp (get-x val) (get-x ret))
+;;            (equalp (get-y val) (get-y ret)))))
+;;   t)
+
+;; (deftest standard-object.3 
+;;   (let ((*store-class-slots* nil)
+;;         (val (make-instance 'baz :z 9)))
+;;     (store val *test-file*)
+;;     (make-instance 'baz :z 2)
+;;     (= (get-z (restore *test-file*))
+;;        2))
+;;   t)
+
+;; (deftest standard-object.4
+;;   (let ((*store-class-slots* t)
+;;         (val (make-instance 'baz :z 9)))
+;;     (store val *test-file*)
+;;     (make-instance 'baz :z 2)
+;;     (let ((ret (restore *test-file*)))
+;;       (= (get-z ret )
+;;          9)))
+;;   t)
+
+;; ;; classes
+;; (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) 
+;;                                  (restore *test-file*)
+;;                                  t)
+;;   t)
+
+;; (deftest standard-class.2 (progn (store (find-class 'bar) *test-file*)
+;;                                  (restore *test-file*)
+;;                                  t)
+;;   t)
+
+;; (deftest standard-class.3 (progn (store (find-class 'baz) *test-file*)
+;;                                  (restore *test-file*)
+;;                                  t)
+;;   t)
+
+
+
+;; ;; conditions
+;; (deftest condition.1
+;;   (handler-case (/ 1 0)
+;;     (division-by-zero (c) 
+;;       (store c *test-file*)
+;;       (typep (restore *test-file*) 'division-by-zero)))
+;;   t)
+
+;; (deftest condition.2
+;;   (handler-case (car (read-from-string "3"))
+;;     ;; allegro pre 7.0 signalled a simple-error here
+;;     ((or type-error simple-error) (c)
+;;       (store c *test-file*)
+;;       (typep (restore *test-file*) 
+;;              '(or type-error simple-error))))
+;;   t)
+
+;; ;; structure-object
+
+;; (defstruct a
+;;   a b c)
+
+;; (defstruct (b (:include a))
+;;   d e f)
+
+;; #+(or sbcl cmu lispworks openmcl) 
+;; (test-encoding structure-object.1 (make-a :a 1 :b 2 :c 3))
+;; #+(or sbcl cmu lispworks openmcl)
+;; (test-encoding structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6))
+;; #+(or sbcl cmu lispworks openmcl)
+;; (test-encoding structure-object.3 (make-b :a 1 :b (make-a :a 1 :b 3 :c 2)
+;;                                       :c #\Space :d #(1 2 3) :e (list 1 2 3)
+;;                                       :f (make-hash-table)))
+
+;; ;; setf test
+;; (test-encoding setf.1 (setf (restore *test-file*) 0))
+;; (test-encoding setf.2 (incf (restore *test-file*)))
+;; (test-encoding setf.3 (decf (restore *test-file*) 2))
+
+;; (test-encoding pathname.1 #P"/home/foo")
+;; (test-encoding pathname.2 (make-pathname :name "foo"))
+;; (test-encoding pathname.3 (make-pathname :name "foo" :type "bar"))
+                                      
+
+;; ; built-in classes
+;; (test-encoding built-in.1 (find-class 'hash-table))
+;; (test-encoding built-in.2 (find-class 'integer))
+                                  
+
+;; ;; find-backend tests
+;; (deftest find-backend.1 
+;;     (and (find-backend 'cl-store) t)
+;;   t)
+
+;; (deftest find-backend.2
+;;     (find-backend (gensym))
+;;   nil)
+
+;; (deftest find-backend.3
+;;     (handler-case (find-backend (gensym) t)
+;;       (error (c) (and c t))
+;;       (:no-error (val) (and val nil)))
+;;   t)
+
+
+
+;; ;; circular objects
+;; (defvar circ1 (let ((x (list 1 2 3 4)))
+;;                 (setf (cdr (last x)) x)))
+;; (deftest circ.1 (progn (store circ1 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (eql (cddddr x) x)))
+;;   t)
+
+;; (defvar circ2 (let ((x (list 2 3 4 4 5)))
+;;                 (setf (second x) x)))
+;; (deftest circ.2 (progn (store circ2 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (eql (second x) x)))
+;;   t)
+
+
+
+;; (defvar circ3 (let ((x (list (list 1 2 3 4 )
+;;                              (list 5 6 7 8)
+;;                              9)))
+;;                 (setf (second x) (car x))
+;;                 (setf (cdr (last x)) x)
+;;                 x))
+
+;; (deftest circ.3 (progn (store circ3 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (and (eql (second x) (car x))
+;;                               (eql (cdddr x) x))))
+;;   t)
+
+
+;; (defvar circ4 (let ((x (make-hash-table)))
+;;                 (setf (gethash 'first x) (make-hash-table))
+;;                 (setf (gethash 'second x) (gethash 'first x))
+;;                 (setf (gethash 'inner (gethash 'first x)) x)
+;;                 x))
+
+;; (deftest circ.4 (progn (store circ4 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (and (eql (gethash 'first x)
+;;                                   (gethash 'second x))
+;;                               (eql x
+;;                                   (gethash 'inner
+;;                                            (gethash 'first x))))))
+;;   t)
+
+;; (deftest circ.5  (let ((circ5 (make-instance 'bar)))
+;;                    (setf (get-y circ5) circ5)
+;;                    (store circ5 *test-file*)
+;;                    (let ((x (restore *test-file*)))
+;;                      (eql x (get-y x))))
+;;   t)
+
+
+;; (defvar circ6 (let ((y (make-array '(2 2 2)
+;;                                    :initial-contents '((("foo" "bar") 
+;;                                                         ("me" "you"))
+;;                                                        ((5 6) (7 8))))))
+;;                 (setf (aref y 1 1 1) y)
+;;                 (setf (aref y 0 0 0) (aref y 1 1 1))
+;;                 y))
+
+
+;; (deftest circ.6 (progn (store circ6 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (and (eql (aref x 1 1 1) x)
+;;                               (eql (aref x 0 0 0) (aref x 1 1 1)))))
+;;   t)
+
+
+
+;; (defvar circ7 (let ((x (make-a)))
+;;                 (setf (a-a x) x)))
+
+;; #+(or sbcl cmu lispworks)
+;; (deftest circ.7 (progn (store circ7 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (eql (a-a x) x)))
+;;   t)
+
+;; (defvar circ.8 (let ((x "foo"))
+;;                  (make-pathname :name x :type x)))
+
+
+;; ;; clisp apparently creates a copy of the strings in a pathname 
+;; ;; so a test for eqness is pointless.
+;; #-clisp
+;; (deftest circ.8 (progn (store circ.8 *test-file*)
+;;                        (let ((x (restore *test-file*)))
+;;                          (eql (pathname-name x)
+;;                               (pathname-type x))))
+;;   t)
+
+
+;; (deftest circ.9 (let ((val (vector "foo" "bar" "baz" 1 2)))
+;;                   (setf (aref val 3) val)
+;;                   (setf (aref val 4) (aref val 0))
+;;                   (store val *test-file*)
+;;                   (let ((rest (restore *test-file*)))
+;;                     (and (eql rest (aref rest 3))
+;;                          (eql (aref rest 4) (aref rest 0)))))
+;;   t)
+                        
+;; (deftest circ.10 (let* ((a1 (make-array 5))
+;;                         (a2 (make-array 4 :displaced-to a1
+;;                                         :displaced-index-offset 1))
+;;                         (a3 (make-array 2 :displaced-to a2
+;;                                         :displaced-index-offset 2)))
+;;                    (setf (aref a3 1) a3)
+;;                    (store a3 *test-file*)
+;;                    (let ((ret (restore *test-file*)))
+;;                      (eql a3 (aref a3 1))))
+;;   t)
+
+;; (defvar circ.11 (let ((x (make-hash-table)))
+;;                   (setf (gethash x x) x)
+;;                   x))
+
+;; (deftest circ.11 (progn (store circ.11 *test-file*)
+;;                         (let ((val (restore *test-file*)))
+;;                           (eql val (gethash val val))))
+;;   t)
+
+;; (deftest circ.12 (let ((x (vector 1 2 "foo" 4 5)))
+;;                    (setf (aref x 0) x)
+;;                    (setf (aref x 1) (aref x 2))
+;;                    (store x *test-file*)
+;;                    (let ((ret (restore *test-file*)))
+;;                      (and (eql (aref ret 0) ret)
+;;                           (eql (aref ret 1) (aref ret 2)))))
+;;   t)
+
+;; (defclass foo.1 ()
+;;   ((a :accessor foo1-a)))
+
+;; ;; a test from Robert Sedgwick which crashed in earlier
+;; ;; versions (pre 0.2)
+;; (deftest circ.13 (let ((foo (make-instance 'foo.1))
+;;                        (bar (make-instance 'foo.1)))
+;;                    (setf (foo1-a foo) bar)
+;;                    (setf (foo1-a bar) foo)
+;;                    (store (list foo) *test-file*)
+;;                    (let ((ret (car (restore *test-file*))))
+;;                      (and (eql ret (foo1-a (foo1-a ret)))
+;;                           (eql (foo1-a ret)
+;;                               (foo1-a (foo1-a (foo1-a ret)))))))
+;;   t)
+
+
+;; (deftest circ.14 (let ((list '#1=(1 2 3 #1# . #1#)))
+;;                    (store list *test-file*)
+;;                    (let ((ret (restore *test-file*)))
+;;                      (and (eq ret (cddddr ret))
+;;                           (eq (fourth ret) ret))))
+;;          t)
+                   
+
+
+
+;; (deftest circ.15 (let ((list '#1=(1 2 3 #2=(#2#) . #1#)))
+;;                    (store list *test-file*)
+;;                    (let ((ret (restore *test-file*)))
+;;                      (and (eq ret (cddddr ret))
+;;                           (eq (fourth ret)
+;;                               (car (fourth ret))))))
+;;          t)
+
+
+
+;; ;; this had me confused for a while since what was
+;; ;; restored #1=(1 (#1#) #1#) looks nothing like this list,
+;; ;; but it turns out that it is correct
+;; (deftest circ.16  (let ((list '#1=(1 #2=(#1#) . #2#)))
+;;                     (store list *test-file*)
+;;                     (let ((ret (restore *test-file*)))
+;;                       (and (eq ret (caadr ret))
+;;                            (eq ret (third ret)))))
+;;          t)
+
+;; ;; large circular lists
+;; (deftest large.1 (let ((list (make-list 100000)))
+;;                    (setf (cdr (last list)) list)
+;;                    (store list *test-file*)
+;;                    (let ((ret (restore *test-file*)))
+;;                      (eq (nthcdr 100000 ret) ret)))
+;;          t)
+
+;; ;; large dotted lists
+;; (test-encoding large.2 (let ((list (make-list 100000)))
+;;                      (setf (cdr (last list)) 'foo)
+;;                      list))
+
+
+
+;; ;; custom storing
+;; (defclass random-obj () ((size :accessor size :initarg :size)))
+
+;; (defvar *random-obj-code* (register-code 100 'random-obj))
+
+;; (defstore-cl-store (obj random-obj buff)
+;;   (output-type-code *random-obj-code* buff)
+;;   (store-object (size obj) buff))
+
+;; (defrestore-cl-store (random-obj buff)
+;;   (random (restore-object buff)))
+
+  
+;; (deftest custom.1
+;;   (progn (store (make-instance 'random-obj :size 5) *test-file* )
+;;          (typep (restore *test-file*) '(integer 0 4)))
+;;   t)
+
+
+
+;; (test-encoding function.1 #'restores)
+;; (test-encoding function.2 #'car)
+
+;; (test-encoding gfunction.1 #'cl-store:restore)
+;; (test-encoding gfunction.2 #'cl-store:store)
+;; #-clisp
+;; (test-encoding gfunction.3 #'(setf get-y))
+
+
+;; (deftest nocirc.1 
+;;     (let* ((string "FOO")
+;;            (list `(,string . ,string))
+;;            (*check-for-circs* nil))
+;;       (store list *test-file*)
+;;       (let ((res (restore *test-file*)))
+;;         (and (not (eql (car res) (cdr res)))
+;;              (string= (car res) (cdr res)))))
+;;   t)
+
+
+;; (defstruct st.bar x)
+;; (defstruct (st.foo (:conc-name f-)
+;;                    (:constructor fooo (z y x))
+;;                    (:copier cp-foo)
+;;                    (:include st.bar)
+;;                    (:predicate is-foo)
+;;                    (:print-function (lambda (obj st dep)
+;;                                       (declare (ignore dep))
+;;                                       (print-unreadable-object (obj st :type t) 
+;;                                         (format st "~A" (f-x obj))))))
+;;   (y 0 :type integer) (z nil :type simple-string))
+
+
+;; #+(or sbcl cmu)
+;; (deftest struct-class.1
+;;     (let* ((obj (fooo "Z" 2 3))
+;;            (string (format nil "~A" obj)))
+;;       (let ((*nuke-existing-classes* t))
+;;         (store (find-class 'st.foo) *test-file*)
+;;         (fmakunbound 'cp-foo)
+;;         (fmakunbound 'is-foo)
+;;         (fmakunbound 'fooo)
+;;         (fmakunbound 'f-x)
+;;         (fmakunbound 'f-y)
+;;         (fmakunbound 'f-z)
+;;         (restore *test-file*)
+;;         (let* ((new-obj (cp-foo (fooo "Z" 2 3)))
+;;                (new-string (format nil "~A" new-obj)))
+;;           (list (is-foo new-obj) (equalp obj new-obj)
+;;                 (string= new-string string)
+;;                 (f-x new-obj) (f-y new-obj) (f-z new-obj)))))
+;;   (t t t 3 2 "Z"))
+
+;; (defun run-tests (backend)
+;;   (with-backend backend
+;;     (regression-test:do-tests))
+;;   (when (probe-file *test-file*)
+;;     (ignore-errors (delete-file *test-file*))))
+
+;; ;; EOF
 


From ksprotte at common-lisp.net  Mon Feb 18 15:44:54 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 10:44:54 -0500 (EST)
Subject: [bknr-cvs] r2556 - trunk/bknr/datastore/src/data
Message-ID: <20080218154454.EAB0D4D0C0@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 10:44:54 2008
New Revision: 2556

Modified:
   trunk/bknr/datastore/src/data/encoding-test.lisp
Log:
changed a bit the encoding tests


Modified: trunk/bknr/datastore/src/data/encoding-test.lisp
==============================================================================
--- trunk/bknr/datastore/src/data/encoding-test.lisp	(original)
+++ trunk/bknr/datastore/src/data/encoding-test.lisp	Mon Feb 18 10:44:54 2008
@@ -140,6 +140,9 @@
                (make-array '(2 2) :initial-contents '((1 1) (1 1))))
 
 (test-encoding array.3
+               (make-array '(2 2) :element-type 'fixnum :initial-element 3))
+
+(test-encoding array.3b
                (make-array '(2 2) :element-type '(mod 10) :initial-element 3))
 
 (test-encoding array.4
@@ -209,14 +212,15 @@
 ;; to (make-hash-table) with ecl.
 
 (test-encoding hash.1 (make-hash-table))
+(test-encoding hash.2 (make-hash-table :test #'equal))
 
-(defvar *hash* (let ((in (make-hash-table :test #'equal 
-                                          :rehash-threshold 0.4 :size 20
-                                          :rehash-size 40)))
-                 (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
-                 in))
+;; (defvar *hash* (let ((in (make-hash-table :test #'equal 
+;;                                           :rehash-threshold 0.4 :size 20
+;;                                           :rehash-size 40)))
+;;                  (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
+;;                  in))
 
-(test-encoding hash.2 *hash*)
+;; (test-encoding hash.3 *hash*)
 
 
 ;; ;; packages


From ksprotte at common-lisp.net  Mon Feb 18 17:09:57 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 12:09:57 -0500 (EST)
Subject: [bknr-cvs] r2557 - trunk/bknr/datastore/src/data
Message-ID: <20080218170957.5E16B405F@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 12:09:56 2008
New Revision: 2557

Modified:
   trunk/bknr/datastore/src/data/encoding-test.lisp
Log:
created tickets for some tests that failed - now skipped


Modified: trunk/bknr/datastore/src/data/encoding-test.lisp
==============================================================================
--- trunk/bknr/datastore/src/data/encoding-test.lisp	(original)
+++ trunk/bknr/datastore/src/data/encoding-test.lisp	Mon Feb 18 12:09:56 2008
@@ -35,8 +35,12 @@
     (decode in)))
 
 (defmacro test-encoding (name value)
-  `(test:test ,name
-     (test:is (congruent-p ,value (copy-by-encoding ,value)))))
+  (let ((options (arnesi:ensure-list name)))
+    (destructuring-bind (name &key skip) options
+      `(test:test ,name
+         ,(if skip
+              `(test:skip ,skip)
+              `(test:is (congruent-p ,value (copy-by-encoding ,value))))))))
 
 (test-encoding list.1 '(1 2 3))
 (test-encoding list.len.30 (loop repeat 30 collect 'x))
@@ -91,7 +95,7 @@
 (test-encoding char.1 #\Space)
 (test-encoding char.2 #\f )
 (test-encoding char.3 #\Rubout)
-(test-encoding char.4 (code-char 255)) 
+(test-encoding char.4 (code-char 255))
 
 ;; various strings
 (test-encoding string.1 "foobar")
@@ -99,7 +103,7 @@
 (test-encoding string.3 "foo
 bar")
 
-(test-encoding string.4
+(test-encoding (string.4 :skip "will be fixed later - http://trac.common-lisp.net/bknr/ticket/30")
                (make-array 10 :initial-element #\f :element-type 'character
                            :fill-pointer 3))
 
@@ -116,7 +120,7 @@
 (test-encoding vector.1 #(1 2 3 4))
 
 
-(test-encoding vector.2 (make-array 5 :element-type 'fixnum 
+(test-encoding vector.2 (make-array 5 :element-type 'fixnum
                                     :initial-contents (list 1 2 3 4 5)))
 
 (test-encoding vector.4 #*101101101110)
@@ -142,27 +146,26 @@
 (test-encoding array.3
                (make-array '(2 2) :element-type 'fixnum :initial-element 3))
 
-(test-encoding array.3b
+(test-encoding (array.3b :skip "will be fixed later - http://trac.common-lisp.net/bknr/ticket/31")
                (make-array '(2 2) :element-type '(mod 10) :initial-element 3))
 
 (test-encoding array.4
-               (make-array  '(2 3 5) 
+               (make-array  '(2 3 5)
                             :initial-contents
                             '(((1 2 #\f 5 12.0) (#\Space "fpp" 4 1 0) ('d "foo" #() 3 -1))
-                              ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1) 
+                              ((0 #\a #\b 4 #\q) (12.0d0 0 '(d) 4 1)
                                (#\Newline 1 7 #\4 #\0)))))
 
-(test-encoding array.5
-               (let* ((a1 (make-array 5))
-                      (a2 (make-array 4 :displaced-to a1
-                                      :displaced-index-offset 1))
-                      (a3 (make-array 2 :displaced-to a2
-                                      :displaced-index-offset 2)))
-                 a3))
+;; (test-encoding array.5
+;;                (let* ((a1 (make-array 5))
+;;                       (a2 (make-array 4 :displaced-to a1
+;;                                       :displaced-index-offset 1))
+;;                       (a3 (make-array 2 :displaced-to a2
+;;                                       :displaced-index-offset 2)))
+;;                  a3))
+
 
 
-    
-         
 
 
 ;; symbols
@@ -195,7 +198,7 @@
 (test-encoding cons.1 '(1 2 3))
 (test-encoding cons.2 '((1 2 3)))
 (test-encoding cons.3 '(#\Space 1 1.2 1.3 #(1 2 3)))
-  
+
 (test-encoding cons.4  '(1 . 2))
 (test-encoding cons.5  '(t . nil))
 (test-encoding cons.6 '(1 2 3 . 5))
@@ -208,25 +211,25 @@
 
 
 ;; hash tables
-;; for some reason (make-hash-table) is not equalp 
+;; for some reason (make-hash-table) is not equalp
 ;; to (make-hash-table) with ecl.
 
 (test-encoding hash.1 (make-hash-table))
 (test-encoding hash.2 (make-hash-table :test #'equal))
 
-;; (defvar *hash* (let ((in (make-hash-table :test #'equal 
+;; (defvar *hash* (let ((in (make-hash-table :test #'equal
 ;;                                           :rehash-threshold 0.4 :size 20
 ;;                                           :rehash-size 40)))
 ;;                  (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
 ;;                  in))
 
 ;; (test-encoding hash.3 *hash*)
-
+(test:test hash.3 (test:skip "will be fixed later - http://trac.common-lisp.net/bknr/ticket/29"))
 
 ;; ;; packages
 ;; (test-encoding package.1 (find-package :cl-store))
 
-;; (defpackage foo 
+;; (defpackage foo
 ;;   (:nicknames foobar)
 ;;   (:use :cl)
 ;;   (:shadow cl:format)
@@ -248,11 +251,11 @@
 
 ;; ; unfortunately it's difficult to portably test the internal symbols
 ;; ; in a package so we just assume that it's OK.
-;; (deftest package.2 
+;; (deftest package.2
 ;;          (package-restores)
 ;;          ("FOO" ("COMMON-LISP") ("FOOBAR") t t))
 
-;; ;; objects 
+;; ;; objects
 (define-persistent-class foo ()
   ((x :update)))
 
@@ -274,7 +277,7 @@
 ;;            (equalp (get-y val) (get-y ret)))))
 ;;   t)
 
-;; (deftest standard-object.3 
+;; (deftest standard-object.3
 ;;   (let ((*store-class-slots* nil)
 ;;         (val (make-instance 'baz :z 9)))
 ;;     (store val *test-file*)
@@ -294,7 +297,7 @@
 ;;   t)
 
 ;; ;; classes
-;; (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*) 
+;; (deftest standard-class.1 (progn (store (find-class 'foo) *test-file*)
 ;;                                  (restore *test-file*)
 ;;                                  t)
 ;;   t)
@@ -314,7 +317,7 @@
 ;; ;; conditions
 ;; (deftest condition.1
 ;;   (handler-case (/ 1 0)
-;;     (division-by-zero (c) 
+;;     (division-by-zero (c)
 ;;       (store c *test-file*)
 ;;       (typep (restore *test-file*) 'division-by-zero)))
 ;;   t)
@@ -324,7 +327,7 @@
 ;;     ;; allegro pre 7.0 signalled a simple-error here
 ;;     ((or type-error simple-error) (c)
 ;;       (store c *test-file*)
-;;       (typep (restore *test-file*) 
+;;       (typep (restore *test-file*)
 ;;              '(or type-error simple-error))))
 ;;   t)
 
@@ -336,7 +339,7 @@
 ;; (defstruct (b (:include a))
 ;;   d e f)
 
-;; #+(or sbcl cmu lispworks openmcl) 
+;; #+(or sbcl cmu lispworks openmcl)
 ;; (test-encoding structure-object.1 (make-a :a 1 :b 2 :c 3))
 ;; #+(or sbcl cmu lispworks openmcl)
 ;; (test-encoding structure-object.2 (make-b :a 1 :b 2 :c 3 :d 4 :e 5 :f 6))
@@ -353,15 +356,15 @@
 ;; (test-encoding pathname.1 #P"/home/foo")
 ;; (test-encoding pathname.2 (make-pathname :name "foo"))
 ;; (test-encoding pathname.3 (make-pathname :name "foo" :type "bar"))
-                                      
+
 
 ;; ; built-in classes
 ;; (test-encoding built-in.1 (find-class 'hash-table))
 ;; (test-encoding built-in.2 (find-class 'integer))
-                                  
+
 
 ;; ;; find-backend tests
-;; (deftest find-backend.1 
+;; (deftest find-backend.1
 ;;     (and (find-backend 'cl-store) t)
 ;;   t)
 
@@ -432,7 +435,7 @@
 
 
 ;; (defvar circ6 (let ((y (make-array '(2 2 2)
-;;                                    :initial-contents '((("foo" "bar") 
+;;                                    :initial-contents '((("foo" "bar")
 ;;                                                         ("me" "you"))
 ;;                                                        ((5 6) (7 8))))))
 ;;                 (setf (aref y 1 1 1) y)
@@ -461,7 +464,7 @@
 ;;                  (make-pathname :name x :type x)))
 
 
-;; ;; clisp apparently creates a copy of the strings in a pathname 
+;; ;; clisp apparently creates a copy of the strings in a pathname
 ;; ;; so a test for eqness is pointless.
 ;; #-clisp
 ;; (deftest circ.8 (progn (store circ.8 *test-file*)
@@ -479,7 +482,7 @@
 ;;                     (and (eql rest (aref rest 3))
 ;;                          (eql (aref rest 4) (aref rest 0)))))
 ;;   t)
-                        
+
 ;; (deftest circ.10 (let* ((a1 (make-array 5))
 ;;                         (a2 (make-array 4 :displaced-to a1
 ;;                                         :displaced-index-offset 1))
@@ -532,7 +535,7 @@
 ;;                      (and (eq ret (cddddr ret))
 ;;                           (eq (fourth ret) ret))))
 ;;          t)
-                   
+
 
 
 
@@ -583,7 +586,7 @@
 ;; (defrestore-cl-store (random-obj buff)
 ;;   (random (restore-object buff)))
 
-  
+
 ;; (deftest custom.1
 ;;   (progn (store (make-instance 'random-obj :size 5) *test-file* )
 ;;          (typep (restore *test-file*) '(integer 0 4)))
@@ -600,7 +603,7 @@
 ;; (test-encoding gfunction.3 #'(setf get-y))
 
 
-;; (deftest nocirc.1 
+;; (deftest nocirc.1
 ;;     (let* ((string "FOO")
 ;;            (list `(,string . ,string))
 ;;            (*check-for-circs* nil))
@@ -619,7 +622,7 @@
 ;;                    (:predicate is-foo)
 ;;                    (:print-function (lambda (obj st dep)
 ;;                                       (declare (ignore dep))
-;;                                       (print-unreadable-object (obj st :type t) 
+;;                                       (print-unreadable-object (obj st :type t)
 ;;                                         (format st "~A" (f-x obj))))))
 ;;   (y 0 :type integer) (z nil :type simple-string))
 
@@ -651,4 +654,3 @@
 ;;     (ignore-errors (delete-file *test-file*))))
 
 ;; ;; EOF
-


From ksprotte at common-lisp.net  Mon Feb 18 17:20:25 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 12:20:25 -0500 (EST)
Subject: [bknr-cvs] r2558 - in trunk/bknr/datastore/src: . data
Message-ID: <20080218172025.2C2FE5C197@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 12:20:24 2008
New Revision: 2558

Modified:
   trunk/bknr/datastore/src/bknr-datastore.asd
   trunk/bknr/datastore/src/data/encoding-test.lisp
Log:
use of bknr.utils:with-temp-file in encoding-test - thanks


Modified: trunk/bknr/datastore/src/bknr-datastore.asd
==============================================================================
--- trunk/bknr/datastore/src/bknr-datastore.asd	(original)
+++ trunk/bknr/datastore/src/bknr-datastore.asd	Mon Feb 18 12:20:24 2008
@@ -29,7 +29,7 @@
                                             (:file "blob" :depends-on ("txn" "object" "package"))))))
 
 (defsystem :bknr-datastore-test  
-  :depends-on (:bknr-datastore :FiveAM :cl-store)
+  :depends-on (:bknr-datastore :fiveam :cl-store :bknr-utils)
   :components ((:module "data" :components ((:file "encoding-test")
                                             ))))
 

Modified: trunk/bknr/datastore/src/data/encoding-test.lisp
==============================================================================
--- trunk/bknr/datastore/src/data/encoding-test.lisp	(original)
+++ trunk/bknr/datastore/src/data/encoding-test.lisp	Mon Feb 18 12:20:24 2008
@@ -17,22 +17,22 @@
 
 (defun congruent-p (a b)
   "Are lisp value A and B (deeply) congruent?"
-  (let ((path-a "/tmp/a.pwgl-tmp")
-	(path-b "/tmp/b.pwgl-tmp"))
-    (cl-store:store a path-a)
-    (cl-store:store b path-b)
-    (prog1
-	(files-identical-content-p path-a path-b)
-      (delete-file path-a)
-      (delete-file path-b))))
+  (bknr.utils:with-temp-file (path-a)
+    (bknr.utils:with-temp-file (path-b)
+      (cl-store:store a path-a)
+      (cl-store:store b path-b)
+      (prog1
+          (files-identical-content-p path-a path-b)
+        (delete-file path-a)
+        (delete-file path-b)))))
 
 (defun copy-by-encoding (value)
-  (with-open-file (out "/tmp/bknr-encoding-test.tmp" :direction :output :if-exists :supersede
-                       :element-type '(unsigned-byte 8))
-    (encode value out))
-  (with-open-file (in "/tmp/bknr-encoding-test.tmp"
-                      :element-type '(unsigned-byte 8))
-    (decode in)))
+  (bknr.utils:with-temp-file (path)
+    (with-open-file (out path :direction :output :if-exists :supersede
+                         :element-type '(unsigned-byte 8))
+      (encode value out))
+    (with-open-file (in path :element-type '(unsigned-byte 8))
+      (decode in))))
 
 (defmacro test-encoding (name value)
   (let ((options (arnesi:ensure-list name)))
@@ -653,4 +653,3 @@
 ;;   (when (probe-file *test-file*)
 ;;     (ignore-errors (delete-file *test-file*))))
 
-;; ;; EOF


From ksprotte at common-lisp.net  Mon Feb 18 18:28:42 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Mon, 18 Feb 2008 13:28:42 -0500 (EST)
Subject: [bknr-cvs] r2559 - in trunk: bknr/datastore/src bknr/modules
	bknr/web/src projects/bos/m2 projects/bos/web
	projects/hello-web/src projects/lisp-ecoop/src
	projects/mah-jongg/src projects/quickhoney/src
	projects/scrabble/src projects/unmaintained/eboy/src
	projects/unmaintained/raw-data/mcp
	projects/unmaintained/saugnapf/src
Message-ID: <20080218182842.A34361603B@common-lisp.net>

Author: ksprotte
Date: Mon Feb 18 13:28:38 2008
New Revision: 2559

Added:
   trunk/bknr/datastore/src/bknr.data.impex.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-data-impex.asd
   trunk/bknr/datastore/src/bknr.datastore.asd
      - copied, changed from r2558, trunk/bknr/datastore/src/bknr-datastore.asd
   trunk/bknr/datastore/src/bknr.impex.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-impex.asd
   trunk/bknr/datastore/src/bknr.indices.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-indices.asd
   trunk/bknr/datastore/src/bknr.skip-list.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-skip-list.asd
   trunk/bknr/datastore/src/bknr.utils.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-utils.asd
   trunk/bknr/datastore/src/bknr.xml.asd
      - copied, changed from r2556, trunk/bknr/datastore/src/bknr-xml.asd
   trunk/bknr/modules/bknr.modules.asd
      - copied, changed from r2556, trunk/bknr/modules/bknr-modules.asd
   trunk/bknr/web/src/bknr.web.asd
      - copied, changed from r2556, trunk/bknr/web/src/bknr-web.asd
Removed:
   trunk/bknr/datastore/src/bknr-data-impex.asd
   trunk/bknr/datastore/src/bknr-datastore.asd
   trunk/bknr/datastore/src/bknr-impex.asd
   trunk/bknr/datastore/src/bknr-indices.asd
   trunk/bknr/datastore/src/bknr-skip-list.asd
   trunk/bknr/datastore/src/bknr-utils.asd
   trunk/bknr/datastore/src/bknr-xml.asd
   trunk/bknr/modules/bknr-modules.asd
   trunk/bknr/web/src/bknr-web.asd
Modified:
   trunk/projects/bos/m2/bos.m2.asd
   trunk/projects/bos/web/bos.web.asd
   trunk/projects/hello-web/src/hello-web.asd
   trunk/projects/lisp-ecoop/src/lisp-ecoop.asd
   trunk/projects/mah-jongg/src/mah-jongg.asd
   trunk/projects/quickhoney/src/quickhoney.asd
   trunk/projects/scrabble/src/scrabble.asd
   trunk/projects/unmaintained/eboy/src/eboy.asd
   trunk/projects/unmaintained/raw-data/mcp/mcp.asd
   trunk/projects/unmaintained/saugnapf/src/saugnapf.asd
Log:
renamed bknr asd files: e.g. bknr.web.asd

Copied: trunk/bknr/datastore/src/bknr.data.impex.asd (from r2556, trunk/bknr/datastore/src/bknr-data-impex.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-data-impex.asd	(original)
+++ trunk/bknr/datastore/src/bknr.data.impex.asd	Mon Feb 18 13:28:38 2008
@@ -1,12 +1,12 @@
 
 (in-package :cl-user)
 
-(defpackage :bknr-data-impex.system
+(defpackage :bknr.data.impex.system
   (:use :cl :asdf))
 
-(in-package :bknr-data-impex.system)
+(in-package :bknr.data.impex.system)
 
-(defsystem :bknr-data-impex
+(defsystem :bknr.data.impex
     :name "baikonour datastore with xml impex"
     :author "Hans Huebner <hans at huebner.org>"
     :author "Manuel Odendahl <manuel at bl0rg.net>"
@@ -15,7 +15,7 @@
     :licence "BSD"
     :description "baikonour - launchpad for lisp satellites"
 
-    :depends-on (:cl-interpol :unit-test :bknr-utils :bknr-indices
-			      :bknr-datastore :bknr-impex)
+    :depends-on (:cl-interpol :unit-test :bknr.utils :bknr.indices
+			      :bknr.datastore :bknr.impex)
 
     :components ((:module "data" :components ((:file "xml-object")))))

Copied: trunk/bknr/datastore/src/bknr.datastore.asd (from r2558, trunk/bknr/datastore/src/bknr-datastore.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-datastore.asd	(original)
+++ trunk/bknr/datastore/src/bknr.datastore.asd	Mon Feb 18 13:28:38 2008
@@ -2,12 +2,12 @@
 
 (in-package :cl-user)
 
-(defpackage :bknr-datastore.system
+(defpackage :bknr.datastore.system
   (:use :cl :asdf))
 
-(in-package :bknr-datastore.system)
+(in-package :bknr.datastore.system)
 
-(defsystem :bknr-datastore
+(defsystem :bknr.datastore
   :name "baikonour datastore"
   :author "Hans Huebner <hans at huebner.org>"
   :author "Manuel Odendahl <manuel at bl0rg.net>"
@@ -19,8 +19,8 @@
   :depends-on (:cl-interpol
                :closer-mop
                :unit-test
-               :bknr-utils
-               :bknr-indices)
+               :bknr.utils
+               :bknr.indices)
 
   :components ((:module "data" :components ((:file "package")
                                             (:file "encoding" :depends-on ("package"))
@@ -28,11 +28,11 @@
                                             (:file "object" :depends-on ("txn" "package"))
                                             (:file "blob" :depends-on ("txn" "object" "package"))))))
 
-(defsystem :bknr-datastore-test  
-  :depends-on (:bknr-datastore :fiveam :cl-store :bknr-utils)
+(defsystem :bknr.datastore.test  
+  :depends-on (:bknr.datastore :fiveam :cl-store :bknr.utils)
   :components ((:module "data" :components ((:file "encoding-test")
                                             ))))
 
-(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :bknr-datastore))))
-  (asdf:oos 'asdf:load-op :bknr-datastore-test)
+(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :bknr.datastore))))
+  (asdf:oos 'asdf:load-op :bknr.datastore.test)
   (funcall (intern (string :run!) (string :it.bese.FiveAM)) :bknr.datastore))

Copied: trunk/bknr/datastore/src/bknr.impex.asd (from r2556, trunk/bknr/datastore/src/bknr-impex.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-impex.asd	(original)
+++ trunk/bknr/datastore/src/bknr.impex.asd	Mon Feb 18 13:28:38 2008
@@ -3,16 +3,11 @@
 (in-package :cl-user)
 
 (defpackage :bknr.impex.system
-  (:use :cl :asdf)
-  (:export #:*bknr-impex-directory*))
+  (:use :cl :asdf))
 
 (in-package :bknr.impex.system)
 
-(defparameter *bknr-impex-directory*
-    (make-pathname :name nil :type nil :version nil
-		   :defaults (parse-namestring *load-truename*)))
-
-(defsystem :bknr-impex
+(defsystem :bknr.impex
   :name "BKNR impex"
   :author "Manuel Odendahl <manuel at bl0rg.net>"
   :version "0"
@@ -21,7 +16,7 @@
   :description "BKNR XML import/export"
   :long-description ""
 
-  :depends-on (:cl-interpol :cxml :closer-mop :bknr-utils :bknr-xml :bknr-indices)
+  :depends-on (:cl-interpol :cxml :closer-mop :bknr.utils :bknr.xml :bknr.indices)
 
   :components ((:module "xml-impex"
 			:components

Copied: trunk/bknr/datastore/src/bknr.indices.asd (from r2556, trunk/bknr/datastore/src/bknr-indices.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-indices.asd	(original)
+++ trunk/bknr/datastore/src/bknr.indices.asd	Mon Feb 18 13:28:38 2008
@@ -3,16 +3,11 @@
 (in-package :cl-user)
 
 (defpackage :bknr.indices.system
-  (:use :cl :asdf)
-  (:export :*bknr-indices-directory*))
+  (:use :cl :asdf))
 
 (in-package :bknr.indices.system)
 
-(defparameter *bknr-indices-directory*
-    (make-pathname :name nil :type nil :version nil
-		   :defaults (parse-namestring *load-truename*)))
-
-(defsystem :bknr-indices
+(defsystem :bknr.indices
   :name "bknr indices"
   :author "Manuel Odendahl <manuel at bl0rg.net>"
   :version "0"
@@ -21,7 +16,7 @@
   :description "CLOS class indices"
   :long-description ""
 
-  :depends-on (:cl-interpol :bknr-utils :bknr-skip-list)
+  :depends-on (:cl-interpol :bknr.utils :bknr.skip-list)
 
   :components ((:module "indices"
 			:components

Copied: trunk/bknr/datastore/src/bknr.skip-list.asd (from r2556, trunk/bknr/datastore/src/bknr-skip-list.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-skip-list.asd	(original)
+++ trunk/bknr/datastore/src/bknr.skip-list.asd	Mon Feb 18 13:28:38 2008
@@ -5,7 +5,7 @@
 
 (in-package :bknr.skip-list.system)
 
-(defsystem :bknr-skip-list
+(defsystem :bknr.skip-list
     :name "skip-list"
     :author "Manuel Odendahl <manuel at bl0rg.net>"
     :version "0"

Copied: trunk/bknr/datastore/src/bknr.utils.asd (from r2556, trunk/bknr/datastore/src/bknr-utils.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-utils.asd	(original)
+++ trunk/bknr/datastore/src/bknr.utils.asd	Mon Feb 18 13:28:38 2008
@@ -7,7 +7,7 @@
 
 (in-package :bknr.utils.system)
 
-(defsystem :bknr-utils
+(defsystem :bknr.utils
     :name "baikonour"
     :author "Hans Huebner <hans at huebner.org>"
     :author "Manuel Odendahl <manuel at bl0rg.net>"

Copied: trunk/bknr/datastore/src/bknr.xml.asd (from r2556, trunk/bknr/datastore/src/bknr-xml.asd)
==============================================================================
--- trunk/bknr/datastore/src/bknr-xml.asd	(original)
+++ trunk/bknr/datastore/src/bknr.xml.asd	Mon Feb 18 13:28:38 2008
@@ -7,7 +7,7 @@
 
 (in-package :bknr.xml.system)
 
-(defsystem :bknr-xml
+(defsystem :bknr.xml
     :name "baikonour"
     :author "Hans Huebner <hans at huebner.org>"
     :author "Manuel Odendahl <manuel at bl0rg.net>"

Copied: trunk/bknr/modules/bknr.modules.asd (from r2556, trunk/bknr/modules/bknr-modules.asd)
==============================================================================
--- trunk/bknr/modules/bknr-modules.asd	(original)
+++ trunk/bknr/modules/bknr.modules.asd	Mon Feb 18 13:28:38 2008
@@ -1,11 +1,11 @@
 (in-package :cl-user)
 
-(defpackage :bknr.system
+(defpackage :bknr.modules.system
   (:use :cl :asdf))
 
-(in-package :bknr.system)
+(in-package :bknr.modules.system)
 
-(defsystem :bknr-modules
+(defsystem :bknr.modules
     :name "baikonour"
     :author "Hans Huebner <hans at huebner.org>"
     :author "Manuel Odendahl <manuel at bl0rg.net>"
@@ -22,10 +22,10 @@
 		 :cl-smtp
 		 :cxml
 		 :unit-test
-		 :bknr-utils
+		 :bknr.utils
 		 :puri
 		 :stem
-		 :bknr-web
+		 :bknr.web
 		 :parenscript)
 
     :components ((:file "packages")

Copied: trunk/bknr/web/src/bknr.web.asd (from r2556, trunk/bknr/web/src/bknr-web.asd)
==============================================================================
--- trunk/bknr/web/src/bknr-web.asd	(original)
+++ trunk/bknr/web/src/bknr.web.asd	Mon Feb 18 13:28:38 2008
@@ -1,16 +1,11 @@
 (in-package :cl-user)
 
-(defpackage :bknr.system
-  (:use :cl :asdf)
-  (:export :*bknr-directory*))
+(defpackage :bknr.web.system
+  (:use :cl :asdf))
 
-(in-package :bknr.system)
+(in-package :bknr.web.system)
 
-(defparameter *bknr-directory*
-  (make-pathname :name nil :type nil :version nil
-		 :defaults (parse-namestring *load-truename*)))
-
-(defsystem :bknr-web
+(defsystem :bknr.web
     :name "Baikonour - Base modules"
     :author "Hans Huebner <hans at huebner.org>"
     :author "Manuel Odendahl <manuel at bl0rg.net>"
@@ -26,14 +21,14 @@
 		 :md5
 		 :cxml
 		 :unit-test
-		 :bknr-utils
-		 :bknr-xml
+		 :bknr.utils
+		 :bknr.xml
 		 :hunchentoot
 		 :xhtmlgen
 		 :puri
 		 :usocket
-		 :bknr-datastore
-		 :bknr-data-impex
+		 :bknr.datastore
+		 :bknr.data.impex
 		 :parenscript)
 
     :components ((:file "packages")

Modified: trunk/projects/bos/m2/bos.m2.asd
==============================================================================
--- trunk/projects/bos/m2/bos.m2.asd	(original)
+++ trunk/projects/bos/m2/bos.m2.asd	Mon Feb 18 13:28:38 2008
@@ -1,7 +1,7 @@
 (in-package :cl-user)
 
 (asdf:defsystem :bos.m2
-  :depends-on (:bknr-datastore :bknr-modules :cl-smtp :cl-mime :iconv :kmrcl :iterate :arnesi)
+  :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime :iconv :kmrcl :iterate :arnesi)
   :components ((:file "packages")
 	       (:file "geo-utm" :depends-on ("packages"))
 	       (:file "geometry" :depends-on ("packages"))

Modified: trunk/projects/bos/web/bos.web.asd
==============================================================================
--- trunk/projects/bos/web/bos.web.asd	(original)
+++ trunk/projects/bos/web/bos.web.asd	Mon Feb 18 13:28:38 2008
@@ -16,7 +16,7 @@
   :description "worldpay test web server"
   :long-description ""
 
-  :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml :acl-compat)
+  :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml :acl-compat)
 
   :components ((:file "packages")
 	       (:file "utf-8" :depends-on ("packages"))

Modified: trunk/projects/hello-web/src/hello-web.asd
==============================================================================
--- trunk/projects/hello-web/src/hello-web.asd	(original)
+++ trunk/projects/hello-web/src/hello-web.asd	Mon Feb 18 13:28:38 2008
@@ -19,7 +19,7 @@
   :depends-on (:cl-interpol
 	       :cl-ppcre	       
 	       :cxml
-	       :bknr-modules)
+	       :bknr.modules)
 
   :components ((:file "packages")
 	       (:file "config" :depends-on ("packages"))

Modified: trunk/projects/lisp-ecoop/src/lisp-ecoop.asd
==============================================================================
--- trunk/projects/lisp-ecoop/src/lisp-ecoop.asd	(original)
+++ trunk/projects/lisp-ecoop/src/lisp-ecoop.asd	Mon Feb 18 13:28:38 2008
@@ -16,8 +16,8 @@
   :description "Website for the LISP ECOOP Workshops"
   :long-description ""
 
-  :depends-on (:bknr-datastore
-               :bknr-web
+  :depends-on (:bknr.datastore
+               :bknr.web
 	       :closer-mop
 	       :cl-smtp
                :cxml)

Modified: trunk/projects/mah-jongg/src/mah-jongg.asd
==============================================================================
--- trunk/projects/mah-jongg/src/mah-jongg.asd	(original)
+++ trunk/projects/mah-jongg/src/mah-jongg.asd	Mon Feb 18 13:28:38 2008
@@ -16,7 +16,7 @@
   :description "Mah Jongg game calculator"
   :long-description ""
 
-  :depends-on (:cxml :bknr :bknr-datastore :aserve)
+  :depends-on (:cxml :bknr :bknr.datastore :aserve)
 
   :components ((:file "package")
 	       (:file "game" :depends-on ("package"))))

Modified: trunk/projects/quickhoney/src/quickhoney.asd
==============================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd	(original)
+++ trunk/projects/quickhoney/src/quickhoney.asd	Mon Feb 18 13:28:38 2008
@@ -20,9 +20,9 @@
 	       :cl-ppcre
 	       :cxml
 	       :cl-mime
-	       :bknr-web
-	       :bknr-datastore
-	       :bknr-modules
+	       :bknr.web
+	       :bknr.datastore
+	       :bknr.modules
 	       :cl-gd)
 
   :components ((:file "packages")

Modified: trunk/projects/scrabble/src/scrabble.asd
==============================================================================
--- trunk/projects/scrabble/src/scrabble.asd	(original)
+++ trunk/projects/scrabble/src/scrabble.asd	Mon Feb 18 13:28:38 2008
@@ -10,8 +10,8 @@
 (defsystem :scrabble
     :name "Scrabble"
     :licence "BSD"
-    :depends-on (:bknr-datastore
-		 :bknr-web
+    :depends-on (:bknr.datastore
+		 :bknr.web
 		 :hunchentoot
 		 :cl-who
 		 :cl-json

Modified: trunk/projects/unmaintained/eboy/src/eboy.asd
==============================================================================
--- trunk/projects/unmaintained/eboy/src/eboy.asd	(original)
+++ trunk/projects/unmaintained/eboy/src/eboy.asd	Mon Feb 18 13:28:38 2008
@@ -18,7 +18,7 @@
 
   :depends-on (:aserve
 	       :bknr
-	       :bknr-modules)
+	       :bknr.modules)
 
   :components ((:file "packages")
 	       (:file "config" :depends-on ("packages"))

Modified: trunk/projects/unmaintained/raw-data/mcp/mcp.asd
==============================================================================
--- trunk/projects/unmaintained/raw-data/mcp/mcp.asd	(original)
+++ trunk/projects/unmaintained/raw-data/mcp/mcp.asd	Mon Feb 18 13:28:38 2008
@@ -26,10 +26,10 @@
 	       #+clim :clim
 	       #+clim :clim-clx
 	       :cxml
-	       :bknr-indices
+	       :bknr.indices
 	       :net.post-office
-	       :bknr-datastore
-	       :bknr-modules
+	       :bknr.datastore
+	       :bknr.modules
 	       :bknr
 	       :aserve
 	       :pg)

Modified: trunk/projects/unmaintained/saugnapf/src/saugnapf.asd
==============================================================================
--- trunk/projects/unmaintained/saugnapf/src/saugnapf.asd	(original)
+++ trunk/projects/unmaintained/saugnapf/src/saugnapf.asd	Mon Feb 18 13:28:38 2008
@@ -20,7 +20,7 @@
 die Saugnapf radiosendung und generiert dann die Homepage fuer die
 Sendung"
 
-    :depends-on (:bknr-modules :klammerscript)
+    :depends-on (:bknr.modules :klammerscript)
 
     :components ((:file "package")
 


From ksprotte at common-lisp.net  Tue Feb 19 12:21:22 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 19 Feb 2008 07:21:22 -0500 (EST)
Subject: [bknr-cvs] r2560 - trunk/projects/bos/web
Message-ID: <20080219122122.6E9FC5D183@common-lisp.net>

Author: ksprotte
Date: Tue Feb 19 07:21:21 2008
New Revision: 2560

Modified:
   trunk/projects/bos/web/packages.lisp
Log:
removed acl-compat dependency in bos - was not needed anyway


Modified: trunk/projects/bos/web/packages.lisp
==============================================================================
--- trunk/projects/bos/web/packages.lisp	(original)
+++ trunk/projects/bos/web/packages.lisp	Tue Feb 19 07:21:21 2008
@@ -12,7 +12,6 @@
 	:cxml
 	:puri
 	#+(or) :mime
-	:acl-compat.socket
         :bknr.web
 	:bknr.datastore
 	:bknr.indices
@@ -24,6 +23,5 @@
         :bos.m2
 	:bos.m2.config)
   (:nicknames :web :worldpay-test)
-  (:shadowing-import-from :cl-interpol #:quote-meta-chars)
-  (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)  
+  (:shadowing-import-from :cl-interpol #:quote-meta-chars)    
   (:export))


From ksprotte at common-lisp.net  Tue Feb 19 12:22:27 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 19 Feb 2008 07:22:27 -0500 (EST)
Subject: [bknr-cvs] r2561 - trunk/projects/bos/web
Message-ID: <20080219122227.7FF6C5F058@common-lisp.net>

Author: ksprotte
Date: Tue Feb 19 07:22:27 2008
New Revision: 2561

Modified:
   trunk/projects/bos/web/bos.web.asd
Log:
acl-compat again - sorry


Modified: trunk/projects/bos/web/bos.web.asd
==============================================================================
--- trunk/projects/bos/web/bos.web.asd	(original)
+++ trunk/projects/bos/web/bos.web.asd	Tue Feb 19 07:22:27 2008
@@ -16,7 +16,7 @@
   :description "worldpay test web server"
   :long-description ""
 
-  :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml :acl-compat)
+  :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml)
 
   :components ((:file "packages")
 	       (:file "utf-8" :depends-on ("packages"))


From ksprotte at common-lisp.net  Tue Feb 19 16:42:06 2008
From: ksprotte at common-lisp.net (ksprotte at common-lisp.net)
Date: Tue, 19 Feb 2008 11:42:06 -0500 (EST)
Subject: [bknr-cvs] r2562 - branches/bos/projects/bos/web
Message-ID: <20080219164206.42E146A22A@common-lisp.net>

Author: ksprotte
Date: Tue Feb 19 11:42:05 2008
New Revision: 2562

Modified:
   branches/bos/projects/bos/web/kml-handlers.lisp
Log:
added demo-kml function to generate the fat demo file

Modified: branches/bos/projects/bos/web/kml-handlers.lisp
==============================================================================
--- branches/bos/projects/bos/web/kml-handlers.lisp	(original)
+++ branches/bos/projects/bos/web/kml-handlers.lisp	Tue Feb 19 11:42:05 2008
@@ -46,36 +46,83 @@
     ;; (attribute "xmlns" "http://earth.google.com/kml/2.2")
     (with-element "Document"
       (dolist (c (contract-neighbours contract 50))
-	(let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
-	      (name (user-full-name (contract-sponsor c))))
-	  (with-element "Placemark"
-	    (with-element "name" (utf-8-text (format nil "~A ~Dm?"
-						     (if name name "anonymous")
-						     (length (contract-m2s c)))))
-	    (with-element "description" (utf-8-text (contract-description c :de)))
-	    (with-element "Style"
-	      (attribute "id" "#region")
-	      (with-element "LineStyle"
-		(with-element "color" (text "ffff3500")))
-	      (with-element "PolyStyle"
-		(with-element "color" (text (kml-format-color (contract-color c) 175)))))
-	    (with-element "Polygon"
-	      (with-element "styleUrl" "#region")
-	      (with-element "tessellate" (text "1"))
-	      (with-element "outerBoundaryIs"
-		(with-element "LinearRing"
-		  (with-element "coordinates"
-		    (text (kml-format-points polygon)))))))
-	  ;; the center contract
-	  (when (eq c contract)
-	    (with-element "Placemark"
-	      (with-element "name" (utf-8-text (format nil "~A ~Dm?"
-						       (if name name "anonymous")
-						       (length (contract-m2s c)))))
-	      (with-element "description" (utf-8-text (contract-description c :de)))
-	      (with-element "Point"
-		(with-element "coordinates"
-		  (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))
+        (let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
+              (name (user-full-name (contract-sponsor c))))
+          (with-element "Placemark"
+            (with-element "name" (utf-8-text (format nil "~A ~Dm?"
+                                                     (if name name "anonymous")
+                                                     (length (contract-m2s c)))))
+            (with-element "description" (utf-8-text (contract-description c :de)))
+            (with-element "Style"
+              (attribute "id" "#region")
+              (with-element "LineStyle"
+                (with-element "color" (text "ffff3500")))
+              (with-element "PolyStyle"
+                (with-element "color" (text (kml-format-color (contract-color c) 175)))))
+            (with-element "Polygon"
+              (with-element "styleUrl" "#region")
+              (with-element "tessellate" (text "1"))
+              (with-element "outerBoundaryIs"
+                (with-element "LinearRing"
+                  (with-element "coordinates"
+                    (text (kml-format-points polygon)))))))
+          ;; the center contract
+          (when (eq c contract)
+            (with-element "Placemark"
+              (with-element "name" (utf-8-text (format nil "~A ~Dm?"
+                                                       (if name name "anonymous")
+                                                       (length (contract-m2s c)))))
+              (with-element "description" (utf-8-text (contract-description c :de)))
+              (with-element "Point"
+                (with-element "coordinates"
+                  (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))
 
 (defmethod handle-object ((handle-object contract-kml-handler) (object null) req)
   (error "Contract not found."))
+
+;;; static kml file demo generator
+(defun demo-kml (&optional (path #p"/tmp/demo.kml"))
+  (with-open-file (out path :direction :output :if-exists :supersede
+                       :element-type '(unsigned-byte 8))
+    (write-line "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" out)
+    (write-line "<kml xmlns=\"http://earth.google.com/kml/2.2\">" out)
+    (cxml:with-xml-output (cxml:make-octet-stream-sink out)
+      (with-element "Document"
+        (dolist (c (subseq (class-instances 'contract) 0 10))
+          (let ((polygon (m2s-polygon-lon-lat (contract-m2s c)))
+                (name (user-full-name (contract-sponsor c))))
+            (with-element "Placemark"
+              (with-element "name" (utf-8-text (format nil "~A ~Dm?"
+                                                       (if name name "anonymous")
+                                                       (length (contract-m2s c)))))
+              (with-element "description" (utf-8-text (contract-description c :de)))
+              (with-element "Style"
+                (attribute "id" "#region")
+                (with-element "LineStyle"
+                  (with-element "color" (text "ffff3500")))
+                (with-element "PolyStyle"
+                  (with-element "color" (text (kml-format-color (contract-color c) 175)))))
+              (with-element "Polygon"
+                (with-element "styleUrl" "#region")
+                (with-element "tessellate" (text "1"))
+                (with-element "outerBoundaryIs"
+                  (with-element "LinearRing"
+                    (with-element "coordinates"
+                      (text (kml-format-points polygon)))))))))
+        (dolist (poi (class-instances 'poi))
+          (when (and (poi-area poi)
+                     (gethash "en" (poi-title poi)))
+            (destructuring-bind (poi-x poi-y) (poi-area poi)
+              (let ((utm-x (+ +nw-utm-x+ poi-x))
+                    (utm-y (- +nw-utm-y+ poi-y)))     
+                (with-element "Placemark"
+                  (with-element "name" (text (gethash "en" (poi-title poi))))
+                  (when (gethash "en" (poi-description poi))
+                    (with-element "description" (text (gethash "en" (poi-description poi)))))
+                  (with-element "Point"
+                    (with-element "coordinates"
+                      (text (kml-format-points (list (geo-utm:utm-x-y-to-lon-lat utm-x utm-y +utm-zone+ t)))))))))))))
+    (write-line "</kml>" out)))
+
+(demo-kml)
+