From f5e1b82f92156ea35d5c13aa6c3242775cffe8e0 Mon Sep 17 00:00:00 2001
From: uid67408 <uid67408>
Date: Mon, 29 Dec 2003 05:25:02 +0000
Subject: [PATCH] Import files from other places.

---
 v7/src/ssp/compile.scm        |   36 +
 v7/src/ssp/db.scm             |  698 ++++++++++++++++
 v7/src/ssp/load.scm           |   39 +
 v7/src/ssp/matcher.scm        |  184 +++++
 v7/src/ssp/mod-lisp.scm       |  662 +++++++++++++++
 v7/src/ssp/validate-xdoc.scm  |  461 +++++++++++
 v7/src/ssp/xdoc.scm           | 1467 +++++++++++++++++++++++++++++++++
 v7/src/ssp/xhtml-expander.scm |  154 ++++
 v7/src/ssp/xhtml.scm          |  246 ++++++
 v7/src/ssp/xmlrpc.scm         |  302 +++++++
 10 files changed, 4249 insertions(+)
 create mode 100644 v7/src/ssp/compile.scm
 create mode 100644 v7/src/ssp/db.scm
 create mode 100644 v7/src/ssp/load.scm
 create mode 100644 v7/src/ssp/matcher.scm
 create mode 100644 v7/src/ssp/mod-lisp.scm
 create mode 100644 v7/src/ssp/validate-xdoc.scm
 create mode 100644 v7/src/ssp/xdoc.scm
 create mode 100644 v7/src/ssp/xhtml-expander.scm
 create mode 100644 v7/src/ssp/xhtml.scm
 create mode 100644 v7/src/ssp/xmlrpc.scm

diff --git a/v7/src/ssp/compile.scm b/v7/src/ssp/compile.scm
new file mode 100644
index 000000000..772c6a3a9
--- /dev/null
+++ b/v7/src/ssp/compile.scm
@@ -0,0 +1,36 @@
+#| -*-Scheme-*-
+
+$Id: compile.scm,v 1.1 2003/12/29 05:24:29 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XDOC/mod-lisp compilation
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+  (lambda ()
+    (compile-file "xhtml-expander")
+    (compile-file "xhtml")
+    (compile-file "db")
+    (compile-file "mod-lisp")
+    (compile-file "matcher")
+    (compile-file "xdoc")
+    (compile-file "xmlrpc")))
\ No newline at end of file
diff --git a/v7/src/ssp/db.scm b/v7/src/ssp/db.scm
new file mode 100644
index 000000000..63af5a2e3
--- /dev/null
+++ b/v7/src/ssp/db.scm
@@ -0,0 +1,698 @@
+#| -*-Scheme-*-
+
+$Id: db.scm,v 1.1 2003/12/29 05:24:32 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; 6.002ex database support
+
+(declare (usual-integrations))
+
+(define db-name "six002x_spring04")
+(define pgsql-conn #f)
+(define *database-connection* #f)
+(define *user-name*)
+(define *ps-number*)
+(define *page-key*)
+
+(define (with-database-connection ps-number pathname thunk)
+  (if (not (and pgsql-conn (pgsql-conn-open? pgsql-conn)))
+      (set! pgsql-conn (open-pgsql-conn (string-append "dbname=" db-name))))
+  (let ((page-key (enough-namestring pathname (server-root-dir))))
+    (if *database-connection*
+	(begin
+	  (set! *database-connection* pgsql-conn)
+	  (fluid-let ((*ps-number* ps-number)
+		      (*page-key* page-key))
+	    (thunk)))
+	(fluid-let ((*database-connection* pgsql-conn)
+		    (*user-name* (http-request-user-name))
+		    (*ps-number* ps-number)
+		    (*page-key* page-key))
+	  (database-transaction thunk)))))
+
+(define (database-connection)
+  (let ((conn *database-connection*))
+    (if (pgsql-conn-open? conn)
+	conn
+	(let ((conn (open-pgsql-conn "dbname=six002x")))
+	  (set! pgsql-conn conn)
+	  (set! *database-connection* conn)
+	  conn))))
+
+(define (database-transaction thunk)
+  (let ((commit? #f))
+    (dynamic-wind (lambda ()
+		    (db-run-cmd "BEGIN"))
+		  (lambda ()
+		    (let ((v (thunk)))
+		      (set! commit? #t)
+		      v))
+		  (lambda ()
+		    (db-run-cmd (if commit? "COMMIT" "ROLLBACK"))))))
+
+(define (close-database)
+  (if pgsql-conn
+      (begin
+	(if (pgsql-conn-open? pgsql-conn)
+	    (close-pgsql-conn pgsql-conn))
+	(set! pgsql-conn #f)
+	unspecific)))
+
+(define-expander 'db-run-query
+  (lambda strings
+    (exec-pgsql-query (database-connection)
+		      (string-append (apply string-append strings) ";"))))
+
+(define-expander 'db-run-cmd
+  (lambda strings
+    (let ((result (apply db-run-query strings)))
+      (let ((status (pgsql-cmd-status result)))
+	(pgsql-clear result)
+	status))))
+
+(define-expander 'db-quote
+  (lambda (object)
+    (if object
+	(if (exact-integer? object)
+	    (number->string object)
+	    (string-append "'"
+			   (escape-pgsql-string
+			    (if (symbol? object)
+				(symbol-name object)
+				object))
+			   "'"))
+	"NULL")))
+
+;;;; Problem-set registration
+
+(define-expander 'db-register-problem-set
+  (lambda (ps-number directory)
+    (db-run-cmd "DELETE FROM saved_inputs"
+		" WHERE ps_number = " (db-quote ps-number))
+    (db-run-cmd "DELETE FROM saved_outputs"
+		" WHERE ps_number = " (db-quote ps-number))
+    (db-run-cmd "DELETE FROM registered_outputs"
+		" WHERE ps_number = " (db-quote ps-number))
+    (let ((n-parts 0)
+	  (n-outputs 0))
+      (for-each (lambda (pathname)
+		  (if (not (string=? (pathname-name pathname) "index"))
+		      (begin
+			(set! n-parts (+ n-parts 1))
+			(set! n-outputs
+			      (+ n-outputs
+				 (register-part-outputs ps-number
+							pathname)))))
+		  unspecific)
+		(directory-read (merge-pathnames "*.xdoc" directory)))
+      (values n-parts n-outputs))))
+
+(define (register-part-outputs ps-number pathname)
+  (with-xdoc-expansion-context ps-number pathname
+    (lambda (document)
+      (db-run-cmd "DELETE FROM persistent_values"
+		  " WHERE file_name = " (db-quote *page-key*))
+      (let ((root (xml-document-root document)))
+	(let ((ps-number* (int0-attribute 'problem-set root #t)))
+	  (if (not (= ps-number* ps-number))
+	      (error "Document has wrong problem-set number:"
+		     (file-namestring pathname))))
+	(let ((part (xdoc-db-id root))
+	      (n-outputs 0))
+	  (let loop ((elt root))
+	    (for-each (lambda (item)
+			(if (xml-element? item)
+			    (begin
+			      (if (xdoc-output? item)
+				  (begin
+				    (set! n-outputs (+ n-outputs 1))
+				    (register-output ps-number
+						     (xdoc-db-id item)
+						     part)))
+			      (loop item))))
+		      (xml-element-contents elt)))
+	  n-outputs)))))
+
+(define (register-output ps-number name part)
+  (db-run-cmd "INSERT INTO registered_outputs VALUES"
+	      " (" (db-quote ps-number)
+	      ", " (db-quote name)
+	      ", " (db-quote part)
+	      ")"))
+
+(define-expander 'db-registered-problem-sets
+  (lambda ()
+    (let ((result
+	   (db-run-query "SELECT DISTINCT ps_number"
+			 " FROM registered_outputs"
+			 " ORDER BY ps_number")))
+      (let ((n (pgsql-n-tuples result)))
+	(do ((i 0 (+ i 1))
+	     (numbers '()
+		      (cons (string->number (pgsql-get-value result i 0))
+			    numbers)))
+	    ((= i n)
+	     (pgsql-clear result)
+	     (reverse! numbers)))))))
+
+(define-expander 'db-ps-problem-names
+  (lambda (ps-number)
+    (let ((result
+	   (db-run-query "SELECT name"
+			 " FROM registered_outputs"
+			 " WHERE ps_number = " (db-quote ps-number))))
+      (let ((n (pgsql-n-tuples result)))
+	(do ((i 0 (+ i 1))
+	     (names '() (cons (pgsql-get-value result i 0) names)))
+	    ((= i n)
+	     (pgsql-clear result)
+	     names))))))
+
+(define-expander 'db-problem-submitted?
+  (lambda (ps-number name user-name)
+    (let ((result
+	   (db-run-query "SELECT submitter"
+			 " FROM saved_outputs"
+			 " WHERE ps_number = " (db-quote ps-number)
+			 " AND name = " (db-quote name)
+			 " AND user_name = " (db-quote user-name))))
+      (let ((submitted?
+	     (and (> (pgsql-n-tuples result) 0)
+		  (let ((v (pgsql-get-value result 0 0)))
+		    (and v
+			 (not (string-null? v)))))))
+	(pgsql-clear result)
+	submitted?))))
+
+(define-expander 'db-get-ps-structure
+  (lambda ()
+    (let ((result
+	   (db-run-query "SELECT ps_number, ps_part, name"
+			 " FROM registered_outputs"
+			 " ORDER BY ps_number, ps_part, name")))
+      (let ((n (pgsql-n-tuples result)))
+	(do ((i 0 (+ i 1))
+	     (items '()
+		    (cons (vector (string->number (pgsql-get-value result i 0))
+				  (pgsql-get-value result i 1)
+				  (pgsql-get-value result i 2))
+			  items)))
+	    ((= i n)
+	     (pgsql-clear result)
+	     (ps-structure->tree (reverse! items))))))))
+
+(define (ps-structure->tree items)
+  (map (lambda (pset)
+	 (cons (vector-ref (car pset) 0)
+	       (map (lambda (vs)
+		      (cons (vector-ref (car vs) 1)
+			    (map (lambda (v) (vector-ref v 2)) vs)))
+		    (chop-into-pieces! pset
+		      (lambda (a b)
+			(string=? (vector-ref a 1) (vector-ref b 1)))))))
+       (chop-into-pieces! items
+	 (lambda (a b)
+	   (= (vector-ref a 0) (vector-ref b 0))))))
+
+(define (chop-into-pieces! items predicate)
+  (let loop ((items items) (pieces '()))
+    (if (pair? items)
+	(receive (head items) (chop-off-head! items predicate)
+	  (loop items (cons head pieces)))
+	(reverse! pieces))))
+
+(define (chop-off-head! head predicate)
+  (let loop ((items (cdr head)) (tail head))
+    (if (pair? items)
+	(if (predicate (car items) (car head))
+	    (loop (cdr items) items)
+	    (begin
+	      (set-cdr! tail '())
+	      (values head items)))
+	(values head items))))
+
+;;;; Saved inputs
+
+(define (db-previously-saved-input id)
+  (let ((result (db-run-query (saved-inputs-query id '(value submitter) #f))))
+    (if (> (pgsql-n-tuples result) 0)
+	(let ((value (pgsql-get-value result 0 0))
+	      (submitter (pgsql-get-value result 0 1)))
+	  (pgsql-clear result)
+	  (values value (and submitter (string->symbol submitter))))
+	(begin
+	  (pgsql-clear result)
+	  (values #f #f)))))
+
+(define (db-save-input! id value submitter)
+  (case (input-submission-status id #t)
+    ((#f)
+     (db-run-cmd "INSERT INTO saved_inputs VALUES"
+		 " (" (db-quote *user-name*)
+		 ", " (db-quote *ps-number*)
+		 ", " (db-quote id)
+		 ", " (db-quote value)
+		 ", " (db-quote submitter)
+		 ")"))
+    ((not-submitted)
+     (db-run-cmd "UPDATE saved_inputs SET"
+		 " value = " (db-quote value)
+		 ", submitter = " (db-quote submitter)
+		 " WHERE " (saved-inputs-condition id)))))
+
+(define (input-submission-status id for-update?)
+  (let ((result
+	 (db-run-query (saved-inputs-query id '(submitter) for-update?))))
+    (let ((status
+	   (and (> (pgsql-n-tuples result) 0)
+		(if (pgsql-get-is-null? result 0 0)
+		    'not-submitted
+		    'submitted))))
+      (pgsql-clear result)
+      status)))
+
+(define (saved-inputs-query id fields for-update?)
+  (string-append "SELECT " (field-list->db-string fields)
+		 " FROM saved_inputs"
+		 " WHERE " (saved-inputs-condition id)
+		 (if for-update? " FOR UPDATE" "")))
+
+(define (saved-inputs-condition id)
+  (string-append "user_name = " (db-quote *user-name*)
+		 " AND ps_number = " (db-quote *ps-number*)
+		 " AND name = " (db-quote id)))
+
+;;;; Saved outputs
+
+(define (db-previously-saved-output id)
+  (let ((result
+	 (db-run-query (saved-outputs-query id '(correctness submitter) #f))))
+    (if (> (pgsql-n-tuples result) 0)
+	(let ((correctness (pgsql-get-value result 0 0))
+	      (submitter (pgsql-get-value result 0 1)))
+	  (pgsql-clear result)
+	  (values correctness (and submitter (string->symbol submitter))))
+	(begin
+	  (pgsql-clear result)
+	  (values #f #f)))))
+
+(define (db-save-output! id correctness submitter late?)
+  (case (output-submission-status id #t)
+    ((#f)
+     (db-run-cmd "INSERT INTO saved_outputs VALUES"
+		 " (" (db-quote *user-name*)
+		 ", " (db-quote *ps-number*)
+		 ", " (db-quote id)
+		 ", " (db-quote correctness)
+		 ", " (db-quote submitter)
+		 ", " (if late? "TRUE" "FALSE")
+		 ")"))
+    ((not-submitted)
+     (db-run-cmd "UPDATE saved_outputs SET"
+		 " correctness = " (db-quote correctness)
+		 ", submitter = " (db-quote submitter)
+		 ", late_p = " (if late? "TRUE" "FALSE")
+		 " WHERE " (saved-outputs-condition id)))))
+
+(define (output-submission-status id for-update?)
+  (let ((result
+	 (db-run-query (saved-outputs-query id '(submitter) for-update?))))
+    (let ((status
+	   (and (> (pgsql-n-tuples result) 0)
+		(if (pgsql-get-is-null? result 0 0)
+		    'not-submitted
+		    'submitted))))
+      (pgsql-clear result)
+      status)))
+
+(define (saved-outputs-query id fields for-update?)
+  (string-append "SELECT " (field-list->db-string fields)
+		 " FROM saved_outputs"
+		 " WHERE " (saved-outputs-condition id)
+		 (if for-update? " FOR UPDATE" "")))
+
+(define (saved-outputs-condition id)
+  (string-append "user_name = " (db-quote *user-name*)
+		 " AND ps_number = " (db-quote *ps-number*)
+		 " AND name = " (db-quote id)))
+
+(define-expander 'db-get-saved-output
+  (lambda (user-name ps-number name)
+    (let ((result
+	   (db-run-query "SELECT correctness, submitter, late_p"
+			 " FROM saved_outputs"
+			 " WHERE user_name = " (db-quote user-name)
+			 " AND ps_number = " (db-quote ps-number)
+			 " AND name = " (db-quote name))))
+      (if (> (pgsql-n-tuples result) 0)
+	  (let ((correctness (pgsql-get-value result 0 0))
+		(submitter (pgsql-get-value result 0 1))
+		(late? (string=? (pgsql-get-value result 0 2) "t")))
+	    (pgsql-clear result)
+	    (values correctness
+		    (and submitter (string->symbol submitter))
+		    late?))
+	  (begin
+	    (pgsql-clear result)
+	    (values #f #f #f))))))
+
+;;;; Persistent values
+
+(define-expander 'db-get-persistent-value
+  (lambda (name default)
+    (let ((result
+	   (db-run-query (persistent-value-query name '(var_value) #f))))
+      (let ((string
+	     (and (> (pgsql-n-tuples result) 0)
+		  (pgsql-get-value result 0 0))))
+	(pgsql-clear result)
+	(if string
+	    (read (open-input-string string))
+	    default)))))
+
+(define-expander 'db-set-persistent-value!
+  (lambda (name object)
+    (let ((value (write-to-string object))
+	  (result
+	   (db-run-query (persistent-value-query name '(var_value) #t))))
+      (if (> (pgsql-n-tuples result) 0)
+	  (let ((same-value? (string=? (pgsql-get-value result 0 0) value)))
+	    (pgsql-clear result)
+	    (if (not same-value?)
+		(db-run-cmd "UPDATE persistent_values SET"
+			    " var_value = "
+			    (db-quote value)
+			    " WHERE "
+			    (persistent-value-condition name))))
+	  (begin
+	    (pgsql-clear result)
+	    (db-run-cmd "INSERT INTO persistent_values VALUES"
+			" (" (db-quote *user-name*)
+			", " (db-quote *page-key*)
+			", " (db-quote name)
+			", " (db-quote value)
+			")"))))))
+
+(define-expander 'db-intern-persistent-value!
+  (lambda (name get-object)
+    (let ((result
+	   (db-run-query (persistent-value-query name '(var_value) #t))))
+      (if (> (pgsql-n-tuples result) 0)
+	  (let ((value (pgsql-get-value result 0 0)))
+	    (pgsql-clear result)
+	    (read (open-input-string value)))
+	  (begin
+	    (pgsql-clear result)
+	    (let ((object (get-object)))
+	      (db-run-cmd "INSERT INTO persistent_values VALUES"
+			  " (" (db-quote *user-name*)
+			  ", " (db-quote *page-key*)
+			  ", " (db-quote name)
+			  ", " (db-quote (write-to-string object))
+			  ")")
+	      object))))))
+
+(define-expander 'db-delete-persistent-value!
+  (lambda (name)
+    (db-run-cmd "DELETE FROM persistent_values WHERE "
+		(persistent-value-condition name))))
+
+(define (persistent-value-query name fields for-update?)
+  (string-append "SELECT " (field-list->db-string fields)
+		 " FROM persistent_values"
+		 " WHERE " (persistent-value-condition name)
+		 (if for-update? " FOR UPDATE" "")))
+
+(define (persistent-value-condition name)
+  (string-append "user_name = " (db-quote *user-name*)
+		 " AND file_name = " (db-quote *page-key*)
+		 " AND var_name = " (db-quote name)))
+
+;;;; Clear submitted/late
+
+(define-expander 'db-saved-submitters
+  (lambda (user-name)
+    (db-marked-submitters user-name "submitter IS NOT NULL")))
+
+(define-expander 'db-late-submitters
+  (lambda (user-name)
+    (db-marked-submitters user-name "late_p")))
+
+(define (db-marked-submitters user-name condition)
+  (let ((result
+	 (db-run-query "SELECT DISTINCT ps_number, submitter"
+		       " FROM saved_outputs"
+		       " WHERE user_name = " (db-quote user-name)
+		       " AND " condition
+		       " ORDER BY ps_number, submitter")))
+    (let ((n (pgsql-n-tuples result)))
+      (let loop ((i 0) (names '()))
+	(if (< i n)
+	    (loop (+ i 1)
+		  (cons (string-append
+			 (pgsql-get-value result i 0)
+			 "/"
+			 (pgsql-get-value result i 1))
+			names))
+	    (begin
+	      (pgsql-clear result)
+	      (reverse! names)))))))
+
+(define-expander 'db-clear-submitter
+  (lambda (user-name number)
+    (receive (ps-number submitter) (parse-problem-number number)
+      (db-run-cmd "UPDATE saved_inputs"
+		  " SET submitter IS NULL"
+		  " WHERE user_name = " (db-quote user-name)
+		  " AND ps_number = " (db-quote ps-number)
+		  " AND submitter  = " (db-quote submitter))
+      (db-set-output-field user-name ps-number submitter
+			   "submitter IS NULL"))))
+
+(define-expander 'db-clear-late-flag
+  (lambda (user-name number)
+    (receive (ps-number submitter) (parse-problem-number number)
+      (db-set-output-field user-name ps-number submitter "late_p = FALSE"))))
+
+(define (db-set-output-field user-name ps-number submitter assignment)
+  (let ((result
+	 (db-run-query "UPDATE saved_outputs"
+		       " SET " assignment
+		       " WHERE user_name = " (db-quote user-name)
+		       " AND ps_number = " (db-quote ps-number)
+		       " AND submitter  = " (db-quote submitter))))
+    (let ((n (pgsql-cmd-tuples result)))
+      (pgsql-clear result)
+      n)))
+
+;;;; Users
+
+(define-expander 'db-known-user?
+  (lambda (user-name)
+    (known-user? user-name #f)))
+
+(define (known-user? user-name for-update?)
+  (let ((result
+	 (db-run-query "SELECT enabled_p"
+		       " FROM users"
+		       " WHERE user_name = " (db-quote user-name)
+		       (if for-update? " FOR UPDATE" ""))))
+    (if (> (pgsql-n-tuples result) 0)
+	(let ((enabled?
+	       (if (string=? (pgsql-get-value result 0 0) "t")
+		   #t
+		   'disabled)))
+	  (pgsql-clear result)
+	  enabled?)
+	(begin
+	  (pgsql-clear result)
+	  #f))))
+
+(define (guarantee-known-user user-name)
+  (if (not (known-user? user-name #t))
+      (error "Unknown user:" user-name)))
+
+(define-expander 'db-known-users
+  (lambda (condition)
+    (let ((result
+	   (db-run-query "SELECT user_name"
+			 " FROM users"
+			 (case condition
+			   ((enabled) " WHERE enabled_p")
+			   ((disabled) " WHERE NOT enabled_p")
+			   (else ""))
+			 " ORDER BY user_name")))
+      (let ((n (pgsql-n-tuples result)))
+	(let loop ((i 0) (users '()))
+	  (if (< i n)
+	      (loop (+ i 1) (cons (pgsql-get-value result i 0) users))
+	      (begin
+		(pgsql-clear result)
+		(reverse! users))))))))
+
+(define-expander 'db-new-user-account
+  (lambda (user-name first-names last-name password enabled?)
+    (if (known-user? user-name #t)
+	#f
+	(begin
+	  (db-run-cmd "INSERT INTO users VALUES"
+		      " (" (db-quote user-name)
+		      ", " (db-quote first-names)
+		      ", " (db-quote last-name)
+		      ", " (db-quote (encrypt-password password))
+		      ", " "FALSE"
+		      ", " (if enabled? "TRUE" "FALSE")
+		      ")")
+	  #t))))
+
+(define-expander 'db-change-user-password
+  (lambda (user-name password)
+    (guarantee-known-user user-name)
+    (db-run-cmd "UPDATE users"
+		" SET password = " (db-quote (encrypt-password password))
+		" WHERE user_name = " (db-quote user-name))))
+
+(define-expander 'db-user-real-name
+  (lambda (user-name)
+    (let ((result
+	   (db-run-query "SELECT first_names, last_name"
+			 " FROM users"
+			 " WHERE user_name = " (db-quote user-name))))
+      (if (> (pgsql-n-tuples result) 0)
+	  (let ((first (pgsql-get-value result 0 0))
+		(last (pgsql-get-value result 0 1)))
+	    (pgsql-clear result)
+	    (values first last))
+	  (begin
+	    (pgsql-clear result)
+	    (error "Unknown user:" user-name)
+	    (values #f #f))))))
+
+(define-expander 'db-set-user-real-name
+  (lambda (user-name first-names last-name)
+    (guarantee-known-user user-name)
+    (db-run-cmd "UPDATE users"
+		" SET first_names = " (db-quote first-names)
+		", last_name = " (db-quote last-name)
+		" WHERE user_name = " (db-quote user-name))))
+
+(define-expander 'db-user-enabled?
+  (lambda (user-name)
+    (get-user-flag user-name "enabled_p")))
+
+(define-expander 'db-user-administrator?
+  (lambda (user-name)
+    (get-user-flag user-name "administrator_p")))
+
+(define-expander 'db-set-user-enabled
+  (lambda (user-name value)
+    (set-user-flag user-name "enabled_p" value)))
+
+(define-expander 'db-set-user-administrator
+  (lambda (user-name value)
+    (set-user-flag user-name "administrator_p" value)))
+
+(define (get-user-flag user-name flag-name)
+  (let ((result
+	 (db-run-query "SELECT " flag-name
+		       " FROM users"
+		       " WHERE user_name = " (db-quote user-name))))
+    (let ((string
+	   (and (> (pgsql-n-tuples result) 0)
+		(pgsql-get-value result 0 0))))
+      (pgsql-clear result)
+      (if (not string)
+	  (error "Unknown user:" user-name))
+      (string=? string "t"))))
+
+(define (set-user-flag user-name flag-name value)
+  (guarantee-known-user user-name)
+  (db-run-cmd "UPDATE users"
+	      " SET " flag-name " = " (if value "TRUE" "FALSE")
+	      " WHERE user_name = " (db-quote user-name)))
+
+(define (encrypt-password password)
+  (if (not (db-valid-password? password))
+      (error "Invalid password syntax:" password))
+  (let ((pw-line
+	 (call-with-output-string
+	   (lambda (port)
+	     (let ((status
+		    (run-shell-command (string-append "htpasswd -nb foo "
+						      password)
+				       'output port)))
+	       (if (not (= status 0))
+		   (error "Non-zero status from htpasswd:" status)))))))
+    (if (not (and (string-prefix? "foo:" pw-line)
+		  (string-suffix? "\n" pw-line)))
+	(error "Unknown result from htpasswd:" pw-line))
+    (substring pw-line 4 (fix:- (string-length pw-line) 1))))
+
+(define-expander 'db-valid-password?
+  (lambda (string)
+    (and (fix:>= (string-length string) 8)
+	 (not (string-find-next-char-in-set string char-set:not-password))
+	 (string-find-next-char-in-set string char-set:lower-case)
+	 (string-find-next-char-in-set string char-set:upper-case)
+	 (string-find-next-char-in-set string char-set:numeric))))
+
+(define char-set:password
+  (char-set-union char-set:alphanumeric
+		  (string->char-set " _-.")))
+
+(define char-set:not-password
+  (char-set-invert char-set:password))
+
+(define-expander 'db-generate-password
+  (lambda ()
+    (string-append (string (integer->char (+ (char->integer #\A) (random 26))))
+		   (string (integer->char (+ (char->integer #\a) (random 26))))
+		   (random-digit-string 6))))
+
+(define (random-digit-string n-chars)
+  (string-pad-left (number->string (random (expt 10 n-chars))) n-chars #\0))
+
+(define (parse-problem-number string)
+  (let ((regs (re-string-match problem-number-regexp string)))
+    (if (not regs)
+	(error:bad-range-argument string 'parse-problem-number))
+    (values (string->number (re-match-extract string regs 1))
+	    (re-match-extract string regs 2))))
+
+(define problem-number-regexp
+  (rexp-compile
+   (let ((int
+	  (rexp-sequence (char-set-difference char-set:numeric (char-set #\0))
+			 (rexp* char-set:numeric))))
+     (rexp-sequence (rexp-string-start)
+		    (rexp-group int)
+		    "/"
+		    (rexp-group (rexp-optional "xdoc_") int (rexp* "." int))
+		    (rexp-string-end)))))
+
+(define (field-list->db-string fields)
+  (apply string-append
+	 (cons (symbol->string (car fields))
+	       (map (lambda (value)
+		      (string-append ", " (symbol->string value)))
+		    (cdr fields)))))
\ No newline at end of file
diff --git a/v7/src/ssp/load.scm b/v7/src/ssp/load.scm
new file mode 100644
index 000000000..a770ea873
--- /dev/null
+++ b/v7/src/ssp/load.scm
@@ -0,0 +1,39 @@
+#| -*-Scheme-*-
+
+$Id: load.scm,v 1.1 2003/12/29 05:24:36 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XDOC/mod-lisp loader
+
+(load-option 'xml)
+(load-option 'postgresql)
+(load-option 'mime-codec)
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+  (lambda ()
+    (load "xhtml-expander")
+    (load "xhtml")
+    (load "mod-lisp")
+    (load "db")
+    (load "matcher")
+    (load "xdoc")
+    (load "xmlrpc")))
\ No newline at end of file
diff --git a/v7/src/ssp/matcher.scm b/v7/src/ssp/matcher.scm
new file mode 100644
index 000000000..a1dafb89e
--- /dev/null
+++ b/v7/src/ssp/matcher.scm
@@ -0,0 +1,184 @@
+#| -*-Scheme-*-
+
+$Id: matcher.scm,v 1.1 2003/12/29 05:24:39 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; List matching
+
+(declare (usual-integrations))
+
+(define ((ml:matcher pattern) items)
+  (ml:apply pattern items))
+
+(define (ml:apply pattern items)
+  (guarantee-list items 'ML:APPLY)
+  (pattern (lambda (kf p r) kf p (r->v r))
+	   (lambda () #f)
+	   items))
+
+(define ((ml:match predicate) ks kf p)
+  (if (pair? p)
+      (let ((item (car p)))
+	(if (predicate item)
+	    (ks kf (cdr p) (r1 item))
+	    (kf)))
+      (kf)))
+
+(define ((ml:noise predicate) ks kf p)
+  (if (and (pair? p) (predicate (car p)))
+      (ks kf (cdr p) (r0))
+      (kf)))
+
+(define (ml:end ks kf p)
+  (if (null? p)
+      (ks kf p (r0))
+      (kf)))
+
+(define ((ml:* matcher) ks kf p)
+  (let ks* ((kf kf) (p p) (r (r0)))
+    (matcher (lambda (kf p r*) (ks* kf p (r+ r r*)))
+	     (lambda () (ks kf p r))
+	     p)))
+
+(define (ml:seq . matchers)
+  (let loop ((matchers matchers))
+    (if (pair? matchers)
+	(let ((m1 (car matchers))
+	      (matchers (cdr matchers)))
+	  (if (pair? matchers)
+	      (let ((m2 (loop matchers)))
+		(lambda (ks kf p)
+		  (m1 (lambda (kf p r1)
+			(m2 (lambda (kf p r2) (ks kf p (r+ r1 r2)))
+			    kf
+			    p))
+		      kf
+		      p)))
+	      m1))
+	(lambda (ks kf p) (ks kf p (r0))))))
+
+(define (ml:alt . matchers)
+  (if (pair? matchers)
+      (let loop ((matchers matchers))
+	(let ((m1 (car matchers))
+	      (matchers (cdr matchers)))
+	  (if (pair? matchers)
+	      (let ((m2 (loop matchers)))
+		(lambda (ks kf p)
+		  (m1 ks
+		      (lambda () (m2 ks kf p))
+		      p)))
+	      m1)))
+      (lambda (ks kf p) ks p (kf))))
+
+(define (ml:transform procedure matcher)
+  (transformer (lambda (v) (v->r (procedure v))) matcher))
+
+(define (ml:encapsulate procedure matcher)
+  (transformer (lambda (v) (r1 (procedure v))) matcher))
+
+(define (ml:map procedure matcher)
+  (transformer (lambda (v) (v->r (vector-map procedure v))) matcher))
+
+(define ((transformer transform matcher) ks kf p)
+  (matcher (lambda (kf p r) (ks kf p (transform (r->v r))))
+	   kf
+	   p))
+
+(define (ml:+ matcher)
+  (ml:seq matcher (ml:* matcher)))
+
+(define (ml:? matcher)
+  (ml:alt matcher (ml:seq)))
+
+(define ((ml:values . items) ks kf p)
+  (ks kf p (l->r items)))
+
+(define (ml:*-list matcher)
+  (ml:encapsulate vector->list (ml:* matcher)))
+
+(define-integrable (r0) '#())
+(define-integrable (r1 item) (vector item))
+(define-integrable (r->v r) r)
+(define-integrable (v->r v) v)
+(define-integrable (l->r l) (list->vector l))
+
+(define (r+ r1 r2)
+  (let ((n1 (vector-length r1))
+	(n2 (vector-length r2)))
+    (cond ((fix:= n1 0) r2)
+	  ((fix:= n2 0) r1)
+	  (else
+	   (let ((r (make-vector (fix:+ n1 n2))))
+	     (do ((i 0 (fix:+ i 1)))
+		 ((fix:= i n1))
+	       (vector-set! r i (vector-ref r1 i)))
+	     (do ((i 0 (fix:+ i 1))
+		  (j n1 (fix:+ j 1)))
+		 ((fix:= i n2))
+	       (vector-set! r j (vector-ref r2 i)))
+	     r)))))
+
+#|
+
+;;; If the set of items doesn't include #F or pairs, this should be
+;;; faster than the above.
+
+(define-integrable (r0) #f)
+(define-integrable (r1 item) item)
+
+(define (r+ r1 r2)
+  (cond ((not r1) r2)
+	((not r2) r1)
+	(else (cons r1 r2))))
+
+(define (r->v r)
+  (if r
+      (let ((n
+	     (let loop ((r r))
+	       (if (pair? r)
+		   (fix:+ (loop (car r))
+			  (loop (cdr r)))
+		   1))))
+	(let ((v (make-vector n)))
+	  (let loop ((r r) (i 0) (q '()))
+	    (if (pair? r)
+		(loop (car r)
+		      i
+		      (cons (cdr r) q))
+		(begin
+		  (vector-set! v i r)
+		  (if (pair? q)
+		      (loop (car q)
+			    (fix:+ i 1)
+			    (cdr q))))))
+	  v))
+      '#()))
+
+(define (v->r v)
+  ???)
+
+(define (l->r l)
+  ???)
+
+|#
\ No newline at end of file
diff --git a/v7/src/ssp/mod-lisp.scm b/v7/src/ssp/mod-lisp.scm
new file mode 100644
index 000000000..425b0beb1
--- /dev/null
+++ b/v7/src/ssp/mod-lisp.scm
@@ -0,0 +1,662 @@
+#| -*-Scheme-*-
+
+$Id: mod-lisp.scm,v 1.1 2003/12/29 05:24:43 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; MIT/GNU Scheme interface to Apache mod-lisp.
+
+(declare (usual-integrations))
+
+(define (start-server)
+  (start-server-internal 3000
+			 (host-address-loopback)
+			 (cond ((file-directory? "/web/www/") "/web/www/")
+			       ((file-directory? "/var/www/") "/var/www/")
+			       (else (error "No server root?")))))
+
+(define root-paths
+  '("/projects/scheme-pages/"
+    "/classes/6.002x/spring04/"
+    "/classes/6.002ex/spring04/"))
+
+(define (start-server-internal tcp-port tcp-host server-root)
+  (let ((socket (open-tcp-server-socket tcp-port tcp-host)))
+    (dynamic-wind
+     (lambda () unspecific)
+     (lambda ()
+       (do () ((channel-closed? socket))
+	 (let ((port (tcp-server-connection-accept socket #t #f "\n")))
+	   (dynamic-wind
+	    (lambda () unspecific)
+	    (lambda ()
+	      (write-response
+	       (let ((response
+		      (call-with-current-continuation
+		       (lambda (k)
+			 (bind-condition-handler (list condition-type:error)
+			     k
+			   (lambda ()
+			     (handle-request (read-request port)
+					     server-root)))))))
+		 (if (condition? response)
+		     (status-response 500 (condition->html response))
+		     response))
+	       port))
+	    (lambda () (close-port port))))))
+     (lambda () (channel-close socket)))))
+
+(let ((target (the-environment))
+      (source (->environment '(RUNTIME DEBUGGER))))
+  (for-each (lambda (name)
+	      (link-variables target name source name))
+	    '(MAKE-INITIAL-DSTATE
+	      DSTATE/SUBPROBLEM
+	      COMMAND/EARLIER-SUBPROBLEM
+	      COMMAND/PRINT-SUBPROBLEM)))
+
+(define (condition->html condition)
+  (call-with-output-string
+    (lambda (port)
+      (write-string "<p>" port)
+      (newline port)
+      (escape-output port
+	(lambda (port)
+	  (write-condition-report condition port)))
+      (newline port)
+      (write-string "</p>" port)
+      (newline port)
+      (newline port)
+      (write-string "<pre>" port)
+      (let ((dstate (make-initial-dstate condition)))
+	(command/print-subproblem dstate port)
+	(let loop ()
+	  (if (let ((next
+		     (stack-frame/next-subproblem (dstate/subproblem dstate))))
+		(and next (not (stack-frame/repl-eval-boundary? next))))
+	      (begin
+		(newline port)
+		(newline port)
+		(escape-output port
+		  (lambda (port)
+		    (command/earlier-subproblem dstate port)))
+		(loop)))))
+      (write-string "</pre>" port)
+      (newline port))))
+
+(define (escape-output port generator)
+  (write-escaped-string (call-with-output-string generator) port))
+
+(define (write-escaped-string string port)
+  (let ((end (string-length string)))
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i end))
+      (write-escaped-char (string-ref string i) port))))
+
+(define (write-escaped-char char port)
+  (case char
+    ((#\<) (write-string "&lt;" port))
+    ((#\&) (write-string "&amp;" port))
+    (else (write-char char port))))
+
+;;;; Request handler
+
+(define (handle-request request server-root)
+  (let ((url (http-message-url request)))
+    (if trace-requests?
+	(write-line
+	 `(HANDLE-REQUEST ,(http-message-method request)
+			  ,url
+			  ,@(http-message-url-parameters request))))
+    (receive (root-dir relative) (url->relative url server-root)
+      (fluid-let ((*root-dir* root-dir))
+	(let ((response (make-http-message)))
+	  (let ((expand
+		 (lambda (pathname default-type handler)
+		   (add-status-header response 200)
+		   (add-content-type-header response default-type)
+		   (set-entity response
+			       (if handler
+				   (mod-lisp-expander request
+						      response
+						      pathname
+						      handler)
+				   (->pathname pathname))))))
+	    (receive (default-type handler) (get-subtree-handler relative)
+	      (let ((pathname (merge-pathnames relative root-dir)))
+		(if handler
+		    (expand pathname default-type handler)
+		    (begin
+		      (maybe-parse-post-variables request)
+		      (handle-request:default request
+					      response
+					      pathname
+					      expand))))))
+	  response)))))
+
+(define (url->relative url server-root)
+  (let loop ((root-paths root-paths))
+    (if (not (pair? root-paths))
+	(error "Unknown URL root:" url))
+    (let ((prefix (->namestring (pathname-as-directory (car root-paths)))))
+      (if (string-prefix? prefix url)
+	  (values (merge-pathnames (enough-pathname prefix "/")
+				   (pathname-as-directory server-root))
+		  (string-tail url (string-length prefix)))
+	  (loop (cdr root-paths))))))
+
+(define *root-dir*)
+(define trace-requests? #f)
+
+(define (handle-request:default request response pathname expand)
+  (let ((page-found
+	 (lambda (pathname)
+	   (let ((type (file-content-type pathname)))
+	     (expand pathname type (get-mime-handler type)))))
+	(page-not-found
+	 (lambda ()
+	   (status-response! response 404 (http-message-url request)))))
+    (case (file-type-indirect pathname)
+      ((REGULAR)
+       (page-found pathname))
+      ((DIRECTORY)
+       (let ((pathname (find-index-page pathname)))
+	 (if pathname
+	     (page-found pathname)
+	     (page-not-found))))
+      (else
+       (page-not-found)))))
+
+(define (get-subtree-handler relative)
+  (let ((entry
+	 (find-matching-item subtree-handlers
+	   (lambda (entry)
+	     (let loop
+		 ((d1 (pathname-directory (vector-ref entry 0)))
+		  (d2 (pathname-directory relative)))
+	       (or (not (pair? d1))
+		   (and (pair? d2)
+			(equal? (car d1) (car d2))
+			(loop (cdr d1) (cdr d2)))))))))
+    (if entry
+	(values (vector-ref entry 1) (vector-ref entry 2))
+	(values #f #f))))
+
+(define (define-subtree-handler pathname default-type handler)
+  (let ((pathname (pathname-as-directory pathname)))
+    (let ((entry
+	   (find-matching-item subtree-handlers
+	     (lambda (entry)
+	       (pathname=? (vector-ref entry 0) pathname)))))
+      (if entry
+	  (begin
+	    (vector-set! entry 1 default-type)
+	    (vector-set! entry 2 handler))
+	  (begin
+	    (set! subtree-handlers
+		  (cons (vector pathname default-type handler)
+			subtree-handlers))
+	    unspecific)))))
+
+(define subtree-handlers '())
+
+(define (find-index-page directory)
+  (let ((directory (pathname-as-directory directory)))
+    (let ((filename
+	   (find-matching-item default-index-pages
+	     (lambda (filename)
+	       (file-exists? (merge-pathnames filename directory))))))
+      (and filename
+	   (merge-pathnames filename directory)))))
+
+(define default-index-pages
+  '("index.xhtml" "index.xml" "index.html"))
+
+(define (mod-lisp-expander request response pathname expander)
+  (call-with-output-string
+    (lambda (port)
+      (fluid-let ((*current-request* request)
+		  (*current-response* response)
+		  (*current-pathname* pathname)
+		  (expander-eval
+		   (lambda (expression environment)
+		     (with-repl-eval-boundary (nearest-repl)
+		       (lambda ()
+			 (eval expression environment))))))
+	(expander pathname port)))))
+
+(define *current-request*)
+(define *current-response*)
+(define *current-pathname*)
+
+;;;; MIME stuff
+
+(define (file-content-type pathname)
+  (let ((extension (pathname-type pathname)))
+    (and (string? extension)
+	 (hash-table/get mime-extensions extension #f))))
+
+(define (get-mime-handler type)
+  (hash-table/get mime-handlers type #f))
+
+(define (define-mime-handler type handle-request)
+  (cond ((symbol? type)
+	 (hash-table/put! mime-handlers type handle-request))
+	((and (pair? type)
+	      (symbol? (car type))
+	      (for-all? (cdr type) string?))
+	 (hash-table/put! mime-handlers (car type) handle-request)
+	 (for-each (lambda (extension)
+		     (let ((index
+			    (->namestring
+			     (pathname-new-type "index" extension))))
+		       (if (not (member index default-index-pages))
+			   (set! default-index-pages
+				 (append default-index-pages
+					 (list index)))))
+		     (hash-table/put! mime-extensions extension (car type)))
+		   (cdr type)))
+	(else
+	 (error:wrong-type-argument type "MIME type" 'DEFINE-MIME-HANDLER))))
+
+(define mime-handlers (make-eq-hash-table))
+(define mime-extensions (make-string-hash-table))
+
+(define (initialize-mime-extensions)
+  (for-each-file-line "/etc/mime.types"
+    (lambda (line)
+      (let ((line (string-trim line)))
+	(if (and (fix:> (string-length line) 0)
+		 (not (char=? (string-ref line 0) #\#)))
+	    (let ((tokens (burst-string line char-set:whitespace #t)))
+	      (let ((type (string->symbol (car tokens))))
+		(for-each (lambda (token)
+			    (hash-table/put! mime-extensions token type))
+			  (cdr tokens))))))))
+  ;; Should be 'application/xhtml+xml -- IE loses.
+  (define-mime-handler '(text/html "xhtml" "xht")
+    (lambda (pathname port)
+      (expand-xhtml-file pathname port))))
+
+;;;; Read request
+
+(define (read-request port)
+  (let ((request (make-http-message)))
+    (let loop ()
+      (let ((keyword (read-line port)))
+	(if (eof-object? keyword)
+	    (error "EOF while reading headers."))
+	(if (not (string-ci=? keyword "end"))
+	    (let ((keyword (intern keyword))
+		  (datum (read-line port)))
+	      (if (eof-object? datum)
+		  (error "Missing command datum:" keyword))
+	      (if debug-request-headers?
+		  (write-line (list keyword datum)))
+	      (case keyword
+		((METHOD)
+		 (let ((method (intern datum)))
+		   (if (not (memq method '(GET POST)))
+		       (error "Unknown HTTP method:" method))
+		   (set-http-message-method! request method)))
+		((URL)
+		 (receive (url parameters) (parse-url datum)
+		   (set-http-message-url! request url)
+		   (set-http-message-url-parameters! request parameters)))
+		((CONTENT-LENGTH)
+		 (set-http-message-entity!
+		  request
+		  (make-string
+		   (or (string->number datum)
+		       (error "Invalid Content-Length:" datum)))))
+		((COOKIE)
+		 (set-http-message-cookie-parameters!
+		  request
+		  (parse-parameters datum)))
+		(else
+		 (add-header request keyword datum)))
+	      (loop)))))
+    (let ((entity (http-message-entity request)))
+      (if entity
+	  (begin
+	    (if (fix:> (string-length entity) 0)
+		(read-string! entity port)))))
+    request))
+
+(define debug-request-headers? #f)
+
+(define (parse-url url)
+  (let ((q (string-find-next-char url #\?)))
+    (if q
+	(values (string-head url q)
+		(parse-parameters (string-tail url (fix:+ q 1))))
+	(values url '()))))
+
+(define (maybe-parse-post-variables request)
+  (let ((entity (http-message-entity request)))
+    (if (and entity (eq? 'POST (http-message-method request)))
+	(begin
+	  (set-http-message-post-parameters! request (parse-parameters entity))
+	  (set-http-message-entity! request #f)
+	  (if debug-post-variables?
+	      (pp (http-message-post-parameters request)))))))
+
+(define debug-post-variables? #f)
+
+(define (parse-parameters string)
+  (let loop ((parameters (burst-string string #\& #f)))
+    (if (pair? parameters)
+	(let ((parameter (car parameters))
+	      (tail (loop (cdr parameters))))
+	  (let ((e (string-find-next-char parameter #\=)))
+	    (if e
+		(cons (cons (string->symbol (string-head parameter e))
+			    (decode-parameter-value parameter
+						    (fix:+ e 1)
+						    (string-length parameter)))
+		      tail)
+		tail)))
+	'())))
+
+(define (decode-parameter-value string start end)
+  (call-with-output-string
+    (lambda (port)
+      (let loop ((start start))
+	(receive (char start) (decode-parameter-char string start end)
+	  (if char
+	      (if (char=? char #\return)
+		  (receive (char* start*)
+		      (decode-parameter-char string start end)
+		    (if (eqv? char* #\newline)
+			(begin
+			  (newline port)
+			  (loop start*))
+			(begin
+			  (write-char char port)
+			  (loop start))))
+		  (begin
+		    (write-char char port)
+		    (loop start)))))))))
+
+(define (decode-parameter-char string start end)
+  (if (fix:< start end)
+      (let ((char (string-ref string start)))
+	(cond ((not (char=? char #\%))
+	       (values (if (char=? char #\+) #\space char)
+		       (fix:+ start 1)))
+	      ((fix:<= (fix:+ start 3) end)
+	       (let ((d1 (char->digit (string-ref string (fix:+ start 1)) 16))
+		     (d2 (char->digit (string-ref string (fix:+ start 2)) 16)))
+		 (if (and d1 d2)
+		     (values (integer->char (+ (* 16 d1) d2))
+			     (fix:+ start 3))
+		     (values #f start))))
+	       (else
+		(values #f start))))
+      (values #f #f)))
+
+;;;; HTTP message datatype
+
+(define-structure (http-message (constructor make-http-message ()))
+  (headers '())
+  (headers-tail '())
+  (entity #f)
+  (method #f)
+  (url #f)
+  (url-parameters '())
+  (post-parameters '())
+  (cookie-parameters '()))
+
+(define (add-header message keyword datum)
+  (let ((new (list (cons keyword datum)))
+	(tail (http-message-headers-tail message)))
+    (if tail
+	(set-cdr! tail new)
+	(set-http-message-headers! message new))
+    (set-http-message-headers-tail! message new)))
+
+(define (set-entity message entity)
+  (add-header message
+	      'CONTENT-LENGTH
+	      (number->string
+	       (cond ((string? entity)
+		      (string-length entity))
+		     ((pathname? entity)
+		      (file-length entity))
+		     (else
+		      (error:wrong-type-argument entity
+						 "string or pathname"
+						 'SET-ENTITY)))))
+  (set-http-message-entity! message entity))
+
+(define (write-response message port)
+  (for-each (lambda (header)
+	      ;; Kludge: mod-lisp uses case-sensitive comparisons for
+	      ;; these headers.
+	      (write-string (case (car header)
+			      ((CONTENT-LENGTH) "Content-Length")
+			      ((CONTENT-TYPE) "Content-Type")
+			      ((KEEP-SOCKET) "Keep-Socket")
+			      ((LAST-MODIFIED) "Last-Modified")
+			      ((LOCATION) "Location")
+			      ((LOG) "Log")
+			      ((LOG-ERROR) "Log-Error")
+			      ((NOTE) "Note")
+			      ((SET-COOKIE) "Set-Cookie")
+			      ((STATUS) "Status")
+			      (else (symbol-name (car header))))
+			    port)
+	      (newline port)
+	      (write-string (cdr header) port)
+	      (newline port))
+	    (http-message-headers message))
+  (write-string "end" port)
+  (newline port)
+  (let ((entity (http-message-entity message)))
+    (cond ((string? entity)
+	   (write-string entity port))
+	  ((pathname? entity)
+	   (call-with-input-file entity
+	     (lambda (input)
+	       (port->port-copy input port))))
+	  (else
+	   (error "Illegal HTTP entity:" entity)))))
+
+;;;; Status messages
+
+(define (status-response code extra)
+  (let ((response (make-http-message)))
+    (status-response! response code extra)
+    response))
+
+(define (status-response! response code extra)
+  (add-status-header response code)
+  (add-content-type-header response 'text/html)
+  (set-entity response
+	      (call-with-output-string
+		(lambda (port)
+		  (let ((message (status-message code))
+			(start
+			 (lambda (name)
+			   (write-char #\< port)
+			   (write-string name port)
+			   (write-char #\> port)
+			   (newline port)))
+			(end
+			 (lambda (name)
+			   (write-char #\< port)
+			   (write-char #\/ port)
+			   (write-string name port)
+			   (write-char #\> port)
+			   (newline port))))
+		    (start "html")
+		    (start "head")
+		    (write-string "<title>" port)
+		    (write-string message port)
+		    (write-string "</title>" port)
+		    (newline port)
+		    (end "head")
+		    (start "body")
+		    (write-string "<h1>" port)
+		    (write-string message port)
+		    (write-string "</h1>" port)
+		    (newline port)
+		    (if extra
+			(begin
+			  (display extra port)
+			  (newline port)))
+		    (end "body")
+		    (end "html"))))))
+
+(define (status-message code)
+  (case code
+    ((200) "OK")
+    ((404) "Not Found")
+    ((500) "Internal Server Error")
+    (else (error "Unknown status code:" code))))
+
+(define (add-status-header message code)
+  (add-header message
+	      'STATUS
+	      (call-with-output-string
+		(lambda (port)
+		  (write code port)
+		  (write-char #\space port)
+		  (write-string (status-message code) port)))))
+
+(define (add-content-type-header message type)
+  (add-header message 'CONTENT-TYPE (symbol-name type)))
+
+;;;; Request/response accessors
+
+(let ((defaccess
+	(lambda (name accessor)
+	  (define-expander name
+	    (lambda ()
+	      (accessor *current-request*))))))
+  (defaccess 'HTTP-REQUEST-ENTITY http-message-entity)
+  (defaccess 'HTTP-REQUEST-METHOD http-message-method)
+  (defaccess 'HTTP-REQUEST-URL http-message-url))
+
+(let ((defget
+	(lambda (name accessor)
+	  (define-expander name
+	    (lambda (keyword #!optional error?)
+	      (let ((p (assq keyword (accessor *current-request*))))
+		(if p
+		    (cdr p)
+		    (begin
+		      (if (and (not (default-object? error?)) error?)
+			  (error:bad-range-argument keyword name))
+		      #f)))))
+	  (define-expander (symbol-append name '-bindings)
+	    (lambda ()
+	      (accessor *current-request*))))))
+  (defget 'HTTP-REQUEST-HEADER http-message-headers)
+  (defget 'HTTP-REQUEST-URL-PARAMETER http-message-url-parameters)
+  (defget 'HTTP-REQUEST-POST-PARAMETER http-message-post-parameters)
+  (defget 'HTTP-REQUEST-COOKIE-PARAMETER http-message-cookie-parameters))
+
+(define-expander 'HTTP-REQUEST-POST-PARAMETER-MULTIPLE
+  (lambda (keyword)
+    (let loop
+	((bindings (http-message-post-parameters *current-request*))
+	 (strings '()))
+      (if (pair? bindings)
+	  (loop (cdr bindings)
+		(if (eq? (caar bindings) keyword)
+		    (cons (cdar bindings) strings)
+		    strings))
+	  (reverse! strings)))))
+
+(define-expander 'HTTP-REQUEST-PATHNAME
+  (lambda ()
+    *current-pathname*))
+
+(define-expander 'HTTP-RESPONSE-HEADER
+  (lambda (keyword datum)
+    (guarantee-symbol keyword 'HTTP-RESPONSE-HEADER)
+    (guarantee-string datum 'HTTP-RESPONSE-HEADER)
+    (if (memq keyword '(STATUS CONTENT-LENGTH))
+	(error "Illegal header keyword:" keyword))
+    (add-header *current-response* keyword datum)))
+
+(define-expander 'HTTP-STATUS-RESPONSE
+  (lambda (code extra)
+    (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE)
+    (guarantee-string extra 'HTTP-STATUS-RESPONSE)
+    (status-response! *current-response* code extra)))
+
+(define-expander 'SERVER-ROOT-DIR
+  (lambda ()
+    *root-dir*))
+
+(define-expander 'HTTP-REQUEST-USER-NAME
+  (lambda ()
+    (let ((auth (http-request-header 'authorization)))
+      (and auth
+	   (cond ((string-prefix? "Basic " auth)
+		  (decode-basic-auth-header auth 6 (string-length auth)))
+		 (else
+		  (error "Unknown authorization header format:" auth)))))))
+
+(define (decode-basic-auth-header string start end)
+  (let ((auth
+	 (call-with-output-string
+	   (lambda (port)
+	     (let ((ctx (decode-base64:initialize port #t)))
+	       (decode-base64:update ctx string start end)
+	       (decode-base64:finalize ctx))))))
+    (let ((colon (string-find-next-char auth #\:)))
+      (if (not colon)
+	  (error "Malformed authorization string."))
+      (string-head auth colon))))
+
+;;;; Utilities
+
+(define (port->port-copy input output #!optional buffer-size)
+  (let ((buffer
+	 (make-string (if (default-object? buffer-size)
+			  #x10000
+			  buffer-size))))
+    (let loop ()
+      (let ((n (read-string! buffer input)))
+	(cond ((not n)
+	       (loop))
+	      ((> n 0)
+	       (write-substring buffer 0 n output)
+	       (loop)))))))
+
+(define (for-each-file-line pathname procedure)
+  (call-with-input-file pathname
+    (lambda (port)
+      (for-each-port-line port procedure))))
+
+(define (for-each-port-line port procedure)
+  (let loop ()
+    (let ((line (read-line port)))
+      (if (not (eof-object? line))
+	  (begin
+	    (procedure line)
+	    (loop))))))
+
+(initialize-mime-extensions)
\ No newline at end of file
diff --git a/v7/src/ssp/validate-xdoc.scm b/v7/src/ssp/validate-xdoc.scm
new file mode 100644
index 000000000..c1e3172f8
--- /dev/null
+++ b/v7/src/ssp/validate-xdoc.scm
@@ -0,0 +1,461 @@
+#| -*-Scheme-*-
+
+$Id: validate-xdoc.scm,v 1.1 2003/12/29 05:24:47 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XDOC implementation
+
+(declare (usual-integrations))
+
+;;; **** Belongs in runtime:
+(define (count-matching-items items predicate)
+  (do ((items items (cdr items))
+       (n 0 (if (predicate (car items)) (+ n 1) n)))
+      ((not (pair? items)) n)))
+
+(define (validate-xdoc pathname)
+  (with-xdoc-expansion-context (pathname->ps-number pathname) pathname
+    (lambda (document)
+      (let ((root (xml-document-root document)))
+	(if (not (xd:xdoc? root))
+	    (vx:error root "Root element not <xdoc>."))
+	(check-element root 'xdoc)))))
+
+(define (check-element elt local)
+  (let ((v (hash-table/get element-checkers local #f)))
+    (if (not v)
+	(error "Missing element definition:" local))
+    (let ((valid-attrs? (vector-ref v 0))
+	  (type (vector-ref v 1))
+	  (valid-local? (vector-ref v 2))
+	  (procedure (vector-ref v 3)))
+      (if valid-attrs?
+	  (valid-attrs? elt))
+      (check-element-content elt type valid-local?)
+      (if procedure
+	  (procedure elt)))))
+
+(define (check-element-content elt type procedure)
+  (case type
+    ((empty)
+     (if (not (null? (xml-element-contents elt)))
+	 (vx:error elt "Empty element has content.")))
+    ((element)
+     (procedure elt))
+    (else
+     (for-each (case type
+		 ((text)
+		  (lambda (item)
+		    (if (not (string? item))
+			(vx:content-error elt item))))
+		 ((html)
+		  (lambda (item)
+		    (if (xdoc-element? item)
+			(vx:content-error elt item))))
+		 ((mixed)
+		  (lambda (item)
+		    (let ((local (xdoc-element-name item)))
+		      (if local
+			  (if (content-predicate local)
+			      (check-element item local)
+			      (vx:content-error elt item))))))
+		 (else
+		  (error "Unknown content type:" type)))
+	       (xml-element-contents elt)))))
+
+(define (define-element-checker local type
+	  #!optional valid-attrs? valid-local? procedure)
+  (let ((valid-attrs? (if (default-object? valid-attrs?) #f valid-attrs?))
+	(valid-local? (if (default-object? valid-local?) #f valid-local?))
+	(procedure (if (default-object? procedure) #f procedure)))
+    (if (and (memq type '(element mixed))
+	     (not valid-local?))
+	(error "Must supply a name predicate with this content type:" type))
+    (hash-table/put! element-checkers
+		     local
+		     (vector valid-attrs? type valid-local? procedure))))
+
+(define element-checkers
+  (make-eq-hash-table))
+
+(define (vx:standard-attrs elt)
+  (vx:optional-attr 'class elt vx:nmtokens)
+  (vx:optional-attr 'style elt vx:style))
+
+;;;; Containers
+
+(define (vx:container-attrs elt)
+  (vx:standard-attrs elt)
+  (vx:optional-attr 'id elt vx:id))
+
+(define (problem-element-name? local)
+  (or (memq local '(problem answer))
+      (answer-element-name? local)))
+
+(define (answer-element-name? local)
+  (or (input-checker-element-name? local)
+      (switched-output-name? local)
+      (button-element-name? local)))
+
+(define-element-checker 'xdoc 'mixed
+  (lambda (elt)
+    (vx:container-attrs elt)
+    (vx:optional-attr 'number-format elt vx:procedure-name)
+    (vx:optional-attr 'problem-separator elt vx:boolean)
+    (vx:required-attr 'problem-set elt vx:nonnegative-integer)
+    (vx:optional-attr 'first-problem elt vx:problem-number)
+    (vx:optional-attr 'form-url elt vx:url))
+  (lambda (local)
+    (or (problem-element-name? local)
+	(memq local '(due-date head))))
+  (lambda (elt)
+    (if (> (count-matching-items (xml-element-contents elt) xd:due-date?) 1)
+	(vx:error elt "Multiple xd:due-date elements."))))
+
+(define-element-checker 'head 'html)
+
+(define-element-checker 'due-date 'empty
+  (lambda (elt)
+    (vx:standard-attrs elt)
+    (vx:optional-attr 'year elt vx:year)
+    (vx:required-attr 'month elt vx:month)
+    (vx:required-attr 'day elt vx:day)
+    (vx:required-attr 'hour elt vx:hour)
+    (vx:optional-attr 'minute elt vx:minute)))
+
+(define-element-checker 'problem 'mixed
+  (lambda (elt)
+    (vx:container-attrs elt)
+    (vx:optional-attr 'number-format elt vx:procedure-name)
+    (vx:optional-attr 'number-type elt vx:number-type)
+    (vx:optional-attr 'problem-separator elt vx:boolean))
+  (lambda (local)
+    (problem-element-name? local)))
+
+(define-element-checker 'answer 'element
+  (lambda (elt)
+    (vx:container-attrs elt))
+  (lambda (local)
+    (or (answer-element-name? local)
+	(input-element-name? local)
+	(eq? local 'label))))
+
+(define-element-checker 'label 'html
+  (lambda (elt)
+    (vx:standard-attrs elt)))
+
+;;;; Inputs
+
+(define (input-element-name? local)
+  (memq local '(checkbox menu radio-buttons text true-false)))
+
+(define (vx:input-attrs elt)
+  (vx:standard-attrs elt)
+  (vx:optional-attr 'width elt vx:positive-integer))
+
+(define-element-checker 'text 'empty
+  (lambda (elt)
+    (vx:input-attrs elt)))
+
+(define-element-checker 'menu 'element
+  (lambda (elt)
+    (vx:input-attrs elt)
+    (vx:optional-attr 'size elt vx:positive-integer))
+  (lambda (local)
+    (eq? local 'menuitem)))
+
+(define-element-checker 'menuitem 'text)
+
+(define-element-checker 'true-false 'empty
+  (lambda (elt)
+    (vx:input-attrs elt)))
+
+(define-element-checker 'checkbox 'empty
+  (lambda (elt)
+    (vx:input-attrs elt)))
+
+(define-element-checker 'radio-buttons 'element
+  (lambda (elt)
+    (vx:input-attrs elt))
+  (lambda (local)
+    (eq? local 'radio-entry)))
+
+(define-element-checker 'radio-entry 'html
+  (lambda (elt)
+    (vx:input-attrs elt)
+    (vx:required-attr 'value elt vx:nmtoken)))
+
+;;;; Input checkers
+
+(define (input-checker-element-name? local)
+  (memq local '(boolean check-input check-inputs menuindex number)))
+
+(define (vx:unary-checker-attrs elt)
+  (vx:optional-attr 'id elt vx:id)
+  (vx:optional-attr 'source elt vx:idref))
+
+(define (vx:n-ary-checker-attrs elt)
+  (vx:optional-attr 'id elt vx:id)
+  (vx:optional-attr 'sources elt vx:idrefs))
+
+(define-element-checker 'check-input 'empty
+  (lambda (elt)
+    (vx:unary-checker-attrs elt)
+    (vx:optional-attr 'expected elt vx:cdata)
+    (vx:optional-attr 'checkable elt vx:boolean)
+    (vx:required-attr 'name elt vx:procedure-name)))
+
+(define-element-checker 'check-inputs 'empty
+  (lambda (elt)
+    (vx:n-ary-checker-attrs elt)
+    (vx:optional-attr 'expected elt vx:cdata)
+    (vx:optional-attr 'checkable elt vx:boolean)
+    (vx:required-attr 'name elt vx:procedure-name)))
+
+(define-element-checker 'number 'empty
+  (lambda (elt)
+    (vx:unary-checker-attrs elt)
+    (vx:required-attr 'expected elt vx:number)
+    (vx:optional-attr 'checkable elt vx:boolean)
+    (vx:optional-attr 'tolerance elt vx:number)))
+
+(define-element-checker 'boolean 'empty
+  (lambda (elt)
+    (vx:unary-checker-attrs elt)
+    (vx:required-attr 'expected elt vx:boolean)))
+
+(define-element-checker 'menuindex 'empty
+  (lambda (elt)
+    (vx:unary-checker-attrs elt)
+    (vx:required-attr 'expected elt vx:positive-integer)))
+
+;;;; Switched elements
+
+(define (switched-output-name? local)
+  (memq local '(case expected-value explain hint when)))
+
+(define (vx:switched-output-attrs elt)
+  (vx:standard-attrs elt)
+  (vx:optional-attr 'source elt vx:idref))
+
+(define-element-checker 'explain 'html
+  (lambda (elt)
+    (vx:switched-output-attrs elt)))
+
+(define-element-checker 'hint 'html
+  (lambda (elt)
+    (vx:switched-output-attrs elt)))
+
+(define-element-checker 'expected-value 'empty
+  (lambda (elt)
+    (vx:switched-output-attrs elt)))
+
+(define-element-checker 'when 'html
+  (lambda (elt)
+    (vx:switched-output-attrs elt)
+    (vx:required-attr 'condition elt
+		      (lambda (string)
+			(vx:test (lambda (string)
+				   (or (string=? string "submitted")
+				       (string=? string "not-submitted")))
+				 string
+				 "condition")))))
+
+(define-element-checker 'case 'element
+  (lambda (elt)
+    (vx:standard-attrs elt))
+  (lambda (local)
+    (or (input-checker-element-name? local)
+	(eq? local 'refer)
+	(eq? local 'choice)
+	(eq? local 'default)))
+  (lambda (elt)
+    (if (not (case-element-children? (xml-element-contents elt)))
+	(vx:error elt "Invalid arrangement of child elements."))))
+
+(define-element-checker 'refer 'empty
+  (lambda (elt)
+    (vx:required-attr 'source elt vx:idref)))
+
+(define-element-checker 'choice 'html
+  (lambda (elt)
+    (vx:required-attr 'values elt vx:nmtokens)))
+
+(define-element-checker 'default 'html)
+
+;;;; Buttons
+
+(define (button-element-name? local)
+  (memq local '(check-button submit-button)))
+
+(define (vx:button-attrs elt)
+  (vx:standard-attrs elt)
+  (vx:optional-attr 'scope elt vx:idref))
+
+(define-element-checker 'check-button 'empty
+  (lambda (elt)
+    (vx:button-attrs elt)))
+
+(define-element-checker 'submit-button 'empty
+  (lambda (elt)
+    (vx:button-attrs elt)))
+
+;;;; Attribute tests
+
+(define (vx:required-attr name elt test)
+  (let ((attr (%find-attribute name (xml-element-attributes elt))))
+    (if attr
+	(vx:check-attr test attr elt)
+	(vx:error "Missing required attribute: " name elt))))
+
+(define (vx:optional-attr name elt test)
+  (let ((attr (%find-attribute name (xml-element-attributes elt))))
+    (if attr
+	(vx:check-attr test attr elt))))
+
+(define (vx:check-attr test attr elt)
+  (let ((desc (test (xml-attribute-value attr))))
+    (if desc
+	(vx:error elt
+		  "Attribute "
+		  (xml-attribute-name attr)
+		  " value should be "
+		  desc
+		  ":"
+		  (xml-attribute-value attr)))))
+
+(define ((vx:tester desc predicate) string)
+  (if (predicate string)
+      #f
+      desc))
+
+(define (vx:number-tester desc predicate)
+  (vx:tester desc
+    (lambda (string)
+      (predicate (string->number string)))))
+
+(define (vx:index-tester desc k l)
+  (vx:number-tester desc
+    (lambda (n)
+      (and (exact-integer? n)
+	   (<= k n l)))))
+
+(define vx:cdata (vx:tester "XML string" xml-char-data?))
+(define vx:id (vx:tester "ID" string-is-xml-name?))
+(define vx:idref (vx:tester "ID reference" string-is-xml-name?))
+(define vx:nmtoken (vx:tester "XML token" string-is-xml-nmtoken?))
+
+(define vx:idrefs
+  (vx:tester "ID references"
+    (lambda (string)
+      (for-all? (burst-string string char-set:whitespace #t)
+	string-is-xml-name?))))
+
+(define vx:nmtokens
+  (vx:tester "XML tokens"
+    (lambda (string)
+      (for-all? (burst-string string char-set:whitespace #t)
+	string-is-xml-nmtoken?))))
+
+(define vx:boolean
+  (vx:tester "true or false"
+    (lambda (string)
+      (or (string=? string "true")
+	  (string=? string "false")))))
+
+(define vx:style
+  (vx:tester "style sheet"
+    (lambda (string)
+      string
+      #t)))
+
+(define vx:url
+  (vx:tester "URL"
+    (lambda (string)
+      string
+      #t)))
+
+(define vx:number
+  (vx:number-tester "number" number?))
+
+(define vx:nonnegative-integer
+  (vx:number-tester "non-negative integer" exact-nonnegative-integer?))
+
+(define vx:positive-integer
+  (vx:number-tester "positive integer" exact-positive-integer?))
+
+(define vx:minute (vx:index-tester "minute" 0 59))
+(define vx:hour (vx:index-tester "hour" 0 59))
+(define vx:day (vx:index-tester "day of month" 1 31))
+(define vx:month (vx:index-tester "month" 1 12))
+(define vx:year (vx:number-tester "year" exact-nonnegative-integer?))
+
+(define vx:problem-number
+  (vx:tester "problem number"
+    (lambda (string)
+      (re-string-match "\\`\\([1-9][0-9]*.\\)*[1-9][0-9]*\\'" string))))
+
+(define vx:number-type
+  (vx:tester "problem-number format type"
+    (lambda (string)
+      (or (string=? string "dl")
+	  (string=? string "ol")
+	  (string=? string "ul")
+	  (string=? string "none")))))
+
+(define vx:procedure-name
+  (vx:tester "procedure name" xdoc-procedure-name?))
+
+(define (vx:content-error elt item)
+  (vx:error elt "Illegal content: " item))
+
+(define (vx:error elt msg . msg-items)
+  (error:xdoc-validation elt (cons msg msg-items)))
+
+(define condition-type:xdoc-validation-error
+  (make-condition-type 'xdoc-validation-error
+      condition-type:warning
+      '(element message-items)
+    (lambda (condition port)
+      (write-string "Error validating " port)
+      (write (xdoc-validation-error/element condition) port)
+      (write-string ": " port)
+      (let loop ((items (xdoc-validation-error/message-items condition)))
+	(if (pair? items)
+	    (begin
+	      (write-string (car items) port)
+	      (if (pair? (cdr items))
+		  (begin
+		    (write (cadr items) port)
+		    (loop (cddr items))))))))))
+
+(define xdoc-validation-error/element
+  (condition-accessor condition-type:xdoc-validation-error 'element))
+
+(define xdoc-validation-error/message-items
+  (condition-accessor condition-type:xdoc-validation-error 'message-items))
+
+(define error:xdoc-validation
+  (condition-signaller condition-type:xdoc-validation-error
+		       '(element message-items)
+		       standard-warning-handler))
\ No newline at end of file
diff --git a/v7/src/ssp/xdoc.scm b/v7/src/ssp/xdoc.scm
new file mode 100644
index 000000000..51a1d2242
--- /dev/null
+++ b/v7/src/ssp/xdoc.scm
@@ -0,0 +1,1467 @@
+#| -*-Scheme-*-
+
+$Id: xdoc.scm,v 1.1 2003/12/29 05:24:51 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XDOC implementation
+
+(declare (usual-integrations))
+
+(define *xdoc-environment*)
+(define *xdoc-root*)
+(define *xdoc-late?*)
+(define *xdoc-element-properties*)
+(define *xdoc-id-map*)
+(define *xdoc-inputs*)
+(define *xdoc-outputs*)
+(define *trace-expansion-port* #f)
+
+(define-mime-handler '(application/xdoc+xml "xdoc")
+  (lambda (pathname port)
+    ;; Should be "application/xhtml+xml" -- IE loses.
+    (http-response-header 'content-type "text/html")
+    (write-xml
+     (with-xdoc-expansion-context (pathname->ps-number pathname) pathname
+       (lambda (document)
+	 (memoize-xdoc-inputs)
+	 (memoize-xdoc-outputs)
+	 (let ((pad-misc
+		(lambda (misc)
+		  (cons "\n"
+			(append-map! (lambda (item) (list item "\n"))
+				     misc)))))
+	   (make-xml-document (or (xml-document-declaration document)
+				  (make-xml-declaration "1.0" "utf-8" #f))
+			      (pad-misc (xml-document-misc-1 document))
+			      xhtml-dtd
+			      (pad-misc (xml-document-misc-2 document))
+			      (generate-xdoc-html (xml-document-root document))
+			      (pad-misc (xml-document-misc-3 document))))))
+     port
+     'indent-dtd? #t
+     'indent-attributes? #t)))
+
+(define (pathname->ps-number pathname)
+  (let ((s (car (last-pair (pathname-directory pathname)))))
+    (let ((regs (re-string-match "\\`ps\\([0-9]+\\)\\'" s #t)))
+      (if regs
+	  (string->number (re-match-extract s regs 1))
+	  0))))
+
+(define (with-xdoc-expansion-context ps-number pathname procedure)
+  (with-database-connection ps-number pathname
+    (lambda ()
+      (let ((environment (make-expansion-environment pathname)))
+	(fluid-let ((*xdoc-environment* environment)
+		    (*xdoc-root*)
+		    (*xdoc-late?*)
+		    (*xdoc-element-properties* (make-eq-hash-table))
+		    (*xdoc-id-map* (make-eq-hash-table))
+		    (*xdoc-inputs* (make-eq-hash-table))
+		    (*xdoc-outputs* (make-eq-hash-table)))
+	  (let ((document (read/expand-xml-file pathname environment)))
+	    (set! *xdoc-root* (xml-document-root document))
+	    (set! *xdoc-late?* (due-date-in-past?))
+	    (xdoc-pre-passes document)
+	    (if *trace-expansion-port*
+		(begin
+		  (write-xml document *trace-expansion-port*)
+		  (fresh-line *trace-expansion-port*)
+		  (flush-output *trace-expansion-port*)))
+	    (procedure document)))))))
+
+(define (trace-expansion filename)
+  (set! *trace-expansion-port* (open-output-file filename))
+  unspecific)
+
+(define (untrace-expansion)
+  (let ((port *trace-expansion-port*))
+    (set! *trace-expansion-port* #f)
+    (if port
+	(close-port port))))
+
+;;;; Document analysis
+
+(define (xdoc-pre-passes document)
+  (let ((root (xml-document-root document)))
+    (strip-xdoc-space document)
+    (save-structure-properties root)))
+
+(define (strip-xdoc-space document)
+  (let ((strip!
+	 (lambda (object accessor modifier)
+	   (modifier object
+		     (delete-matching-items! (accessor object)
+		       xml-comment?))
+	   (modifier object
+		     (delete-matching-items! (accessor object)
+		       xml-whitespace-string?)))))
+    (strip! document xml-document-misc-1 set-xml-document-misc-1!)
+    (set-xml-document-dtd! document #f)
+    (strip! document xml-document-misc-2 set-xml-document-misc-2!)
+    (let loop ((elt (xml-document-root document)))
+      (if (memq (xdoc-content-type elt) '(empty element))
+	  (strip! elt xml-element-contents set-xml-element-contents!))
+      (for-each (lambda (item)
+		  (if (xml-element? item)
+		      (loop item)))
+		(xml-element-contents elt)))
+    (strip! document xml-document-misc-3 set-xml-document-misc-3!)))
+
+(define (save-structure-properties root)
+  (receive (prefix n) (ps-info root)
+    ;; Make unique top-level ID.
+    (save-container-props root '() (string-append "xdoc_" prefix) 1 (- n 1))
+    (let ((get-misc-id
+	   (let ((prefix (string-append prefix (number->string n) "-"))
+		 (count 0))
+	     (lambda ()
+	       (let ((id
+		      (string->symbol
+		       (string-append prefix
+				      (string-pad-left (number->string count)
+						       4
+						       #\0)))))
+		 (set! count (+ count 1))
+		 id)))))
+      (let walk-container
+	  ((elt root)
+	   (containers (list root))
+	   (prefix prefix)
+	   (offset (- n 1)))
+	(let loop ((items (xml-element-contents elt)) (count 1))
+	  (if (pair? items)
+	      (let ((item (car items)))
+		(if (xdoc-internal-container? item)
+		    (begin
+		      (walk-container item
+				      (cons item containers)
+				      (save-container-props item
+							    containers
+							    prefix
+							    count
+							    offset)
+				      0)
+		      (loop (cdr items) (+ count 1)))
+		    (begin
+		      (let walk-html ((item item))
+			(if (xdoc-container? item)
+			    (error "No containers in HTML:" item))
+			(if (xdoc-element? item)
+			    (save-element-props item containers (get-misc-id)))
+			(if (xml-element? item)
+			    (for-each walk-html (xml-element-contents item))))
+		      (loop (cdr items) count))))))))))
+
+(define-expander 'xdoc-part-number
+  (lambda (name)
+    (if (string-prefix? "xdoc_" name)
+	(string-tail name 5)
+	name)))
+
+(define (ps-info elt)
+  (let ((no (find-attribute 'first-problem elt #f)))
+    (if no
+	(let ((regs
+	       (re-string-match "\\`\\(\\([0-9]+.\\)*\\)\\([0-9]+\\)\\'" no)))
+	  (if (not regs)
+	      (error "Malformed first-problem attribute:" no))
+	  (values (re-match-extract no regs 1)
+		  (string->number (re-match-extract no regs 3))))
+	(values "" 1))))
+
+(define (save-container-props elt containers prefix count offset)
+  (let ((number (+ count offset)))
+    (let ((db-id (string-append prefix (number->string number))))
+      (hash-table/put! *xdoc-element-properties* elt
+		       (vector (string->symbol db-id)
+			       containers
+			       prefix
+			       number
+			       count))
+      (save-xdoc-id elt)
+      (string-append db-id "."))))
+
+(define (save-element-props elt containers db-id)
+  (hash-table/put! *xdoc-element-properties* elt (vector db-id containers))
+  (save-xdoc-id elt)
+  (cond ((xdoc-input? elt)
+	 (hash-table/put! *xdoc-inputs* elt #f))
+	((xdoc-output? elt)
+	 (hash-table/put! *xdoc-outputs* elt #f))))
+
+(define (save-xdoc-id elt)
+  (let ((id (id-attribute 'id elt #f)))
+    (if id
+	(begin
+	  (if (hash-table/get *xdoc-id-map* id #f)
+	      (error "ID attribute not unique:" id))
+	  (hash-table/put! *xdoc-id-map* id elt)))))
+
+(define (xdoc-db-id elt)
+  (vector-ref (%xdoc-element-properties elt) 0))
+
+(define (xdoc-element-containers elt)
+  (vector-ref (%xdoc-element-properties elt) 1))
+
+(define (xdoc-element-properties elt)
+  (let ((v (%xdoc-element-properties elt)))
+    (values (vector-ref v 2)
+	    (vector-ref v 3)
+	    (length (vector-ref v 1))
+	    (vector-ref v 4))))
+
+(define (%xdoc-element-properties elt)
+  (let ((v (hash-table/get *xdoc-element-properties* elt #f)))
+    (if (not v)
+	(error:wrong-type-argument elt "XDOC element"
+				   'xdoc-element-properties))
+    v))
+
+(define (nearest-container elt)
+  (let ((containers (xdoc-element-containers elt)))
+    (if (not (pair? containers))
+	(error "Unable to find XDOC element container."))
+    (car containers)))
+
+(define (named-element id)
+  (or (hash-table/get *xdoc-id-map* id #f)
+      (error:bad-range-argument id 'named-element)))
+
+;;;; I/O memoization
+
+(define (memoize-xdoc-inputs)
+  (for-each (lambda (elt)
+	      (hash-table/put! *xdoc-inputs* elt (memoize-xdoc-input elt)))
+	    (hash-table/key-list *xdoc-inputs*)))
+
+(define (memoize-xdoc-input elt)
+  (let ((id (xdoc-db-id elt)))
+    (receive (value submitter) (db-previously-saved-input id)
+      (if submitter
+	  (cons value submitter)
+	  (receive (value* submitter) (xdoc-active-input-status elt)
+	    (let ((value (or value "")))
+	      (if (or submitter
+		      (and value* (not (string=? value* value))))
+		  (db-save-input! id (or value* value) submitter))
+	      (cons (or value* value) submitter)))))))
+
+(define (memoize-xdoc-outputs)
+  (for-each (lambda (elt)
+	      (receive (correctness submitter) (memoize-xdoc-output elt)
+		(hash-table/put! *xdoc-outputs* elt
+				 (cons correctness submitter))))
+	    (hash-table/key-list *xdoc-outputs*)))
+
+(define (memoize-xdoc-output elt)
+  (let ((id (xdoc-db-id elt)))
+    (receive (correctness submitter) (db-previously-saved-output id)
+      (if submitter
+	  (values correctness submitter)
+	  (receive (correctness* submitter) (xdoc-active-output-status elt)
+	    (let ((correctness (or correctness "unspecified")))
+	      (if (or submitter
+		      (not (string=? correctness* correctness)))
+		  (db-save-output! id
+				   correctness*
+				   submitter
+				   *xdoc-late?*)))
+	    (values correctness* submitter))))))
+
+(define (current-input-status elt)
+  (let ((p (%current-input-status elt)))
+    (values (car p) (cdr p))))
+
+(define (input-submitted? elt)
+  (and (cdr (%current-input-status elt)) #t))
+
+(define (%current-input-status elt)
+  (or (hash-table/get *xdoc-inputs* elt #f)
+      (error:wrong-type-argument elt
+				 "XDOC input element"
+				 'current-input-status)))
+
+(define (current-inputs-status sources)
+  (receive (value submitter) (current-input-status (car sources))
+    (let loop
+	((sources (cdr sources))
+	 (vals (list value))
+	 (submitter submitter))
+      (if (pair? sources)
+	  (receive (value submitter*) (current-input-status (car sources))
+	    (loop (cdr sources)
+		  (cons value vals)
+		  (and (eq? submitter* submitter) submitter)))
+	  (values (reverse! vals) submitter)))))
+
+(define (current-output-status elt)
+  (let ((p (%current-output-status elt)))
+    (values (car p) (cdr p))))
+
+(define (output-submitted? elt)
+  (and (cdr (%current-output-status elt)) #t))
+
+(define (%current-output-status elt)
+  (or (hash-table/get *xdoc-outputs* elt #f)
+      (error:wrong-type-argument elt
+				 "XDOC output element"
+				 'current-output-status)))
+
+;;;; HTML generator
+
+(define (generate-xdoc-html root)
+  (if (not (xd:xdoc? root))
+      (error "Top level element must be <xd:xdoc>:" root))
+  (html (xdoc-attributes root 'xmlns xhtml-iri)
+	"\n"
+	(head #f
+	      "\n  "
+	      (style-link "/styles/xdoc.css")
+	      (append-map (lambda (item)
+			    (if (xd:head? item)
+				(xml-element-contents item)
+				'()))
+			  (xml-element-contents root)))
+	"\n"
+	(body #f "\n" ((xdoc-html-generator root) root) "\n")
+	"\n"))
+
+(define (define-html-generator name handler)
+  (hash-table/put! html-generators name handler))
+
+(define (xdoc-html-generator item)
+  (hash-table/get html-generators (xdoc-element-name item) #f))
+
+(define html-generators
+  (make-xml-name-hash-table))
+
+(define (generate-container-items items extra-content?)
+  (generate-container-groups
+   (parse-container-groups items xd:answer?)
+   (let ((expand-xdoc
+	  (lambda (elt valid-content?)
+	    (if (not (valid-content? elt))
+		(error "Illegal content in this context:" elt))
+	    (let ((handler (xdoc-html-generator elt)))
+	      (if (not handler)
+		  (error "Unhandled element type:" (xml-element-name elt)))
+	      (handler elt)))))
+     (lambda (items)
+       (map (lambda (item)
+	      (cond ((xdoc-element? item)
+		     (expand-xdoc item
+		       (lambda (elt)
+			 (or (memq (xdoc-element-type elt)
+				   '(internal-container
+				     output
+				     content-selector
+				     action))
+			     (extra-content? elt)))))
+		    ((xml-element? item)
+		     (generate-xdoc-in-html item
+		       (lambda (elt)
+			 (expand-xdoc elt
+			   (lambda (elt)
+			     (memq (xdoc-element-type elt)
+				   '(output content-selector action)))))))
+		    (else item)))
+	    items)))
+   generate-answer-block))
+
+(define (generate-xdoc-in-html elt procedure)
+  (let loop ((elt elt))
+    (make-xml-element (xml-element-name elt)
+		      (xml-element-attributes elt)
+		      (flatten-xml-element-contents
+		       (map (lambda (item)
+			      (cond ((xdoc-element? item) (procedure item))
+				    ((xml-element? item) (loop item))
+				    (else item)))
+			    (xml-element-contents elt))))))
+
+(define (generate-container-groups groups generate-even generate-odd)
+  (let loop ((groups groups))
+    (if (pair? groups)
+	(cons (generate-even (car groups))
+	      (if (pair? (cdr groups))
+		  (cons (generate-odd (cadr groups))
+			(loop (cddr groups)))
+		  '()))
+	'())))
+
+(define (parse-container-groups items container?)
+  (letrec
+      ((collect-non-containers
+	(lambda (items group groups)
+	  (if (pair? items)
+	      (if (container? (car items))
+		  (collect-containers (cdr items)
+				      (list (car items))
+				      (cons (reverse! group) groups))
+		  (collect-non-containers (cdr items)
+					  (cons (car items) group)
+					  groups))
+	      (reverse! (cons (reverse! group) groups)))))
+       (collect-containers
+	(lambda (items group groups)
+	  (if (pair? items)
+	      (cond ((container? (car items))
+		     (collect-containers (cdr items)
+					 (cons (car items) group)
+					 groups))
+		    ((spacer? (car items))
+		     (skip-spacers (cdr items)
+				   (list (car items))
+				   group
+				   groups))
+		    (else
+		     (collect-non-containers (cdr items)
+					     (list (car items))
+					     (cons (reverse! group) groups))))
+	      (reverse! (cons (reverse! group) groups)))))
+       (skip-spacers
+	(lambda (items spacers group groups)
+	  (if (pair? items)
+	      (cond ((spacer? (car items))
+		     (skip-spacers (cdr items)
+				   (cons (car items) spacers)
+				   group
+				   groups))
+		    ((container? (car items))
+		     (collect-containers (cdr items)
+					 (cons (car items)
+					       (append! spacers group))
+					 groups))
+		    (else
+		     (collect-non-containers (cdr items)
+					     (cons (car items) spacers)
+					     (cons (reverse! group) groups))))
+	      (reverse!
+	       (cons* (reverse! spacers)
+		      (reverse! group)
+		      groups)))))
+       (spacer?
+	(lambda (item)
+	  (or (xml-whitespace-string? item)
+	      (xml-comment? item)))))
+    (collect-non-containers items '() '())))
+
+;;;; Containers
+
+(define-html-generator 'xdoc
+  (lambda (elt)
+    (int0-attribute 'problem-set elt #t)	;require attribute
+    (form (attributes
+	   'method "post"
+	   'action (or (find-attribute 'form-url elt #f) (http-request-url)))
+	  (generate-container-items (xml-element-contents elt)
+				    (lambda (elt)
+				      (or (xd:head? elt)
+					  (xd:due-date? elt)))))))
+
+(define-html-generator 'head
+  (lambda (elt)
+    elt
+    '()))
+
+(define-html-generator 'due-date
+  (lambda (elt)
+    (let ((dt (due-date->decoded-time elt)))
+      (p (merge-attributes (xdoc-due-date-attributes dt)
+			   (preserved-attributes elt))
+	 (xdoc-due-date-string dt)))))
+
+(define (due-date->decoded-time elt)
+  (make-decoded-time
+   0
+   (or (index0-attribute 'minute 60 elt #f) 0)
+   (index0-attribute 'hour 24 elt #t)
+   (index1-attribute 'day 31 elt #t)
+   (index1-attribute 'month 12 elt #t)
+   (numeric-attribute 'year
+		      (lambda (z)
+			(and (exact-integer? z)
+			     (>= z 1970)))
+		      elt
+		      #t)))
+
+(define-expander 'xdoc-due-date-attributes
+  (lambda (dt)
+    (attributes 'class
+		(string-append "xdoc-due-date "
+			       (if (decoded-time-in-past? dt)
+				   "xdoc-due-date-overdue"
+				   "xdoc-due-date-on-time")))))
+
+(define-expander 'xdoc-due-date-string
+  (lambda (dt)
+    (let ((hour (decoded-time/hour dt))
+	  (minute (decoded-time/minute dt)))
+      (string-append "Due: "
+		     (day-of-week/long-string (decoded-time/day-of-week dt))
+		     " "
+		     (month/short-string (decoded-time/month dt))
+		     ". "
+		     (number->string (decoded-time/day dt))
+		     " at "
+		     (number->string
+		      (cond ((> hour 12) (- hour 12))
+			    ((> hour 0) hour)
+			    (else 12)))
+		     (if (> minute 0)
+			 (string-append ":" (string-pad-left minute 2 #\0))
+			 "")
+		     " "
+		     (if (> hour 12) "PM" "AM")))))
+
+(define (due-date-in-past?)
+  (let ((elt (find-named-child 'due-date *xdoc-root* #f)))
+    (and elt
+	 (decoded-time-in-past? (due-date->decoded-time elt)))))
+
+(define (decoded-time-in-past? dt)
+  (< (decoded-time->universal-time dt) (get-universal-time)))
+
+(define-html-generator 'problem
+  (lambda (elt)
+    (receive (prefix number depth count) (xdoc-element-properties elt)
+      (let ((formatter
+	     (procedure-attribute 'number-format (nearest-container elt) #f))
+	    (body (generate-problem-body elt)))
+	(let ((class-attrs
+	       (lambda (part)
+		 (attributes 'class
+			     (let ((base (string-append "xdoc-problem-" part)))
+			       (string-append base "-" (number->string depth)
+					      " " base))))))
+	  (let ((label-attrs (class-attrs "label"))
+		(body-attrs (class-attrs "body")))
+	    (list (if (and (> count 1) (problem-separator? elt))
+		      (list (hr) "\n")
+		      '())
+		  (if (> depth 1)
+		      (case (problem-group-type (nearest-container elt))
+			((dl)
+			 (list (dt label-attrs
+				   (if formatter
+				       (formatter prefix number elt)
+				       (list number ":")))
+			       "\n"
+			       (dd body-attrs "\n" body)))
+			((ol)
+			 (li (append body-attrs (attributes 'value number))
+			     body))
+			((ul) (li body-attrs body))
+			(else (div body-attrs body)))
+		      (list (p label-attrs
+			       (if formatter
+				   (formatter prefix number elt)
+				   (list "Problem " prefix number)))
+			    "\n"
+			    (div body-attrs "\n" body))))))))))
+
+(define (generate-problem-body elt)
+  (let ((wrap
+	 (case (problem-group-type elt)
+	   ((dl) dl)
+	   ((ol) ol)
+	   ((ul) ul)
+	   (else div)))
+	(attrs (xdoc-attributes elt 'class "xdoc-problem-group"))
+	(generate-group
+	 (lambda (items)
+	   (generate-container-items items (lambda (elt) elt #f)))))
+    (generate-container-groups
+     (parse-container-groups (xml-element-contents elt) xd:problem?)
+     generate-group
+     (lambda (items)
+       (list "\n"
+	     (wrap attrs "\n" (generate-group items)))))))
+
+(define (problem-group-type elt)
+  (if (find-attribute 'number-format elt #f)
+      'dl
+      (let ((type (or (symbol-attribute 'number-type elt #f) 'ol)))
+	(if (not (memq type '(dl ol ul none)))
+	    (error "Illegal number-type attribute:" type))
+	type)))
+
+(define (problem-separator? elt)
+  (eq? (let ((elt (nearest-container elt)))
+	 (or (boolean-attribute 'problem-separator elt #f)
+	     (let ((local (xdoc-element-name elt)))
+	       (case local
+		 ((xdoc) 'true)
+		 ((problem) 'false)
+		 (else (error "Illegal <xd:problem> container:" local))))))
+       'true))
+
+(define (generate-answer-block elts)
+  (fluid-let ((*answer-block-appendixes* '()))
+    (let ((t
+	   (table (attributes 'class "xdoc-answer-block"
+			      'cellspacing "8")
+		  (append-map (lambda (elt)
+				(list "\n  "
+				      (tr (xdoc-attributes elt)
+					  (generate-answer-row elt)
+					  "\n  ")
+				      "\n"))
+			      elts))))
+      ;; Let forces order of evaluation.
+      (cons t (reverse! *answer-block-appendixes*)))))
+
+(define (append-to-answer-block . items)
+  (set! *answer-block-appendixes*
+	(append! *answer-block-appendixes* items))
+  unspecific)
+
+(define *answer-block-appendixes*)
+
+(define (generate-answer-row elt)
+  (append-map generate-answer-item
+	      (xml-element-contents elt)))
+
+(define (generate-answer-item elt)
+  (let* ((name (xdoc-element-name elt)))
+    (if (not (or (memq (xdoc-element-type elt)
+		       '(input output content-selector action))
+		 (xd:label? elt)))
+	(error "Unknown <xd:answer> content:" elt))
+    (let ((items
+	   (flatten-xml-element-contents ((xdoc-html-generator elt) elt))))
+      (if (null? items)
+	  '()
+	  (list "\n    "
+		(td (xdoc-attributes elt
+				     'class (symbol-append 'xdoc-answer- name))
+		    "\n      "
+		    items
+		    "\n    "))))))
+
+(define-html-generator 'label
+  (lambda (elt)
+    (xml-element-contents elt)))
+
+;;;; Inputs
+
+(define (define-xdoc-input local canonicalizer generator)
+  (hash-table/put! xdoc-input-canonicalizers local canonicalizer)
+  (define-html-generator local generator))
+
+(define (xdoc-active-input-status elt)
+  (receive (request submitter) (xdoc-active-element-request elt)
+    (values (canonicalize-xdoc-input-value
+	     elt
+	     (http-request-post-parameter (xdoc-db-id elt))
+	     request)
+	    (and (eq? request 'submit) submitter))))
+
+(define (xdoc-active-element-request elt)
+  (let ((bindings (http-request-post-parameter-bindings)))
+    (let per-elt ((elt elt) (containers (xdoc-element-containers elt)))
+      (let* ((id (xdoc-db-id elt))
+	     (suffix (string-append "-" (symbol-name id))))
+	(cond ((find-matching-item bindings
+		 (lambda (binding)
+		   (string-suffix? suffix (symbol-name (car binding)))))
+	       => (lambda (binding)
+		    (values (let ((name (symbol-name (car binding))))
+			      (substring->symbol
+			       name
+			       0
+			       (fix:- (string-length name)
+				      (string-length suffix))))
+			    id)))
+	      ((pair? containers)
+	       (per-elt (car containers) (cdr containers)))
+	      (else
+	       (values #f #f)))))))
+
+(define (canonicalize-xdoc-input-value elt value request)
+  (let ((local (xdoc-element-name elt)))
+    (if (eq? local 'checkbox)
+	(if (and (not value) request) "false" value)
+	(and value
+	     ((or (hash-table/get xdoc-input-canonicalizers local #f)
+		  (error:wrong-type-argument elt
+					     "XDOC input element"
+					     'canonicalize-xdoc-input-value))
+	      value)))))
+
+(define xdoc-input-canonicalizers
+  (make-eq-hash-table))
+
+(define-xdoc-input 'text
+  string-trim
+  (lambda (elt)
+    (receive (value submitter) (current-input-status elt)
+      (let ((width (int0-attribute 'width elt #t)))
+	(input 'class "xdoc-text-input"
+	       'type 'text
+	       'size width
+	       'maxlen width
+	       'name (xdoc-db-id elt)
+	       'value value
+	       'disabled (and submitter 'disabled))))))
+
+(define-xdoc-input 'menu
+  (lambda (value) (if (string=? value menu-dummy-string) "" value))
+  (lambda (elt)
+    (receive (value submitter) (current-input-status elt)
+      (let ((size (or (int1-attribute 'size elt #f) 1)))
+	(list
+	 (select (xdoc-attributes elt
+				  'name (xdoc-db-id elt)
+				  'size size
+				  'disabled (and submitter 'disabled))
+		 "\n"
+		 (option #f menu-dummy-string)
+		 (map (lambda (v)
+			(list "\n"
+			      (option (attributes 'selected (string=? v value))
+				      v)))
+		      (xd:menu-values elt))
+		 "\n")
+	 "\n")))))
+
+(define menu-dummy-string
+  "--select answer--")
+
+(define (xd:menu-values elt)
+  (map (lambda (elt)
+	 (if (not (xd:menuitem? elt))
+	     (error "Illegal <xd:menu> content:" elt))
+	 (string-trim (xml-element-text elt)))
+       (xml-element-contents elt)))
+
+(define-xdoc-input 'checkbox
+  #f ;; special, see canonicalize-xdoc-input-value
+  (lambda (elt)
+    (receive (value submitter) (current-input-status elt)
+      (input 'class "xdoc-checkbox-input"
+	     'type 'checkbox
+	     'name (xdoc-db-id elt)
+	     'value "true"
+	     'checked (string=? value "true")
+	     'disabled (and submitter 'disabled)))))
+
+(define-xdoc-input 'radio-buttons
+  identity-procedure
+  (lambda (elt)
+    (receive (value submitter) (current-input-status elt)
+      (let ((id (xdoc-db-id elt)))
+	(table
+	 (attributes 'class "xdoc-radio-buttons-input")
+	 (tr #f
+	     (map (lambda (item)
+		    (if (not (xd:radio-entry? item))
+			(error "Illegal <xd:radio-buttons> content:" item))
+		    (let ((value* (find-attribute 'value item #t)))
+		      (list
+		       (td #f
+			   (input 'type 'radio
+				  'name id
+				  'value value*
+				  'checked (string=? value* value)
+				  'disabled (and submitter 'disabled)))
+		       (th #f (xml-element-contents item)))))
+		  (xml-element-contents elt))))))))
+
+(define (xd:radio-button-values elt)
+  (map (lambda (elt)
+	 (if (not (xd:radio-entry? elt))
+	     (error "Illegal <xd:radio-buttons> content:" elt))
+	 (find-attribute 'value elt #t))
+       (xml-element-contents elt)))
+
+;;;; Outputs
+
+(define (define-unary-xdoc-output local checkable? expected-value procedure)
+  (hash-table/put! xdoc-output-definitions local
+    (vector checkable?
+	    expected-value
+	    (lambda (elt)
+	      (let ((source (unary-xdoc-output-source elt)))
+		(receive (value submitter) (current-input-status source)
+		  (values (if (string-null? value)
+			      "unspecified"
+			      (procedure elt value source))
+			  submitter))))))
+  (define-html-generator local (lambda (elt) elt '())))
+
+(define (unary-xdoc-output-source elt)
+  (or (idref-attribute 'source elt #f)
+      (find-child (nearest-container elt) #t xdoc-input?)))
+
+(define (define-n-ary-xdoc-output local checkable? expected-value procedure)
+  (hash-table/put! xdoc-output-definitions local
+    (vector checkable?
+	    expected-value
+	    (lambda (elt)
+	      (let ((sources
+		     (map named-element (ids-attribute 'sources elt #t))))
+		(if (not (pair? sources))
+		    (error
+		     "Multiple-input test needs at least one input."))
+		(receive (vals submitter) (current-inputs-status sources)
+		  (values (if (there-exists? vals string-null?)
+			      "unspecified"
+			      (procedure elt vals sources))
+			  submitter))))))
+  (define-html-generator local (lambda (elt) elt '())))
+
+(define (xdoc-output-checkable? elt)
+  (and (vector-ref (%xdoc-output-definition elt) 0)
+       (let ((b (boolean-attribute 'checkable elt #f)))
+	 (if b
+	     (eq? b 'true)
+	     #t))))
+
+(define (xdoc-output-expected-value elt)
+  ((vector-ref (%xdoc-output-definition elt) 1) elt))
+
+(define (xdoc-active-output-status elt)
+  (receive (correctness submitter)
+      ((vector-ref (%xdoc-output-definition elt) 2) elt)
+    (if (not (string? correctness))
+	(error "Illegal result from output procedure:" correctness))
+    (values correctness submitter)))
+
+(define (%xdoc-output-definition elt)
+  (or (hash-table/get xdoc-output-definitions (xdoc-element-name elt) #f)
+      (error:bad-range-argument elt 'xdoc-output-definition)))
+
+(define xdoc-output-definitions
+  (make-eq-hash-table))
+
+(define-unary-xdoc-output 'check-input #t
+  (lambda (elt)
+    (find-attribute 'expected elt #f))
+  (lambda (elt value source)
+    ((procedure-attribute 'name elt #t) elt value source)))
+
+(define-n-ary-xdoc-output 'check-inputs #t
+  (lambda (elt)
+    (find-attribute 'expected elt #f))
+  (lambda (elt vals sources)
+    ((procedure-attribute 'name elt #t) elt vals sources)))
+
+(define-unary-xdoc-output 'number #t
+  (lambda (elt)
+    (complex-attribute 'expected elt #t))
+  (lambda (elt value source)
+    source
+    (let ((expected (complex-attribute 'expected elt #t))
+	  (tolerance (or (complex-attribute 'tolerance elt #f) 0))
+	  (z (string->number value)))
+      (if z
+	  (if (close-enough? z expected tolerance)
+	      "correct"
+	      "incorrect")
+	  "malformed"))))
+
+(define close-enough?
+  (let ((machine-epsilon
+	 (let loop ((e 1.))
+	   (if (> (+ e 1) 1)
+	       (loop (/ e 2))
+	       (* 2 e)))))
+    (lambda (z expected tolerance)
+      (if (= tolerance 0)
+	  (= z expected)
+	  (<= (magnitude (- z expected))
+	      (/ (* (max tolerance machine-epsilon)
+		    (+ (magnitude z)
+		       (magnitude tolerance)
+		       2))
+		 2))))))
+
+(define-unary-xdoc-output 'boolean #f
+  (lambda (elt)
+    (boolean-attribute 'expected elt #t))
+  (lambda (elt value source)
+    source
+    (let ((expected (boolean-attribute 'expected elt #t)))
+      (if (or (string=? value "true") (string=? value "false"))
+	  (if (string=? value (symbol-name expected))
+	      "correct"
+	      "incorrect")
+	  "malformed"))))
+
+(let ((get-vals
+       (lambda (source)
+	 (cond ((xd:menu? source) (xd:menu-values source))
+	       ((xd:radio-buttons? source) (xd:radio-button-values source))
+	       (else (error "Illegal <xd:menuindex> source:" source)))))
+      (get-expected
+       (lambda (elt vals)
+	 (list-ref vals
+		   (- (index1-attribute 'expected (length vals) elt #t)
+		      1)))))
+  (define-unary-xdoc-output 'menuindex #f
+    (lambda (elt)
+      (get-expected elt (get-vals (unary-xdoc-output-source elt))))
+    (lambda (elt value source)
+      (let ((vals (get-vals source)))
+	(if (member value vals)
+	    (if (string=? value (get-expected elt vals))
+		"correct"
+		"incorrect")
+	    "malformed")))))
+
+;;;; Content selectors
+
+(define-html-generator 'explain
+  (lambda (elt)
+    (if (descendant-outputs-submitted? (content-selector-source elt))
+	(switched-content-selector elt "explanation")
+	'())))
+
+(define-html-generator 'hint
+  (lambda (elt)
+    (if (descendant-outputs-submitted? (content-selector-source elt))
+	'()
+	(switched-content-selector elt "hint"))))
+
+(define (switched-content-selector elt noun)
+  (let* ((type (xdoc-element-name elt))
+	 (name (symbol-append type '- (xdoc-db-id elt)))
+	 (value (db-get-persistent-value name #f)))
+    (if (if (eq? value 'shown)
+	    (not (http-request-post-parameter name))
+	    (http-request-post-parameter name))
+	(let ((text
+	       (list
+		"\n"
+		(blockquote
+		 (xdoc-attributes elt
+				  'class
+				  (string-append "xdoc-"
+						 (symbol-name type)
+						 "-blockquote"))
+		 (xml-element-contents elt))
+		"\n"))
+	      (button
+	       (input 'type 'submit
+		      'name name
+		      'value (string-append "Hide " noun))))
+	  (if (not (eq? value 'shown))
+	      (db-set-persistent-value! name 'shown))
+	  (if (xd:answer? (nearest-container elt))
+	      (begin
+		(append-to-answer-block text)
+		button)
+	      (list button text)))
+	(begin
+	  (if (not (eq? value 'hidden))
+	      (db-set-persistent-value! name 'hidden))
+	  (input 'type 'submit
+		 'name name
+		 'value (string-append "Show " noun))))))
+
+(define-html-generator 'expected-value
+  (lambda (elt)
+    (let ((source
+	   (let ((source (content-selector-source elt)))
+	     (let ((outputs (descendant-outputs source)))
+	       (if (not (and (pair? outputs) (null? (cdr outputs))))
+		   (error "Single source output required:" outputs))
+	       (car outputs)))))
+      (and (output-submitted? source)
+	   (div (xdoc-attributes elt)
+		(xdoc-output-expected-value source))))))
+
+(define-html-generator 'when
+  (lambda (elt)
+    (and ((let ((condition (symbol-attribute 'condition elt #t)))
+	    (or (hash-table/get when-conditions condition #f)
+		(error "Unknown <xd:when> condition:" condition)))
+	  (content-selector-source elt))
+	 (div (xdoc-attributes elt)
+	      (xml-element-contents elt)))))
+
+(define (define-when-condition name procedure)
+  (hash-table/put! when-conditions name procedure))
+
+(define when-conditions
+  (make-eq-hash-table))
+
+(define-when-condition 'submitted
+  (lambda (elt)
+    (descendant-outputs-submitted? elt)))
+
+(define-when-condition 'not-submitted
+  (lambda (elt)
+    (not (descendant-outputs-submitted? elt))))
+
+(define-html-generator 'case
+  (lambda (elt)
+    (let ((children (xml-element-contents elt)))
+      (let ((token
+	     (let ((source
+		    (let ((source (car children)))
+		      (if (xd:refer? source)
+			  (idref-attribute 'source source #t)
+			  source))))
+	       (if (not (xdoc-output? source))
+		   (error "First child of <xd:case> must be output:" source))
+	       (receive (correctness submitter) (current-output-status source)
+		 (if (or submitter (xdoc-output-checkable? source))
+		     correctness
+		     "not-checkable")))))
+	(let loop ((choices (cdr children)))
+	  (if (pair? choices)
+	      (let ((choice (car choices)))
+		(if (cond ((xd:choice? choice)
+			   (there-exists?
+			       (attribute-value->list
+				(find-attribute 'values choice #t))
+			     (lambda (token*)
+			       (string=? token* token))))
+			  ((xd:default? choice)
+			   (if (not (null? (cdr choices)))
+			       (error "<xd:default> must be last child:"
+				      choices))
+			   #t)
+			  (else
+			   (error "Illegal <xd:case> child:" choice)))
+		    (xml-element-contents choice)
+		    (loop (cdr choices))))
+	      '()))))))
+
+(define (content-selector-source elt)
+  (let ((source (idref-attribute 'source elt #f)))
+    (if source
+	(begin
+	  (if (not (or (xdoc-container? source) (xdoc-output? source)))
+	      (error "Source must be container or output:" source))
+	  source)
+	(nearest-container elt))))
+
+(define (descendant-outputs-submitted? elt)
+  (for-all? (descendant-outputs elt) output-submitted?))
+
+(define (descendant-outputs elt)
+  (matching-descendants-or-self elt xdoc-output?))
+
+;;;; Actions
+
+(define-html-generator 'check-action
+  (lambda (elt)
+    (submission-action elt 'check)))
+
+(define-html-generator 'submit-action
+  (lambda (elt)
+    (submission-action elt 'submit)))
+
+(define (submission-action elt prefix)
+  (let ((container
+	 (let ((container (idref-attribute 'scope elt #f)))
+	   (if container
+	       (begin
+		 (if (not (xdoc-container? container))
+		     (error "scope attribute must refer to container:"
+			    container))
+		 container)
+	       (nearest-container elt)))))
+    (let ((inputs (descendant-inputs container)))
+      (if (for-all? inputs input-submitted?)
+	  #f
+	  (input
+	   (xdoc-attributes
+	    elt
+	    'class "xdoc-submit-action"
+	    'type 'submit
+	    'name (symbol-append prefix '- (xdoc-db-id container))
+	    'value
+	    (string-append (string-capitalize (symbol-name prefix))
+			   " answer"
+			   (if (fix:= (length inputs) 1) "" "s"))))))))
+
+(define (descendant-inputs elt)
+  (matching-descendants-or-self elt xdoc-input?))
+
+;;;; Attribute accessors
+
+(define (find-attribute name elt error?)
+  (let ((attr (%find-attribute name (xml-element-attributes elt))))
+    (if attr
+	(xml-attribute-value attr)
+	(begin
+	  (if error?
+	      (error "Missing required XDOC attribute:" name elt))
+	  #f))))
+
+(define (%find-attribute name attrs)
+  (find-matching-item attrs
+    (lambda (attr)
+      (xml-name=? (xml-attribute-name attr) name))))
+
+(define (symbol-attribute name elt error?)
+  (let ((string (find-attribute name elt error?)))
+    (and string
+	 (string->symbol string))))
+
+(define (id-attribute name elt error?)
+  (let ((string (find-attribute name elt error?)))
+    (and string
+	 (make-xml-qname string))))
+
+(define (idref-attribute name elt error?)
+  (let ((id (id-attribute name elt error?)))
+    (and id
+	 (named-element id))))
+
+(define (ids-attribute name elt error?)
+  (let ((string (find-attribute name elt error?)))
+    (and string
+	 (map make-xml-qname (attribute-value->list string)))))
+
+(define (nmtokens-attribute name elt error?)
+  (let ((string (find-attribute name elt error?)))
+    (and string
+	 (map make-xml-nmtoken (attribute-value->list string)))))
+
+(define (attribute-value->list names)
+  (burst-string names char-set:whitespace #t))
+
+(define (boolean-attribute name elt error?)
+  (let ((value (symbol-attribute name elt error?)))
+    (if (and value (not (memq value '(true false))))
+	(error "Ill-formed boolean attribute:" value))
+    value))
+
+(define (numeric-attribute name predicate elt error?)
+  (let ((string (find-attribute name elt error?)))
+    (and string
+	 (let ((z (string->number string)))
+	   (if (not (and z (predicate z)))
+	       (error "Ill-formed number:" z))
+	   z))))
+
+(define (int0-attribute name elt error?)
+  (numeric-attribute name exact-nonnegative-integer? elt error?))
+
+(define (int1-attribute name elt error?)
+  (numeric-attribute name exact-positive-integer? elt error?))
+
+(define (complex-attribute name elt error?)
+  (numeric-attribute name complex? elt error?))
+
+(define (index0-attribute name limit elt error?)
+  (numeric-attribute name
+		     (lambda (z)
+		       (and (exact-nonnegative-integer? z)
+			    (< z limit)))
+		     elt
+		     error?))
+
+(define (index1-attribute name limit elt error?)
+  (numeric-attribute name
+		     (lambda (z)
+		       (and (exact-positive-integer? z)
+			    (<= z limit)))
+		     elt
+		     error?))
+
+(define (procedure-attribute name elt error?)
+  (let ((name (procedure-name-attribute name elt error?)))
+    (and name
+	 (environment-lookup *xdoc-environment* name))))
+
+(define (procedure-name-attribute name elt error?)
+  (let ((symbol (symbol-attribute name elt error?)))
+    (if (not (or (not symbol) (xdoc-procedure-name? symbol)))
+	(error "Malformed procedure attribute:" symbol))
+    symbol))
+
+(define (xdoc-procedure-name? symbol)
+  (re-string-match "[A-Za-z_][0-9A-Za-z_]*" (symbol-name symbol)))
+
+;;;; Merging of attributes
+
+(define (xdoc-attributes elt . keyword-list)
+  (merge-attributes (apply attributes keyword-list)
+		    (preserved-attributes elt)))
+
+(define (preserved-attributes elt)
+  (keep-matching-items (xml-element-attributes elt) preserved-attribute?))
+
+(define (merge-attributes attrs defaults)
+  (map* (delete-matching-items defaults
+	  (lambda (attr)
+	    (%find-attribute (xml-attribute-name attr) attrs)))
+	(lambda (attr)
+	  (let ((attr*
+		 (and (merged-attribute? attr)
+		      (%find-attribute (xml-attribute-name attr) defaults))))
+	    (if attr*
+		(merge-attribute attr attr*)
+		attr)))
+	attrs))
+
+(define (preserved-attribute? attr)
+  (let ((name (xml-attribute-name attr)))
+    (or (xml-name=? name 'class)
+	(xml-name=? name 'style)
+	(and (xml-name-prefix=? name 'xmlns)
+	     (not (string=? (xml-attribute-value attr)
+			    (xml-namespace-iri-string xdoc-iri)))))))
+
+(define (merged-attribute? attr)
+  (let ((name (xml-attribute-name attr)))
+    (xml-name=? name 'class)))
+
+(define (merge-attribute attr1 attr2)
+  (let ((name (xml-attribute-name attr1)))
+    (cond ((xml-name=? name 'class)
+	   (make-xml-attribute name
+			       (class-union (xml-attribute-value attr1)
+					    (xml-attribute-value attr2))))
+	  (else
+	   (error:bad-range-argument attr1 'MERGE-ATTRIBUTE)))))
+
+(define (class-union c1 c2)
+  (let ((classes
+	 (let ((c2 (attribute-value->list c2)))
+	   (let loop ((c1 (attribute-value->list c1)))
+	     (if (pair? c1)
+		 (if (member (car c1) c2)
+		     (loop (cdr c1))
+		     (cons (car c1) (loop (cdr c1))))
+		 c2)))))
+    (if (pair? classes)
+	(call-with-output-string
+	  (lambda (port)
+	    (write-string (car classes) port)
+	    (for-each (lambda (class)
+			(write-char #\space port)
+			(write-string class port))
+		      (cdr classes))))
+	"")))
+
+;;;; Element accessors
+
+(define (find-named-child local elt error?)
+  (find-child elt error?
+    (lambda (child)
+      (xdoc-element-name=? child local))))
+
+(define (find-child elt error? predicate)
+  (%find-result (%find-child elt predicate) error?))
+
+(define (%find-child elt predicate)
+  (find-matching-item (xml-element-contents elt)
+    (lambda (item)
+      (and (xml-element? item)
+	   (predicate item)))))
+
+(define (%find-result elt error?)
+  (if (and (not elt) error?)
+      (error "Unable to find matching element."))
+  elt)
+
+(define (xml-element-text elt)
+  (let loop ((items (xml-element-contents elt)) (text ""))
+    (if (pair? items)
+	(begin
+	  (if (not (string? (car items)))
+	      (error "Illegal text component:" (car items)))
+	  (loop (cdr items)
+		(string-append text (car items))))
+	text)))
+
+(define (find-named-descendant local elt error?)
+  (find-descendant elt error?
+    (lambda (elt)
+      (xdoc-element-name=? elt local))))
+
+(define (find-descendant elt error? predicate)
+  (%find-result (%find-descendant elt predicate) error?))
+
+(define (find-descendant-or-self elt error? predicate)
+  (%find-result (%find-descendant-or-self elt predicate) error?))
+
+(define (matching-descendants elt predicate)
+  (reverse! (%matching-descendants elt predicate '())))
+
+(define (matching-descendants-or-self elt predicate)
+  (reverse! (%matching-descendants-or-self elt predicate '())))
+
+(define (%find-descendant elt predicate)
+  (let loop ((items (xml-element-contents elt)))
+    (and (pair? items)
+	 (or (and (xml-element? (car items))
+		  (%find-descendant-or-self (car items) predicate))
+	     (loop (cdr items))))))
+
+(define (%find-descendant-or-self elt predicate)
+  (if (predicate elt)
+      elt
+      (%find-descendant elt predicate)))
+
+(define (%matching-descendants elt predicate matches)
+  (let loop ((items (xml-element-contents elt)) (matches matches))
+    (if (pair? items)
+	(loop (cdr items)
+	      (let ((item (car items)))
+		(if (xml-element? item)
+		    (%matching-descendants-or-self item predicate matches)
+		    matches)))
+	matches)))
+
+(define (%matching-descendants-or-self elt predicate matches)
+  (%matching-descendants elt
+			 predicate
+			 (if (predicate elt)
+			     (cons elt matches)
+			     matches)))
+
+;;;; XDOC element data types
+
+(define xdoc-iri
+  (make-xml-namespace-iri "http://mit.edu/2003/XDOC"))
+
+(define (xdoc-name? name)
+  (xml-name-iri=? name xdoc-iri))
+
+(define (xdoc-name=? name local)
+  (and (xdoc-name? name)
+       (xml-name-local=? name local)))
+
+(define (xdoc-element? item)
+  (and (xml-element? item)
+       (xdoc-name? (xml-element-name item))))
+
+(define (xdoc-element-name item)
+  (and (xml-element? item)
+       (let ((name (xml-element-name item)))
+	 (and (xdoc-name? name)
+	      (xml-name-local name)))))
+
+(define (xdoc-element-name=? item local)
+  (and (xml-element? item)
+       (xdoc-name=? (xml-element-name item) local)))
+
+(define (xdoc-content-type elt)
+  (let ((local (xdoc-element-name elt)))
+    (and local
+	 (or (hash-table/get xdoc-content-types local #f)
+	     (error "Unknown XDOC element name:" local)))))
+
+(define xdoc-content-types
+  (make-eq-hash-table))
+
+(define (xdoc-element-type elt)
+  (let ((local (xdoc-element-name elt)))
+    (and local
+	 (or (hash-table/get xdoc-element-types local #f)
+	     (error "Unknown XDOC element name:" local)))))
+
+(define xdoc-element-types
+  (make-eq-hash-table))
+
+(define (xdoc-container? elt)
+  (let ((type (xdoc-element-type elt)))
+    (or (eq? type 'top-level-container)
+	(eq? type 'internal-container))))
+
+(define (xdoc-internal-container? elt)
+  (eq? (xdoc-element-type elt) 'internal-container))
+
+(define (xdoc-input? elt)
+  (eq? (xdoc-element-type elt) 'input))
+
+(define (xdoc-output? elt)
+  (eq? (xdoc-element-type elt) 'output))
+
+(define (xdoc-content-selector? elt)
+  (eq? (xdoc-element-type elt) 'content-selector))
+
+(define (xdoc-action? elt)
+  (eq? (xdoc-element-type elt) 'action))
+
+(let ((define-element
+	(lambda (local content-type elt-type)
+	  (let ((qname (symbol-append 'xd: local)))
+	    (define-expander qname
+	      ((if (eq? content-type 'empty)
+		   empty-element-constructor
+		   standard-element-constructor)
+	       qname xdoc-iri))
+	    (define-expander (symbol-append qname '?)
+	      (let ((name (make-xml-name qname xdoc-iri)))
+		(lambda (object)
+		  (and (xml-element? object)
+		       (xml-name=? (xml-element-name object) name))))))
+	  (hash-table/put! xdoc-content-types local content-type)
+	  (hash-table/put! xdoc-element-types local elt-type))))
+  (define-element 'xdoc 'mixed 'top-level-container)
+  (define-element 'head 'mixed 'internal)
+  (define-element 'due-date 'empty 'internal)
+  (define-element 'problem 'mixed 'internal-container)
+  (define-element 'answer 'element 'internal-container)
+  (define-element 'label 'mixed 'internal)
+
+  (define-element 'text 'empty 'input)
+  (define-element 'menu 'element 'input)
+  (define-element 'menuitem 'text 'internal)
+  (define-element 'checkbox 'empty 'input)
+  (define-element 'radio-buttons 'element 'input)
+  (define-element 'radio-entry 'mixed 'internal)
+
+  (define-element 'check-input 'empty 'output)
+  (define-element 'check-inputs 'empty 'output)
+  (define-element 'number 'empty 'output)
+  (define-element 'boolean 'empty 'output)
+  (define-element 'menuindex 'empty 'output)
+
+  (define-element 'explain 'mixed 'content-selector)
+  (define-element 'hint 'mixed 'content-selector)
+  (define-element 'expected-value 'empty 'content-selector)
+  (define-element 'when 'mixed 'content-selector)
+  (define-element 'case 'element 'content-selector)
+  (define-element 'refer 'empty 'internal)
+  (define-element 'choice 'mixed 'internal)
+  (define-element 'default 'mixed 'internal)
+
+  (define-element 'check-action 'empty 'action)
+  (define-element 'submit-action 'empty 'action))
+
+(define-expander 'xd:true-false
+  (lambda keyword-list
+    (xd:radio-buttons (apply attributes keyword-list)
+		      (xd:radio-entry (attributes 'value 'true) "True")
+		      (xd:radio-entry (attributes 'value 'false) "False"))))
+
+(define-expander 'xd:true-false?
+  (lambda (object)
+    (and (xd:radio-buttons? object)
+	 (let ((entries (xml-element-contents object)))
+	   (and (fix:= (length entries) 2)
+		(let ((v1 (find-attribute 'value (car entries) #t))
+		      (v2 (find-attribute 'value (cadr entries) #t)))
+		  (or (and (string=? v1 "true") (string=? v2 "false"))
+		      (and (string=? v1 "false") (string=? v2 "true")))))))))
\ No newline at end of file
diff --git a/v7/src/ssp/xhtml-expander.scm b/v7/src/ssp/xhtml-expander.scm
new file mode 100644
index 000000000..4fd8a0013
--- /dev/null
+++ b/v7/src/ssp/xhtml-expander.scm
@@ -0,0 +1,154 @@
+#| -*-Scheme-*-
+
+$Id: xhtml-expander.scm,v 1.1 2003/12/29 05:24:59 uid67408 Exp $
+
+Copyright 2002,2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XHTML+Scheme expander
+
+(declare (usual-integrations))
+(load-option 'xml)
+
+(define default-expander-directory
+  (merge-pathnames "*.xml"
+		   (directory-pathname (current-load-pathname))))
+
+(define (expand-xhtml-directory #!optional directory)
+  (for-each expand-xhtml-file
+	    (directory-read (if (default-object? directory)
+				default-expander-directory
+				directory))))
+
+(define (expand-xhtml-file input #!optional output)
+  (let ((document
+	 (read/expand-xml-file input
+			       (make-expansion-environment input))))
+    (let ((root (xml-document-root document)))
+      (set-xml-element-contents!
+       root
+       (cons* "\n"
+	      (make-xml-comment
+	       (string-append
+		" This document was automatically generated from \""
+		(file-namestring input)
+		"\"\n     on "
+		(universal-time->local-time-string (get-universal-time))
+		". "))
+	      (xml-element-contents root))))
+    (let ((output
+	   (if (default-object? output)
+	       (pathname-new-type input "html")
+	       output)))
+      ((if (output-port? output) write-xml write-xml-file)
+       document output 'INDENT-DTD? #t))))
+
+(define (read/expand-xml-file pathname environment)
+  (with-working-directory-pathname (directory-pathname pathname)
+    (lambda ()
+      (fluid-let ((*sabbr-table* (make-eq-hash-table)))
+	(read-xml-file pathname
+		       `((scheme ,(pi-expander environment))
+			 (svar ,svar-expander)
+			 (sabbr ,sabbr-expander)))))))
+
+(define (make-expansion-environment pathname)
+  (let ((pathname (merge-pathnames pathname))
+	(environment (extend-top-level-environment expander-environment)))
+    (environment-define environment 'document-pathname pathname)
+    (environment-define environment 'emit emit)
+    (environment-define environment 'load
+			(let ((directory (directory-pathname pathname)))
+			  (lambda (pathname)
+			    (load (merge-pathnames pathname directory)
+				  environment))))
+    (environment-define environment 'define-sabbr define-sabbr)
+    (environment-define environment 'get-sabbr get-sabbr)
+    environment))
+
+(define ((pi-expander environment) text)
+  (fluid-let ((*outputs* (cons '() '()))
+	      (load/suppress-loading-message? #t))
+    (let ((port (open-input-string text)))
+      (let loop ()
+	(let ((expression (read port)))
+	  (if (not (eof-object? expression))
+	      (begin
+		(expander-eval expression environment)
+		(loop))))))
+    (car *outputs*)))
+
+(define expander-eval eval)
+(define expander-environment)
+(define server-environment (the-environment))
+(define expander-directory (directory-pathname (current-load-pathname)))
+
+(define (initialize-expander-environment)
+  (set! expander-environment
+	(let ((e (make-top-level-environment)))
+	  (load (merge-pathnames "xhtml" expander-directory) e)
+	  e))
+  (for-each (lambda (name)
+	      (link-variables server-environment name
+			      expander-environment name))
+	    (environment-bound-names expander-environment)))
+
+(define (define-expander name value)
+  (environment-define expander-environment name value)
+  (link-variables server-environment name
+		  expander-environment name))
+
+(initialize-expander-environment)
+
+(define (svar-expander text)
+  (list (make-xml-element 'code '() (list (string-trim text)))))
+
+(define (sabbr-expander text)
+  (get-sabbr (intern (string-trim text))))
+
+(define (define-sabbr name expansion)
+  (hash-table/put! *sabbr-table* name (flatten expansion)))
+
+(define (get-sabbr name)
+  (let ((expansion (hash-table/get *sabbr-table* name 'NO-EXPANSION)))
+    (if (eq? expansion 'NO-EXPANSION)
+	(error "Invalid sabbr name:" name))
+    expansion))
+
+(define (emit . content)
+  (emit* content *outputs*))
+
+(define (emit* content q)
+  (let ((tail (flatten content)))
+    (if (pair? tail)
+	(begin
+	  (if (pair? (cdr q))
+	      (set-cdr! (cdr q) tail)
+	      (set-car! q tail))
+	  (set-cdr! q (last-pair tail))))))
+
+(define (flatten items)
+  (cond ((pair? items) (append-map! flatten items))
+	((null? items) '())
+	(else (list items))))
+
+(define *outputs*)
+(define *sabbr-table*)
\ No newline at end of file
diff --git a/v7/src/ssp/xhtml.scm b/v7/src/ssp/xhtml.scm
new file mode 100644
index 000000000..614087acb
--- /dev/null
+++ b/v7/src/ssp/xhtml.scm
@@ -0,0 +1,246 @@
+#| -*-Scheme-*-
+
+$Id: xhtml.scm,v 1.1 2003/12/29 05:24:55 uid67408 Exp $
+
+Copyright 2002,2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XHTML support
+
+(declare (usual-integrations))
+
+(define xhtml-external-dtd
+  (make-xml-external-id "-//W3C//DTD XHTML 1.0 Strict//EN"
+			"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"))
+
+(define xhtml-dtd
+  (make-xml-dtd 'html xhtml-external-dtd '()))
+
+(define xhtml-iri
+  (make-xml-namespace-iri "http://www.w3.org/1999/xhtml"))
+
+(define-syntax define-standard-element
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER) (cdr form))
+	 (let ((name (cadr form)))
+	   `(DEFINE ,name
+	      (STANDARD-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
+	 (ill-formed-syntax form)))))
+
+(define (standard-element-constructor simple iri)
+  (let ((name (make-xml-name simple iri)))
+    (lambda (attrs . items)
+      (make-xml-element name
+			(if (not attrs)
+			    '()
+			    attrs)
+			(flatten-xml-element-contents items)))))
+
+(define (flatten-xml-element-contents item)
+  (letrec
+      ((scan-item
+	(lambda (item tail)
+	  (cond ((xml-content-item? item) (cons item tail))
+		((pair? item) (scan-list item tail))
+		((or (not item) (null? item)) tail)
+		(else (cons (convert-xhtml-string-value item) tail)))))
+       (scan-list
+	(lambda (items tail)
+	  (if (pair? items)
+	      (scan-item (car items)
+			 (scan-list (cdr items) tail))
+	      (begin
+		(if (not (null? items))
+		    (error:wrong-type-datum items "list"))
+		tail)))))
+    (scan-item item '())))
+
+(define (convert-xhtml-string-value value)
+  (cond ((symbol? value) (symbol-name value))
+	((number? value) (number->string value))
+	((xml-namespace-iri? value) (xml-namespace-iri-string value))
+	(else (error:wrong-type-datum value "string value"))))
+
+(define-standard-element a)
+(define-standard-element abbr)
+(define-standard-element acronym)
+(define-standard-element address)
+(define-standard-element b)
+(define-standard-element big)
+(define-standard-element blockquote)
+(define-standard-element body)
+(define-standard-element button)
+(define-standard-element caption)
+(define-standard-element cite)
+(define-standard-element code)
+(define-standard-element col)
+(define-standard-element colgroup)
+(define-standard-element dd)
+(define-standard-element defn)
+(define-standard-element del)
+(define-standard-element dir)
+(define-standard-element div)
+(define-standard-element dl)
+(define-standard-element dt)
+(define-standard-element em)
+(define-standard-element form)
+(define-standard-element h1)
+(define-standard-element h2)
+(define-standard-element h3)
+(define-standard-element h4)
+(define-standard-element h5)
+(define-standard-element head)
+(define-standard-element html)
+(define-standard-element i)
+(define-standard-element ins)
+(define-standard-element kbd)
+(define-standard-element li)
+(define-standard-element listing)
+(define-standard-element menu)
+(define-standard-element ol)
+(define-standard-element optgroup)
+(define-standard-element option)
+(define-standard-element p)
+(define-standard-element pre)
+(define-standard-element q)
+(define-standard-element s)
+(define-standard-element samp)
+(define-standard-element script)
+(define-standard-element select)
+(define-standard-element small)
+(define-standard-element span)
+(define-standard-element strike)
+(define-standard-element strong)
+(define-standard-element sub)
+(define-standard-element sup)
+(define-standard-element table)
+(define-standard-element tbody)
+(define-standard-element td)
+(define-standard-element textarea)
+(define-standard-element tfoot)
+(define-standard-element th)
+(define-standard-element thead)
+(define-standard-element title)
+(define-standard-element tr)
+(define-standard-element tt)
+(define-standard-element u)
+(define-standard-element ul)
+(define-standard-element var)
+
+(define-syntax define-empty-element
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER) (cdr form))
+	 (let ((name (cadr form)))
+	   `(DEFINE ,name
+	      (EMPTY-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
+	 (ill-formed-syntax form)))))
+
+(define (empty-element-constructor simple iri)
+  (let ((name (make-xml-name simple iri)))
+    (lambda keyword-list
+      (make-xml-element name
+			(if (and (pair? keyword-list)
+				 (list-of-type? (car keyword-list)
+				   xml-attribute?)
+				 (null? (cdr keyword-list)))
+			    (car keyword-list)
+			    (apply attributes keyword-list))
+			'()))))
+
+(define-empty-element br)
+(define-empty-element hr)
+(define-empty-element img)
+(define-empty-element input)
+(define-empty-element link)
+(define-empty-element meta)
+
+(define (attributes . keyword-list)
+  (let loop ((bindings keyword-list))
+    (if (and (pair? bindings)
+	     (xml-name? (car bindings))
+	     (pair? (cdr bindings)))
+	(let ((value (cadr bindings))
+	      (tail (loop (cddr bindings))))
+	  (if value
+	      (cons (make-xml-attribute
+		     (car bindings)
+		     (cond ((eq? value #t) (symbol-name (car bindings)))
+			   ((xml-char-data? value) value)
+			   (else (convert-xhtml-string-value value))))
+		    tail)
+	      tail))
+	(begin
+	  (if (not (null? bindings))
+	      (error:wrong-type-argument keyword-list
+					 "keyword list"
+					 'ATTRIBUTES))
+	  '()))))
+
+(define (href iri . contents)
+  (apply a
+	 (attributes 'href iri)
+	 contents))
+
+(define (id-def tag . contents)
+  (apply a
+	 (attributes 'id tag
+		     'name tag)
+	 contents))
+
+(define (id-ref tag . contents)
+  (apply href (string-append "#" tag) contents))
+
+(define (rel-link rel iri)
+  (link 'rel rel
+	'href iri))
+
+(define (style-link iri)
+  (link 'rel "stylesheet"
+	'href iri
+	'type "text/css"))
+
+(define (http-equiv name value)
+  (meta 'http-equiv name
+	'content value))
+
+(define (style . keyword-list)
+  (let loop ((bindings keyword-list))
+    (if (and (pair? bindings)
+	     (symbol? (car bindings))
+	     (pair? (cdr bindings))
+	     (string? (cadr bindings)))
+	(string-append (symbol-name (car bindings))
+		       ": "
+		       (cadr bindings)
+		       (if (pair? (cddr bindings))
+			   (string-append "; " (loop (cddr bindings)))
+			   ";"))
+	(begin
+	  (if (not (null? bindings))
+	      (error:wrong-type-argument keyword-list "keyword list" 'STYLE))
+	  ""))))
+
+(define (comment . strings)
+  (make-xml-comment (string-append " " (apply string-append strings) " ")))
\ No newline at end of file
diff --git a/v7/src/ssp/xmlrpc.scm b/v7/src/ssp/xmlrpc.scm
new file mode 100644
index 000000000..ad42f496f
--- /dev/null
+++ b/v7/src/ssp/xmlrpc.scm
@@ -0,0 +1,302 @@
+#| -*-Scheme-*-
+
+$Id: xmlrpc.scm,v 1.1 2003/12/29 05:25:02 uid67408 Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; MIT/GNU Scheme XML-RPC implementation (requires mod-lisp)
+
+(declare (usual-integrations))
+
+(define-subtree-handler "xmlrpc" 'text/xml
+  (lambda (pathname port)
+    (if (eq? (http-request-method) 'post)
+	(let ((entity (http-request-entity)))
+	  (if entity
+	      (let ((document (read-xml (open-input-string entity))))
+		(if document
+		    (write-xml (xml-rpc:process-request document pathname)
+			       port)
+		    (http-status-response 400 "Ill-formed XML entity")))
+	      (http-status-response 400 "Missing XML entity")))
+	(begin
+	  (http-status-response 405 "XML-RPC requires POST method.")
+	  (http-response-header 'allow "POST")))))
+
+(define (xml-rpc:process-request document pathname)
+  (let ((result
+	 (ignore-errors
+	  (lambda ()
+	    (receive (name params) (xml-rpc:parse-request document)
+	      (let ((handler (xml-rpc:get-method-handler pathname name)))
+		(if (not handler)
+		    (error "Unknown method name:" name))
+		(xml-rpc:response
+		 (with-working-directory-pathname (directory-pathname pathname)
+		   (lambda ()
+		     (apply handler params))))))))))
+    (if (condition? result)
+	(xml-rpc:fault 1 (condition/report-string result))
+	result)))
+
+(define (xml-rpc:get-method-handler pathname name)
+  (let ((methods (make-string-hash-table)))
+    (let ((environment (make-expansion-environment pathname)))
+      (environment-define environment 'define-xmlrpc-method
+	(lambda (name handler)
+	  (hash-table/put! methods name handler)))
+      (fluid-let ((load/suppress-loading-message? #t))
+	(load pathname environment)))
+    (hash-table/get methods name #f)))
+
+(define (xml-rpc:response object)
+  (rpc-elt:method-response
+   (rpc-elt:params
+    (rpc-elt:param
+     (rpc-elt:value (xml-rpc:encode-object object))))))
+
+(define (xml-rpc:fault code message . irritants)
+  (let ((message
+	 (call-with-output-string
+	  (lambda (port)
+	    (format-error-message message irritants port)))))
+    (rpc-elt:method-response
+     (rpc-elt:fault
+      (rpc-elt:value
+       (rpc-elt:struct
+	(rpc-elt:member (rpc-elt:name "faultCode")
+			(rpc-elt:value (rpc-elt:int (number->string code))))
+	(rpc-elt:member (rpc-elt:name "faultString")
+			(rpc-elt:value (rpc-elt:string message)))))))))
+
+(define (xml-rpc:parse-request document)
+  (let ((elt (xml-document-root document))
+	(lose
+	 (lambda ()
+	   (error:bad-range-argument (xml->string document) #f))))
+    (if (not (xml-name=? (xml-element-name elt) '|methodCall|))
+	(lose))
+    (values (let ((s
+		   (xml-rpc:content-string
+		    (xml-rpc:named-child '|methodName| elt lose)
+		    lose)))
+	      (if (not (re-string-match "\\`[a-zA-Z0-9_.:/]+\\'" s))
+		  (lose))
+	      s)
+	    (let ((elt (xml-rpc:named-child 'params elt #f)))
+	      (if elt
+		  (xml-rpc:parse-params elt lose)
+		  '())))))
+
+(define (xml-rpc:parse-params elt lose)
+  (map (lambda (elt)
+	 (xml-rpc:decode-value (xml-rpc:single-named-child 'value elt lose)
+			       lose))
+       (xml-rpc:named-children 'param elt lose)))
+
+(define (xml-rpc:named-children name elt lose)
+  (let loop ((items (xml-element-contents elt)))
+    (if (pair? items)
+	(let ((item (car items))
+	      (rest (loop (cdr items))))
+	  (if (xml-element? item)
+	      (begin
+		(if (not (xml-name=? (xml-element-name item) name))
+		    (lose))
+		(cons item rest))
+	      (begin
+		(if (not (or (xml-whitespace-string? item)
+			     (xml-comment? item)))
+		    (lose))
+		rest)))
+	'())))
+
+(define (xml-rpc:children elt lose)
+  (let loop ((items (xml-element-contents elt)))
+    (if (pair? items)
+	(let ((item (car items))
+	      (rest (loop (cdr items))))
+	  (if (xml-element? item)
+	      (cons item rest)
+	      (begin
+		(if (not (or (xml-whitespace-string? item)
+			     (xml-comment? item)))
+		    (lose))
+		rest)))
+	'())))
+
+(define (xml-rpc:named-child name elt lose)
+  (or (find-matching-item (xml-element-contents elt)
+	(lambda (item)
+	  (and (xml-element? item)
+	       (xml-name=? (xml-element-name item) name))))
+      (and lose (lose))))
+
+(define (xml-rpc:single-child elt lose)
+  (let ((children (xml-rpc:children elt lose)))
+    (if (not (and (pair? children)
+		  (null? (cdr children))))
+	(lose))
+    (car children)))
+
+(define (xml-rpc:single-named-child name elt lose)
+  (let ((child (xml-rpc:single-child elt lose)))
+    (if (not (xml-name=? (xml-element-name child) name))
+	(lose))
+    child))
+
+(define (xml-rpc:decode-object elt lose)
+  (case (xml-element-name elt)
+    ((boolean)
+     (let ((s (xml-rpc:content-string elt lose)))
+       (cond ((string=? s "0") #f)
+	     ((string=? s "1") #t)
+	     (else (lose)))))
+    ((|dateTime.iso8601|)
+     (safe-call lose
+		iso8601-string->decoded-time
+		(xml-rpc:content-string elt lose)))
+    ((double)
+     (let ((x (string->number (xml-rpc:content-string elt lose))))
+       (if (not (and x (flo:flonum? x)))
+	   (lose))
+       x))
+    ((i4 int)
+     (let ((n (string->number (xml-rpc:content-string elt lose))))
+       (if (not (and n
+		     (exact-integer? n)
+		     (<= #x-80000000 n #x7fffffff)))
+	   (lose))
+       n))
+    ((string)
+     (xml-rpc:content-string elt lose))
+    ((base64)
+     (safe-call lose
+		(lambda (string)
+		  (call-with-output-string
+		    (lambda (port)
+		      (call-with-decode-base64-output-port port #f
+			(lambda (port)
+			  (write-string string port))))))
+		(xml-rpc:content-string elt lose)))
+    ((array)
+     (map (lambda (elt) (xml-rpc:decode-value elt lose))
+	  (xml-rpc:named-children 'value
+				  (xml-rpc:single-named-child 'data elt lose)
+				  lose)))
+    ((struct)
+     (map (lambda (elt)
+	    (cons (string->symbol (xml-rpc:named-child 'name elt lose))
+		  (xml-rpc:decode-value (xml-rpc:named-child 'value elt lose)
+					lose)))
+	  (xml-rpc:named-children 'member elt lose)))
+    (else (lose))))
+
+(define (xml-rpc:content-string elt lose)
+  (let ((items (xml-element-contents elt)))
+    (if (not (and (pair? items)
+		  (string? (car items))
+		  (null? (cdr items))))
+	(lose))
+    (car items)))
+
+(define (safe-call lose procedure . arguments)
+  (let ((value (ignore-errors (lambda () (apply procedure arguments)))))
+    (if (condition? value)
+	(lose)
+	value)))
+
+(define (xml-rpc:decode-value elt lose)
+  (let ((items (xml-element-contents elt)))
+    (if (and (pair? items)
+	     (string? (car items))
+	     (null? (cdr items)))
+	(car items)
+	(xml-rpc:decode-object (xml-rpc:single-child elt lose) lose))))
+
+(define (xml-rpc:encode-object object)
+  (cond ((and (exact-integer? object)
+	      (<= #x-80000000 object #x7fffffff))
+	 (rpc-elt:int (number->string object)))
+	((flo:flonum? object)
+	 ;; Probably not right -- formatting issues
+	 (rpc-elt:double (number->string object)))
+	((boolean? object)
+	 (rpc-elt:boolean? (if object "1" "0")))
+	((string? object)
+	 (if (utf8-string-valid? object)
+	     (rpc-elt:string object)
+	     (call-with-output-string
+	       (lambda (port)
+		 (let ((context (encode-base64:initialize port #f)))
+		   (encode-base64:update context
+					 object
+					 0
+					 (string-length object))
+		   (encode-base64:finalize context))))))
+	((decoded-time? object)
+	 (rpc-elt:date-time (decoded-time->iso8601-string object)))
+	((and (pair? object)
+	      (list-of-type? object
+		(lambda (item)
+		  (and (pair? item)
+		       (symbol? (car item))))))
+	 (rpc-elt:struct
+	  (map (lambda (item)
+		 (rpc-elt:member (rpc-elt:name (symbol->string (car item)))
+				 (xml-rpc:encode-value (cdr item))))
+	       (cdr object))))
+	((list? object)
+	 (rpc-elt:array (rpc-elt:data (map xml-rpc:encode-value object))))
+	(else
+	 (error:wrong-type-argument object
+				    "an XML-RPC object"
+				    'xml-rpc:encode-object))))
+
+(define (xml-rpc:encode-value v)
+  (rpc-elt:value (xml-rpc:encode-object v)))
+
+(define (rpc-elt name)
+  (let ((make-elt
+	 (standard-element-constructor name (null-xml-namespace-iri))))
+    (lambda contents
+      (apply make-elt #f contents))))
+
+(define rpc-elt:array (rpc-elt 'array))
+(define rpc-elt:base64 (rpc-elt 'base64))
+(define rpc-elt:boolean (rpc-elt 'boolean))
+(define rpc-elt:data (rpc-elt 'data))
+(define rpc-elt:date-time (rpc-elt '|dateTime.iso8601|))
+(define rpc-elt:double (rpc-elt 'double))
+(define rpc-elt:fault (rpc-elt 'fault))
+(define rpc-elt:i4 (rpc-elt 'i4))
+(define rpc-elt:int (rpc-elt 'int))
+(define rpc-elt:member (rpc-elt 'member))
+(define rpc-elt:method-call (rpc-elt '|methodCall|))
+(define rpc-elt:method-name (rpc-elt '|methodName|))
+(define rpc-elt:method-response (rpc-elt '|methodResponse|))
+(define rpc-elt:name (rpc-elt 'name))
+(define rpc-elt:param (rpc-elt 'param))
+(define rpc-elt:params (rpc-elt 'params))
+(define rpc-elt:string (rpc-elt 'string))
+(define rpc-elt:struct (rpc-elt 'struct))
+(define rpc-elt:value (rpc-elt 'value))
\ No newline at end of file
-- 
2.25.1