From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:28 -0800
Subject: Import Upstream version 2d2

---
 htmlform.scm | 1128 +++++++++++++++++++---------------------------------------
 1 file changed, 364 insertions(+), 764 deletions(-)

(limited to 'htmlform.scm')

diff --git a/htmlform.scm b/htmlform.scm
index c7ce1dc..935e006 100644
--- a/htmlform.scm
+++ b/htmlform.scm
@@ -1,9 +1,9 @@
-;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*-
-; Copyright 1997, 1998 Aubrey Jaffer
+;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*-
+; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
 ;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
 ;
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
@@ -18,31 +18,20 @@
 ;each case.
 
 (require 'sort)
-(require 'scanf)
 (require 'printf)
-(require 'line-i/o)
 (require 'parameters)
-(require 'fluid-let)
-(require 'dynamic-wind)
-(require 'pretty-print)
 (require 'object->string)
-(require 'string-case)
-(require 'string-port)
 (require 'string-search)
 (require 'database-utilities)
 (require 'common-list-functions)
 
 ;;;;@code{(require 'html-form)}
-
-;;@body Procedure names starting with @samp{html:} send their output
-;;to the port @0.  @0 is initially the current output port.
-(define *html:output-port* (current-output-port))
-
-(define (html:printf . args) (apply fprintf *html:output-port* args))
+;;@ftindex html-form
+(define html:blank (string->symbol ""))
 
 ;;@body Returns a string with character substitutions appropriate to
 ;;send @1 as an @dfn{attribute-value}.
-(define (make-atval txt)		; attribute-value
+(define (html:atval txt)		; attribute-value
   (if (symbol? txt) (set! txt (symbol->string txt)))
   (if (number? txt)
       (number->string txt)
@@ -54,256 +43,164 @@
 
 ;;@body Returns a string with character substitutions appropriate to
 ;;send @1 as an @dfn{plain-text}.
-(define (make-plain txt)		; plain-text `Data Characters'
-  (if (symbol? txt) (set! txt (symbol->string txt)))
-  (if (number? txt)
-      (number->string txt)
-      (string-subst (if (string? txt) txt (object->string txt))
-		    "&" "&amp;"
-		    "<" "&lt;"
-		    ">" "&gt;")))
+(define (html:plain txt)		; plain-text `Data Characters'
+  (cond ((eq? html:blank txt) "&nbsp;")
+	(else
+	 (if (symbol? txt) (set! txt (symbol->string txt)))
+	 (if (number? txt)
+	     (number->string txt)
+	     (string-subst (if (string? txt) txt (object->string txt))
+			   "&" "&amp;"
+			   "<" "&lt;"
+			   ">" "&gt;")))))
+
+;;@body Returns a tag of meta-information suitable for passing as the
+;;third argument to @code{html:head}.  The tag produced is @samp{<META
+;;NAME="@1" CONTENT="@2">}.  The string or symbol @1 can be
+;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description},
+;;@samp{date}, @samp{robots}, @dots{}.
+(define (html:meta name content)
+  (sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content)))
+
+;;@body Returns a tag of HTTP information suitable for passing as the
+;;third argument to @code{html:head}.  The tag produced is @samp{<META
+;;HTTP-EQUIV="@1" CONTENT="@2">}.  The string or symbol @1 can be
+;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type},
+;;@samp{Refresh}, @dots{}.
+(define (html:http-equiv name content)
+  (sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">"
+	   name (html:atval content)))
+
+;;@args delay uri
+;;@args delay
+;;
+;;Returns a tag suitable for passing as the third argument to
+;;@code{html:head}.  If @2 argument is supplied, then @1 seconds after
+;;displaying the page with this tag, Netscape or IE browsers will fetch
+;;and display @2.  Otherwise, @1 seconds after displaying the page with
+;;this tag, Netscape or IE browsers will fetch and redisplay this page.
+(define (html:meta-refresh delay . uri)
+  (if (null? uri)
+      (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay)
+      (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">"
+	       delay (car uri))))
 
 ;;@args title backlink tags ...
 ;;@args title backlink
 ;;@args title
 ;;
-;;Outputs headers for an HTML page named @1.  If string arguments @2
-;;... are supplied they are printed verbatim within the @t{<HEAD>}
-;;section.
-(define (html:start-page title . args)
+;;Returns header string for an HTML page named @1.  If @2 is a string,
+;;it is used verbatim between the @samp{H1} tags; otherwise @1 is
+;;used.  If string arguments @3 ... are supplied, then they are
+;;included verbatim within the @t{<HEAD>} section.
+(define (html:head title . args)
   (define backlink (if (null? args) #f (car args)))
   (if (not (null? args)) (set! args (cdr args)))
-  (html:printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
-  (html:printf "<HTML>\\n")
-  (html:comment "HTML by SLIB"
-		"http://swissnet.ai.mit.edu/~jaffer/SLIB.html")
-  (html:printf "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n"
-	       (apply string-append args) (make-plain title))
-  (html:printf "<BODY><H1>%s</H1>\\n"
-	       (or backlink (make-plain title))))
-
-;;@body Outputs HTML codes to end a page.
-(define (html:end-page)
-  (html:printf "</BODY>\\n")
-  (html:printf "</HTML>\\n"))
-
-;;@body Writes (using @code{html:printf}) the strings @1, @2 as
-;;@dfn{PRE}formmated plain text (rendered in fixed-width font).
-;;Newlines are inserted between @1, @2.  HTML tags (@samp{<tag>})
-;;within @2 will be visible verbatim.
+  (string-append
+   (sprintf #f "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
+   (sprintf #f "<HTML>\\n")
+   (sprintf #f "%s"
+	    (html:comment "HTML by SLIB"
+			  "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
+   (sprintf #f " <HEAD>\\n  <TITLE>%s</TITLE>\\n  %s\\n </HEAD>\\n"
+	    (html:plain title) (apply string-append args))
+   (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title)))))
+
+;;@body Returns HTML string to end a page.
+(define (html:body . body)
+  (apply string-append
+	 (append body (list (sprintf #f "</BODY>\\n</HTML>\\n")))))
+
+;;@body Returns the strings @1, @2 as @dfn{PRE}formmated plain text
+;;(rendered in fixed-width font).  Newlines are inserted between @1,
+;;@2.  HTML tags (@samp{<tag>}) within @2 will be visible verbatim.
 (define (html:pre line1 . lines)
-  (html:printf "<PRE>\\n%s" (make-plain line1))
-  (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
-  (html:printf "</PRE>\\n"))
-
-;;@body Writes (using @code{html:printf}) the strings @1 as HTML
-;;comments.
+  (sprintf #f "<PRE>\\n%s%s</PRE>"
+	   (html:plain line1)
+	   (string-append
+	    (apply string-append
+		   (map (lambda (line) (sprintf #f "\\n%s" (html:plain line)))
+			lines)))))
+
+;;@body Returns the strings @1 as HTML comments.
 (define (html:comment line1 . lines)
-  (html:printf "<!")
-  (if (substring? "--" line1)
-      (slib:error 'html:comment "line contains --" line1)
-      (html:printf "--%s--" line1))
-  (for-each (lambda (line)
-	      (if (substring? "--" line)
-		  (slib:error 'html:comment "line contains --" line)
-		  (html:printf "\\n  --%s--" line)))
-	    lines)
-  (html:printf ">\\n"))
-
-;;@section HTML Tables
-
-;;@body
-(define (html:start-table caption)
-  (html:printf "<TABLE BORDER WIDTH=\"100%%\">\\n")
-  (html:printf "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n" (make-plain caption)))
-
-;;@body
-(define (html:end-table)
-  (html:printf "</TABLE>\\n"))
-
-;;@body Outputs a heading row for the currently-started table.
-(define (html:heading columns)
-  (html:printf "<TR VALIGN=\"TOP\">\\n")
-  (for-each (lambda (datum) (html:printf "<TH>%s\\n" (or datum ""))) columns))
-
-;;@body Outputs a heading row with column-names @1 linked to URLs @2.
-(define (html:href-heading columns urls)
-  (html:heading
-   (map (lambda (column url)
-	  (if url
-	      (sprintf #f "<A HREF=\"%s\">%s</A>" url column)
-	      column))
-	columns urls)))
-
-;;@args k foreigns
-;;
-;;The positive integer @1 is the primary-key-limit (number of
-;;primary-keys) of the table.  @2 is a list of the filenames of
-;;foreign-key field pages and #f for non foreign-key fields.
-;;
-;;@0 returns a procedure taking a row for its single argument.  This
-;;returned procedure prints the table row to @var{*html:output-port*}.
-(define (make-row-converter pkl foreigns)
-  (lambda (data-row)
-    (define anchored? #f)
-    (define (present datum)
-      (cond ((or (string? datum) (symbol? datum))
-	     (html:printf "%s" (make-plain datum)))
-	    (else
-	     (html:printf
-	      "<PRE>\\n%s</PRE>\\n"
-	      (make-plain (call-with-output-string
-			   (lambda (port)
-			     (pretty-print datum port))))))))
-    (html:printf "<TR VALIGN=\"TOP\">")
-    (for-each (lambda (datum foreign)
-		(html:printf "<TD>")
-		(cond ((not datum))
-		      ((null? datum))
-		      ((not anchored?)
-		       (html:printf "<A NAME=\"")
-		       (cond
-			((zero? pkl)
-			 (html:printf "%s" (make-atval datum)))
-			(else (html:printf
-			       "%s" (make-atval (car data-row)))
-			      (do ((idx 1 (+ 1 idx))
-				   (contents (cdr data-row) (cdr contents)))
-				  ((>= idx pkl))
-				(html:printf
-				 " %s" (make-atval (car contents))))))
-		       (html:printf "\">")
-		       (set! anchored? (not (zero? pkl)))))
-		(cond ((not datum)) ((null? datum))
-		      ((not foreign) (present datum))
-		      ((zero? pkl)
-		       (html:printf "<A HREF=\"%s\">" foreign)
-		       (present datum)
-		       (html:printf "</A>"))
-		      (else
-		       (html:printf "<A HREF=\"%s#%s\">"
-				    foreign (make-atval datum))
-		       (present datum)
-		       (html:printf "</A>"))))
-	      data-row foreigns)
-    (html:printf "\\n")))
-
-;;@body
-;;Returns the symbol @1 converted to a filename.
-(define (table-name->filename table-name)
-  (and table-name (string-append
-		   (string-subst (symbol->string table-name) "*" "" ":" "_")
-		   ".html")))
-
-(define (table-name->column-table-name db table-name)
-  ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
-   table-name))
-
-;;@args caption db table-name match-key1 @dots{}
-;;Writes HTML for @2 table @3 to @var{*html:output-port*}.
-;;
-;;The optional @4 @dots{} arguments restrict actions to a subset of
-;;the table.  @xref{Table Operations, match-key}.
-(define (table->html caption db table-name . args)
-  (let* ((table ((db 'open-table) table-name #f))
-	 (foreigns (table 'column-foreigns))
-	 (tags (map table-name->filename foreigns))
-	 (names (table 'column-names))
-	 (primlim (table 'primary-limit)))
-    (html:start-table caption)
-    (html:href-heading
-     names
-     (append (make-list primlim (table-name->filename
-				 (table-name->column-table-name db table-name)))
-	     (make-list (- (length names) primlim) #f)))
-    (html:heading (table 'column-domains))
-    (html:href-heading foreigns tags)
-    (html:heading (table 'column-types))
-    (apply (table 'for-each-row) (make-row-converter primlim tags) args)
-    (html:end-table)))
-
-;;@body
-;;Writes a complete HTML page to @var{*html:output-port*}.  The string
-;;@3 names the page which refers to this one.
-(define (table->page db table-name index-filename)
-  (dynamic-wind
-      (lambda ()
-	(if index-filename
-	    (html:start-page
-	     table-name
-	     (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
-		      index-filename
-		      (make-atval table-name)
-		      (make-plain table-name)))
-	    (html:start-page table-name)))
-      (lambda () (table->html table-name db table-name))
-      html:end-page))
-
-;;@body
-;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}.
-(define	(catalog->html db caption)
-  (html:start-table caption)
-  (html:heading '(table columns))
-  ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
-   (lambda (row)
-     (cond ((and (eq? '*columns* (caddr row))
-		 (not (eq? '*columns* (car row)))))
-	   (else ((make-row-converter
-		   0 (list (table-name->filename (car row))
-			   (table-name->filename (caddr row))))
-		  (list (car row) (caddr row))))))))
-
-;;@body
-;;Writes a complete HTML page for the catalog of @1 to
-;;@var{*html:output-port*}.
-(define (catalog->page db caption)
-  (dynamic-wind
-      (lambda () (html:start-page caption))
-      (lambda ()
-	(catalog->html db caption)
-	(html:end-table))
-      html:end-page))
+  (string-append
+   (apply string-append
+	  (if (substring? "--" line1)
+	      (slib:error 'html:comment "line contains --" line1)
+	      (sprintf #f "<!--%s--" line1))
+	  (map (lambda (line)
+		 (if (substring? "--" line)
+		     (slib:error 'html:comment "line contains --" line)
+		     (sprintf #f "\\n  --%s--" line)))
+	       lines))
+   (sprintf #f ">\\n")))
+
+(define (html:strong-doc name doc)
+  (set! name (if name (html:plain name) ""))
+  (set! doc (if doc (html:plain doc) ""))
+  (if (equal? "" doc)
+      (if (equal? "" name)
+	  ""
+	  (sprintf #f "<STRONG>%s</STRONG>" (html:plain name)))
+      (sprintf #f "<STRONG>%s</STRONG> (%s)"
+	       (html:plain name) (html:plain doc))))
 
 ;;@section HTML Forms
 
-(define (html:dt-strong-doc name doc)
-  (if (and (string? doc) (not (equal? "" doc)))
-      (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n"
-		   (make-plain name) (make-plain doc))
-      (html:printf "<DT><STRONG>%s</STRONG>\\n" (make-plain name))))
-
-(define (html:checkbox name doc pname)
-  (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n"
-	       (make-atval pname))
-  (if (and (string? doc) (not (equal? "" doc)))
-      (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n"
-		   (make-plain name) (make-plain doc))
-      (html:printf "<DD><STRONG>%s</STRONG>\\n" (make-plain name))))
-
-(define (html:text name doc pname default)
+;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
+;;@code{put}, or @code{delete}.  The strings @3 form the body of the
+;;form.  @0 returns the HTML @dfn{form}.
+(define (html:form method action . body)
+  (cond ((not (memq method '(get head post put delete)))
+	 (slib:error 'html:form "method unknown:" method)))
+  (string-append
+   (apply string-append
+	  (sprintf #f "<FORM METHOD=%#a ACTION=%#a>\\n"
+		   (html:atval method) (html:atval action))
+	  body)
+   (sprintf #f "</FORM>\\n")))
+
+;;@body Returns HTML string which will cause @1=@2 in form.
+(define (html:hidden name value)
+  (sprintf #f "<INPUT TYPE=HIDDEN NAME=%#a VALUE=%#a>"
+	   (html:atval name) (html:atval value)))
+
+;;@body Returns HTML string for check box.
+(define (html:checkbox pname default)
+  (sprintf #f "<INPUT TYPE=CHECKBOX NAME=%#a %s>"
+	   (html:atval pname)
+	   (if default "CHECKED" "")))
+
+;;@body Returns HTML string for one-line text box.
+(define (html:text pname default . size)
+  (set! size (if (null? size) #f (car size)))
   (cond (default
-	  (html:dt-strong-doc name doc)
-	  (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n"
-		       (make-atval pname)
-		       (max 20 (string-length
-				(if (symbol? default)
-				    (symbol->string default) default)))
-		       (make-atval default)))
-	(else
-	 (html:dt-strong-doc name doc)
-	 (html:printf "<DD><INPUT NAME=%#a>\\n" (make-atval pname)))))
-
-(define (html:text-area name doc pname default-list)
-  (html:dt-strong-doc name doc)
-  (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
-	       (make-atval pname) (max 2 (length default-list))
-	       (apply max 32 (map (lambda (d) (string-length
-					       (if (symbol? d)
-						   (symbol->string d)
-						   d)))
-				  default-list)))
-  (for-each (lambda (line) (html:printf "%s\\n" (make-plain line))) default-list)
-  (html:printf "</TEXTAREA>\\n"))
+	  (sprintf #f "<INPUT NAME=%#a SIZE=%d VALUE=%#a>"
+		   (html:atval pname)
+		   (or size
+		       (max 5
+			    (min 20 (string-length
+				     (if (symbol? default)
+					 (symbol->string default) default)))))
+		   (html:atval default)))
+	(size (sprintf #f "<INPUT NAME=%#a SIZE=%d>" (html:atval pname) size))
+	(else (sprintf #f "<INPUT NAME=%#a>" (html:atval pname)))))
+
+;;@body Returns HTML string for multi-line text box.
+(define (html:text-area pname default-list)
+  (set! default-list (map (lambda (d) (sprintf #f "%a" d)) default-list))
+  (string-append
+   (sprintf #f "<TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
+	    (html:atval pname) (max 1 (length default-list))
+	    (min 32 (apply max 5 (map string-length default-list))))
+   (let* ((str (apply string-append
+		      (map (lambda (line)
+			     (sprintf #f "%s\\n" (html:plain line)))
+			   default-list)))
+	  (len (+ -1 (string-length str))))
+     (if (positive? len) (substring str 0 len) str))
+   (sprintf #f "</TEXTAREA>\\n")))
 
 (define (html:s<? s1 s2)
   (if (and (number? s1) (number? s2))
@@ -311,117 +208,174 @@
       (string<? (if (symbol? s1) (symbol->string s1) s1)
 		(if (symbol? s2) (symbol->string s2) s2))))
 
-(define (html:select name doc pname arity default-list value-list)
-  (set! value-list (sort! value-list html:s<?))
-  (html:dt-strong-doc name doc)
-  (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n"
-	       (make-atval pname)
-	       (case arity
-		 ((single optional) 1)
-		 ((nary nary1) 5))
-	       (case arity
-		 ((nary nary1) " MULTIPLE")
-		 (else "")))
-  (for-each (lambda (value)
-	      (html:printf "<OPTION VALUE=%#a%s>%s\\n"
-			   (make-atval value)
-			   (if (member value default-list)
-			       " SELECTED" "")
-			   (make-plain value)))
-	    (case arity
-	      ((optional nary) (cons (string->symbol "") value-list))
-	      (else value-list)))
-  (html:printf "</SELECT>\\n"))
-
-(define (html:buttons name doc pname arity default-list value-list)
-  (set! value-list (sort! value-list html:s<?))
-  (html:dt-strong-doc name doc)
-  (html:printf "<DD><MENU>")
-  (case arity
-    ((single optional)
-     (for-each (lambda (value)
-		 (html:printf
-		  "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
-		  (make-atval pname) (make-atval value)
-		  (if (member value default-list) " CHECKED" "")
-		  (make-plain value)))
-	       value-list))
-    ((nary nary1)
-     (for-each (lambda (value)
-		 (html:printf
-		  "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
-		  (make-atval pname) (make-atval value)
-		  (if (member value default-list) " CHECKED" "")
-		  (make-plain value)))
-	       value-list)))
-  (html:printf "</MENU>"))
-
-;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
-;;@code{put}, or @code{delete}.  @0 prints the header for an HTML
-;;@dfn{form}.
-(define (html:start-form method action)
-  (cond ((not (memq method '(get head post put delete)))
-	 (slib:error 'html:start-form "method unknown:" method)))
-  (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n"
-	       (make-atval method) (make-atval action))
-  (html:printf "<DL>\\n"))
-
-;;@body @0 prints the footer for an HTML @dfn{form}.  The string @2
-;;appears on the button which submits the form.
-(define (html:end-form pname submit-label)
-  (html:printf "</DL>\\n")
-  (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n"
-	       (make-atval '*command*) (make-atval submit-label))
-  (html:printf "</FORM><HR>\\n"))
+(define (by-car proc)
+  (lambda (s1 s2) (proc (car s1) (car s2))))
+
+;;@body Returns HTML string for pull-down menu selector.
+(define (html:select pname arity default-list foreign-values)
+  (set! foreign-values (sort foreign-values (by-car html:s<?)))
+  (let ((value-list (map car foreign-values))
+	(visibles (map cadr foreign-values)))
+    (string-append
+     (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>"
+	      (html:atval pname)
+	      (case arity
+		((single optional) 1)
+		((nary nary1) 5))
+	      (case arity
+		((nary nary1) " MULTIPLE")
+		(else "")))
+     (apply string-append
+	    (map (lambda (value visible)
+		   (sprintf #f "<OPTION VALUE=%#a%s>%s"
+			    (html:atval value)
+			    (if (member value default-list) " SELECTED" "")
+			    (html:plain visible)))
+		 (case arity
+		   ((optional nary) (cons html:blank value-list))
+		   (else value-list))
+		 (case arity
+		   ((optional nary) (cons html:blank visibles))
+		   (else visibles))))
+     (sprintf #f "</SELECT>"))))
+
+;;@body Returns HTML string for any-of selector.
+(define (html:buttons pname arity default-list foreign-values)
+  (set! foreign-values (sort foreign-values (by-car html:s<?)))
+  (let ((value-list (map car foreign-values))
+	(visibles (map cadr foreign-values)))
+    (string-append
+     (sprintf #f "<MENU>")
+     (case arity
+       ((single optional)
+	(apply
+	 string-append
+	 (map (lambda (value visible)
+		(sprintf #f
+			 "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
+			 (html:atval pname) (html:atval value)
+			 (if (member value default-list) " CHECKED" "")
+			 (html:plain visible)))
+	      value-list
+	      visibles)))
+       ((nary nary1)
+	(apply
+	 string-append
+	 (map (lambda (value visible)
+		(sprintf #f
+			 "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
+			 (html:atval pname) (html:atval value)
+			 (if (member value default-list) " CHECKED" "")
+			 (html:plain visible)))
+	      value-list
+	      visibles))))
+     (sprintf #f "</MENU>"))))
+
+;;@args submit-label command
+;;@args submit-label
+;;
+;;The string or symbol @1 appears on the button which submits the form.
+;;If the optional second argument @2 is given, then @code{*command*=@2}
+;;and @code{*button*=@1} are set in the query.  Otherwise,
+;;@code{*command*=@1} is set in the query.
+(define (form:submit submit-label . command)
+  (if (null? command)
+      (sprintf #f "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>"
+	       (html:atval '*command*)
+	       (html:atval submit-label))
+      (sprintf #f "%s<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a>"
+	       (html:hidden '*command* (car command))
+	       (html:atval '*button*)
+	       (html:atval submit-label))))
+
+;;@body The @2 appears on the button which submits the form.
+(define (form:image submit-label image-src)
+  (sprintf #f "<INPUT TYPE=IMAGE NAME=%#a SRC=%#a>"
+	   (html:atval submit-label)
+	   (html:atval image-src)))
+
+;;@body Returns a string which generates a @dfn{reset} button.
+(define (form:reset) "<INPUT TYPE=RESET>")
+
+(define (html:delimited-list . rows)
+  (apply string-append
+	 "<DL>"
+	 (append rows '("</DL>"))))
+
+;;@body Returns a string which generates an INPUT element for the field
+;;named @1.  The element appears in the created form with its
+;;representation determined by its @2 and domain.  For domains which
+;;are foreign-keys:
+;;
+;;@table @code
+;;@item single
+;;select menu
+;;@item optional
+;;select menu
+;;@item nary
+;;check boxes
+;;@item nary1
+;;check boxes
+;;@end table
+;;
+;;If the foreign-key table has a field named @samp{visible-name}, then
+;;the contents of that field are the names visible to the user for
+;;those choices.  Otherwise, the foreign-key itself is visible.
+;;
+;;For other types of domains:
+;;
+;;@table @code
+;;@item single
+;;text area
+;;@item optional
+;;text area
+;;@item boolean
+;;check box
+;;@item nary
+;;text area
+;;@item nary1
+;;text area
+;;@end table
+(define (form:element pname arity default-list foreign-values)
+  (define dflt (if (null? default-list) #f
+		   (sprintf #f "%a" (car default-list))))
+  ;;(print 'form:element pname arity default-list foreign-values)
+  (case (length foreign-values)
+    ((0) (case arity
+	   ((boolean)
+	    (html:checkbox pname dflt))
+	   ((single optional)
+	    (html:text pname (if (car default-list) dflt "")))
+	   (else (html:text-area pname default-list))))
+    ((1) (html:checkbox pname dflt))
+    (else ((case arity
+	     ((single optional) html:select)
+	     (else html:buttons))
+	   pname arity default-list foreign-values))))
 
-(define (html:generate-form comname method action docu pnames docs aliases
-			    arities types default-lists value-lists)
-  (define aliast (map list pnames))
-  (for-each (lambda (alias) (if (> (string-length (car alias)) 1)
-				(let ((apr (assq (cadr alias) aliast)))
-				  (set-cdr! apr (cons (car alias) (cdr apr))))))
-	    aliases)
-  (dynamic-wind
-   (lambda ()
-     (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
-		  (make-plain comname) (make-plain docu))
-     (html:start-form 'post action))
-   (lambda ()
-     (for-each
-      (lambda (pname doc aliat arity default-list value-list)
-	(define longname
-	  (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
-	(set! longname (if (null? longname) #f (car longname)))
-	(cond (longname
-	       (case (length value-list)
-		 ((0) (case arity
-			((boolean) (html:checkbox longname doc pname 'Y))
-			((single optional)
-			 (html:text longname doc pname
-				    (if (null? default-list)
-					#f (car default-list))))
-			(else
-			 (html:text-area longname doc pname default-list))))
-		 ((1) (html:checkbox longname doc pname (car value-list)))
-		 (else ((case arity
-			  ((single optional) html:select)
-			  (else html:buttons))
-			longname doc pname arity default-list value-list))))))
-      pnames docs aliast arities default-lists value-lists))
-   (lambda ()
-     (html:end-form comname comname))))
+;;@body
+;;
+;;Returns a HTML string for a form element embedded in a line of a
+;;delimited list.  Apply map @0 to the list returned by
+;;@code{command->p-specs}.
+(define (form:delimited pname doc aliat arity default-list foreign-values)
+  (define longname
+    (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
+  (set! longname (if (null? longname) #f (car longname)))
+  (if longname
+      (string-append
+       "<DT>" (html:strong-doc longname doc) "<DD>"
+       (form:element pname arity default-list foreign-values))
+      ""))
 
-;;@body The symbol @2 names a command table in the @1 relational
-;;database.
+;;@body
 ;;
-;;@0 writes an HTML-2.0 @dfn{form} for command @3 to the
-;;current-output-port.  The @samp{SUBMIT} button, which is labeled @3,
-;;invokes the URI @5 with method @4 with a hidden attribute
-;;@code{*command*} bound to the command symbol submitted.
+;;The symbol @2 names a command table in the @1 relational database.
+;;The symbol @3 names a key in @2.
 ;;
-;;An action may invoke a CGI script
-;;(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon
-;;(@samp{http://www.my-site.edu:8001}).
+;;@0 returns a list of lists of @var{pname}, @var{doc}, @var{aliat},
+;;@var{arity}, @var{default-list}, and @var{foreign-values}.  The
+;;returned list has one element for each parameter of command @3.
 ;;
 ;;This example demonstrates how to create a HTML-form for the @samp{build}
 ;;command.
@@ -430,29 +384,34 @@
 ;;(require (in-vicinity (implementation-vicinity) "build.scm"))
 ;;(call-with-output-file "buildscm.html"
 ;;  (lambda (port)
-;;    (fluid-let ((*html:output-port* port))
-;;      (html:start-page 'commands)
-;;      (command->html
-;;       build '*commands* 'build 'post
-;;       (or "/cgi-bin/build.cgi"
-;;           "http://localhost:8081/buildscm"))
-;;      html:end-page)))
+;;    (display
+;;     (string-append
+;;      (html:head 'commands)
+;;      (html:body
+;;       (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
+;;		(html:plain 'build)
+;;		(html:plain ((comtab 'get 'documentation) 'build)))
+;;       (html:form
+;;	'post
+;;	(or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi")
+;;	(apply html:delimited-list
+;;	       (apply map form:delimited
+;;		      (command->p-specs build '*commands* 'build)))
+;;	(form:submit 'build)
+;;	(form:reset))))
+;;     port)))
 ;;@end example
-(define (command->html rdb command-table command method action)
+(define (command->p-specs rdb command-table command)
   (define rdb-open (rdb 'open-table))
   (define (row-refer idx) (lambda (row) (list-ref row idx)))
   (let ((comtab (rdb-open command-table #f))
-	(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id))
-	(get-domain-choices
-	 (let ((for-tab-name
-		((rdb-open '*domains-data* #f) 'get 'foreign-table)))
+	;;(domain->type ((rdb-open '*domains-data* #f) 'get 'type-id))
+	(get-foreign-values
+	 (let ((ftn ((rdb-open '*domains-data* #f) 'get 'foreign-table)))
 	   (lambda (domain-name)
-	     (define tab-name (for-tab-name domain-name))
+	     (define tab-name (ftn domain-name))
 	     (if tab-name
-		 (do ((dlst (((rdb-open tab-name #f) 'get* 1)) (cdr dlst))
-		      (out '() (if (member (car dlst) (cdr dlst))
-				   out (cons (car dlst) out))))
-		     ((null? dlst) out))
+		 (get-foreign-choices (rdb-open tab-name #f))
 		 '())))))
     (define row-ref
       (let ((names (comtab 'column-names)))
@@ -463,387 +422,28 @@
 	   (param-rows (sort! ((parameter-table 'row:retrieve*))
 			      (lambda (r1 r2) (< (car r1) (car r2))))))
       (let ((domains (map (row-refer (position 'domain pcnames)) param-rows))
-	    (parameter-names
-	     (rdb-open (row-ref command:row 'parameter-names) #f)))
-	(html:generate-form
-	 command
-	 method
-	 action
-	 (row-ref command:row 'documentation)
-	 (map (row-refer (position 'name pcnames)) param-rows)
-	 (map (row-refer (position 'documentation pcnames)) param-rows)
-	 (map list ((parameter-names 'get* 'name))
-	      (map (parameter-table 'get 'name)
-		   ((parameter-names 'get* 'parameter-index))))
-	 (map (row-refer (position 'arity pcnames)) param-rows)
-	 (map domain->type domains)
-	 (map cdr (fill-empty-parameters
-		   (map slib:eval
-			(map (row-refer (position 'defaulter pcnames))
-			     param-rows))
-		   (make-parameter-list
-		    (map (row-refer (position 'name pcnames)) param-rows))))
-	 (map get-domain-choices domains))))))
-
-(define (cgi:process-% str)
-  (define len (string-length str))
-  (define (sub str)
-    (cond
-     ((string-index str #\%)
-      => (lambda (idx)
-	   (if (and (< (+ 2 idx) len)
-		    (string->number (substring str (+ 1 idx) (+ 2 idx)) 16)
-		    (string->number (substring str (+ 2 idx) (+ 3 idx)) 16))
-	       (string-append
-		(substring str 0 idx)
-		(string (integer->char
-			 (string->number
-			  (substring str (+ 1 idx) (+ 3 idx))
-			  16)))
-		(sub (substring str (+ 3 idx) (string-length str)))))))
-     (else str)))
-  (sub str))
-
-(define (form:split-lines txt)
-  (let ((idx (string-index txt #\newline))
-	(carriage-return (integer->char #xd)))
-    (if idx
-	(cons (substring txt 0
-			 (if (and (positive? idx)
-				  (char=? carriage-return
-					  (string-ref txt (+ -1 idx))))
-			     (+ -1 idx)
-			     idx))
-	      (form:split-lines
-	       (substring txt (+ 1 idx) (string-length txt))))
-	(list txt))))
-
-(define (form-urlencoded->query-alist txt)
-  (if (symbol? txt) (set! txt (symbol->string txt)))
-  (set! txt (string-subst txt " " "" "+" " "))
-  (do ((lst '())
-       (edx (string-index txt #\=)
-	    (string-index txt #\=)))
-      ((not edx) lst)
-    (let* ((rxt (substring txt (+ 1 edx) (string-length txt)))
-	   (adx (string-index rxt #\&))
-	   (name (cgi:process-% (substring txt 0 edx))))
-      (set!
-       lst (append
-	    lst
-	    (map
-	     (lambda (value) (list (string->symbol name)
-				   (if (equal? "" value) #f value)))
-	     (form:split-lines
-	      (cgi:process-% (substring rxt 0 (or adx (string-length rxt))))))))
-      (set! txt (if adx (substring rxt (+ 1 adx) (string-length rxt)) "")))))
-
-(define (query-alist->parameter-list alist optnames arities types)
-  (define (can-take-arg? opt)
-    (not (eq? (list-ref arities (position opt optnames)) 'boolean)))
-  (let ((parameter-list (make-parameter-list optnames)))
-    (for-each
-     (lambda (lst)
-       (let* ((value (cadr lst))
-	      (name (car lst)))
-	 (cond ((not (can-take-arg? name))
-		(adjoin-parameters! parameter-list (list name #t)))
-	       (value
-		(adjoin-parameters!
-		 parameter-list
-		 (let ((type (list-ref types (position name optnames))))
-		   (case type
-		     ((expression) (list name value))
-		     ((symbol)
-		      (if (string? value)
-			  (call-with-input-string
-			   value
-			   (lambda (port)
-			     (do ((tok (scanf-read-list " %s" port)
-				       (scanf-read-list " %s" port))
-				  (lst '()
-				       (cons (string-ci->symbol (car tok))
-					     lst)))
-				 ((or (null? tok) (eof-object? tok))
-				  (cons name lst)))))
-			  (list name (coerce value type))))
-		     (else (list name (coerce value type))))))))))
-     alist)
-    parameter-list))
-
-;;@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages
-;;@section HTTP and CGI service
-
-;;@code{(require 'html-form)}
-
-;;;; Now that we have generated the HTML form, process the ensuing CGI request.
-
-;;@body Reads a @samp{"POST"} or @samp{"GET"} query from
-;;@code{(current-input-port)} and executes the encoded command from @2
-;;in relational-database @1.
-;;
-;;This example puts up a plain-text page in response to a CGI query.
-;;
-;;@example
-;;(display "Content-Type: text/plain") (newline) (newline)
-;;(require 'html-form)
-;;(load (in-vicinity (implementation-vicinity) "build.scm"))
-;;(cgi:serve-command build '*commands*)
-;;@end example
-(define (cgi:serve-command rdb command-table)
-  (serve-urlencoded-command rdb command-table (cgi:read-query-string)))
-
-;;@body Reads attribute-value pairs from @3, converts them to
-;;parameters and invokes the @1 command named by the parameter
-;;@code{*command*}.
-(define (serve-urlencoded-command rdb command-table urlencoded)
-  (let* ((alist (form-urlencoded->query-alist urlencoded))
-	 (comname #f)
-	 (comtab ((rdb 'open-table) command-table #f))
-	 (names (comtab 'column-names))
-	 (row-ref (lambda (row name) (list-ref row (position name names))))
-	 (comgetrow (comtab 'row:retrieve)))
-    (set! alist (remove-if (lambda (elt)
-			     (cond ((not (and (list? elt) (pair? elt)
-					      (eq? '*command* (car elt)))) #f)
-				   (comname
-				    (slib:error
-				     'serve-urlencoded-command
-				     'more-than-one-command? comname
-				     (string->symbol (cadr elt))))
-				   (else (set! comname
-					       (string-ci->symbol (cadr elt)))
-					 #t)))
-			   alist))
-    (let* ((command:row (comgetrow comname))
-	   (parameter-table ((rdb 'open-table)
-			     (row-ref command:row 'parameters) #f))
-	   (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
-	   (options ((parameter-table 'get* 'name)))
-	   (positions ((parameter-table 'get* 'index)))
-	   (arities ((parameter-table 'get* 'arity)))
-	   (defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
-	   (domains ((parameter-table 'get* 'domain)))
-	   (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
-		       domains))
-	   (dirs (map (rdb 'domain-checker) domains)))
-
-       (let* ((params (query-alist->parameter-list alist options arities types))
-	     (fparams (fill-empty-parameters defaulters params)))
-	(and (list? fparams) (check-parameters dirs fparams)
-	     (comval fparams))))))
-
-(define (serve-query-alist-command rdb command-table alist)
-  (let ((command #f))
-    (set! alist (remove-if (lambda (elt)
-			     (cond ((not (and (list? elt) (pair? elt)
-					      (eq? '*command* (car elt)))) #f)
-				   (command
-				    (slib:error
-				     'serve-query-alist-command
-				     'more-than-one-command? command
-				     (string->symbol (cadr elt))))
-				   (else (set! command
-					       (string-ci->symbol (cadr elt)))
-					 #t)))
-			   alist))
-    ((make-command-server rdb command-table)
-     command
-     (lambda (comname comval options positions
-		      arities types defaulters dirs aliases)
-       (let* ((params (query-alist->parameter-list alist options arities types))
-	      (fparams (fill-empty-parameters defaulters params)))
-	 (and (list? fparams) (check-parameters dirs fparams)
-	      (apply comval
-		     (parameter-list->arglist positions arities fparams))))))))
-
-(define http:crlf (string (integer->char 13) #\newline))
-(define (http:read-header port)
-  (define alist '())
-  (do ((line (read-line port) (read-line port)))
-      ((or (zero? (string-length line))
-	   (and (= 1 (string-length line))
-		(char-whitespace? (string-ref line 0)))
-	   (eof-object? line))
-       (if (and (= 1 (string-length line))
-		(char-whitespace? (string-ref line 0)))
-	   (set! http:crlf (string (string-ref line 0) #\newline)))
-       (if (eof-object? line) line alist))
-    (let ((len (string-length line))
-	  (idx (string-index line #\:)))
-      (if (char-whitespace? (string-ref line (+ -1 len)))
-	  (set! len (+ -1 len)))
-      (and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
-		   ((or (>= idx2 len)
-			(not (char-whitespace? (string-ref line idx2))))
-		    (set! alist
-			  (cons
-			   (cons (string-ci->symbol (substring line 0 idx))
-				 (substring line idx2 len))
-			   alist)))))
-      ;;Else -- ignore malformed line
-      ;;(else (slib:error 'http:read-header 'malformed-input line))
-      )))
-
-(define (http:read-query-string request-line header port)
-  (case (car request-line)
-    ((get head)
-     (let* ((request-uri (cadr request-line))
-	    (len (string-length request-uri)))
-       (and (> len 3)
-	    (string-index request-uri #\?)
-	    (substring request-uri
-		       (+ 1 (string-index request-uri #\?))
-		       (if (eqv? #\/ (string-ref request-uri (+ -1 len)))
-			   (+ -1 len)
-			   len)))))
-    ((post put delete)
-     (let ((content-length (assq 'content-length header)))
-       (and content-length
-	    (set! content-length (string->number (cdr content-length))))
-       (and content-length
-	    (let ((str (make-string content-length #\ )))
-	      (do ((idx 0 (+ idx 1)))
-		  ((>= idx content-length)
-		   (if (>= idx (string-length str)) str (substring str 0 idx)))
-		(let ((chr (read-char port)))
-		  (if (char? chr)
-		      (string-set! str idx chr)
-		      (set! content-length idx))))))))
-    (else #f)))
-
-(define (http:send-status-line status-code reason)
-  (html:printf "HTTP/1.1 %d %s%s" status-code reason http:crlf))
-(define (http:send-header alist)
-  (for-each (lambda (pair)
-	      (html:printf "%s: %s%s" (car pair) (cdr pair) http:crlf))
-	    alist)
-  (html:printf http:crlf))
-
-(define *http:byline*
-  "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB </A>HTTP/1.1 server")
-
-(define (http:send-error-page code str port)
-  (fluid-let ((*html:output-port* port))
-    (http:send-status-line code str)
-    (http:send-header '(("Content-Type" . "text/html")))
-    (html:start-page (sprintf #f "%d %s" code str))
-    (and *http:byline* (html:printf "<HR>\\n%s\\n" *http:byline*))
-    (html:end-page)))
-
-;;@body reads the @dfn{query-string} from @1.  If this is a valid
-;;@samp{"POST"} or @samp{"GET"} query, then @0 calls @3 with two
-;;arguments, the query-string and the header-alist.
-;;
-;;Otherwise, @0 replies (to @2) with appropriate HTML describing the
-;;problem.
-(define (http:serve-query input-port output-port serve-proc)
-  (let ((request-line (http:read-request-line input-port)))
-    (cond ((not request-line)
-	   (http:send-error-page 400 "Bad Request" output-port))
-	  ((string? (car request-line))
-	   (http:send-error-page 501 "Not Implemented" output-port))
-	  ((not (case (car request-line)
-		  ((get post) #t)
-		  (else #f)))
-	   (http:send-error-page 405 "Method Not Allowed" output-port))
-	  (else (let* ((header (http:read-header input-port))
-		       (query-string
-			(http:read-query-string
-			 request-line header input-port)))
-		  (cond ((not query-string)
-			 (http:send-error-page 400 "Bad Request" output-port))
-			(else (http:send-status-line 200 "OK")
-			      (serve-proc query-string header))))))))
-
-;;@ This example services HTTP queries from port 8081:
-;;
-;;@example
-;;(define socket (make-stream-socket AF_INET 0))
-;;(socket:bind socket 8081)
-;;(socket:listen socket 10)
-;;(dynamic-wind
-;; (lambda () #f)
-;; (lambda ()
-;;   (do ((port (socket:accept socket)
-;;              (socket:accept socket)))
-;;       (#f)
-;;     (dynamic-wind
-;;      (lambda () #f)
-;;      (lambda ()
-;;        (fluid-let ((*html:output-port* port))
-;;          (http:serve-query
-;;           port port
-;;           (lambda (query-string header)
-;;             (http:send-header
-;;              '(("Content-Type" . "text/plain")))
-;;             (with-output-to-port port
-;;               (lambda ()
-;;                 (serve-urlencoded-command
-;;                  build '*commands* query-string)))))))
-;;      (lambda () (close-port port)))))
-;; (lambda () (close-port socket)))
-;;@end example
-
-(define (http:read-start-line port)
-  (do ((line (read-line port) (read-line port)))
-      ((or (not (equal? "" line)) (eof-object? line)) line)))
-
-;;@body Reads the first non-blank line from @1 and, if successful,
-;;returns a list of three itmes from the request-line:
-;;
-;;@enumerate 0
-;;
-;;@item Method
-;;
-;;Either one of the symbols @code{options}, @code{get}, @code{head},
-;;@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string.
-;;
-;;@item Request-URI
-;;
-;;A string.  At the minimum, it will be the string @samp{"/"}.
-;;
-;;@item HTTP-Version
-;;
-;;A string.  For example, @samp{HTTP/1.0}.
-;;@end enumerate
-(define (http:read-request-line port)
-  (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port))))
-    (and (list? lst)
-	 (= 3 (length lst))
-	 (let ((method
-		(assoc
-		 (car lst)
-		 '(("OPTIONS" . options) ; Section 9.2
-		   ("GET"     . get)	; Section 9.3
-		   ("HEAD"    . head)	; Section 9.4
-		   ("POST"    . post)	; Section 9.5
-		   ("PUT"     . put)	; Section 9.6
-		   ("DELETE"  . delete)	; Section 9.7
-		   ("TRACE"   . trace)	; Section 9.8
-		   ))))
-	   (cons (if (pair? method) (cdr method) (car lst)) (cdr lst))))))
-
-;;@body Reads the @dfn{query-string} from @code{(current-input-port)}.
-;;@0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
-;;value of @code{(getenv "REQUEST_METHOD")}.
-(define (cgi:read-query-string)
-  (define request-method (getenv "REQUEST_METHOD"))
-  (cond ((and request-method (string-ci=? "GET" request-method))
-	 (getenv "QUERY_STRING"))
-	((and request-method (string-ci=? "POST" request-method))
-	 (let ((content-length (getenv "CONTENT_LENGTH")))
-	   (and content-length
-		(set! content-length (string->number content-length)))
-	   (and content-length
-		(let ((str (make-string content-length #\ )))
-		  (do ((idx 0 (+ idx 1)))
-		      ((>= idx content-length)
-		       (if (>= idx (string-length str))
-			   str
-			   (substring str 0 idx)))
-		    (let ((chr (read-char)))
-		      (if (char? chr)
-			  (string-set! str idx chr)
-			  (set! content-length idx))))))))
-	(else #f)))
+	    (parameter-names (rdb-open (row-ref command:row 'parameter-names) #f))
+	    (pnames (map (row-refer (position 'name pcnames)) param-rows)))
+	(define foreign-values (map get-foreign-values domains))
+	(define aliast (map list pnames))
+	(for-each (lambda (alias)
+		    (if (> (string-length (car alias)) 1)
+			(let ((apr (assq (cadr alias) aliast)))
+			  (set-cdr! apr (cons (car alias) (cdr apr))))))
+		  (map list
+		       ((parameter-names 'get* 'name))
+		       (map (parameter-table 'get 'name)
+			    ((parameter-names 'get* 'parameter-index)))))
+	(list pnames
+	      (map (row-refer (position 'documentation pcnames)) param-rows)
+	      aliast
+	      (map (row-refer (position 'arity pcnames)) param-rows)
+	      ;;(map domain->type domains)
+	      (map cdr			;(lambda (lst) (if (null? lst) lst (cdr lst)))
+		   (fill-empty-parameters
+		    (map slib:eval
+			 (map (row-refer (position 'defaulter pcnames))
+			      param-rows))
+		    (make-parameter-list
+		     (map (row-refer (position 'name pcnames)) param-rows))))
+	      foreign-values)))))
-- 
cgit v1.2.3