ffi: Add install-html using documentation build parameters.

Install parameters in infodir/mit-scheme-doc-config.scm.

diff --git a/doc/Makefile.in b/doc/Makefile.in
index dca4c5204473338269fada77e1a29c2deb68771f..79311ae384dc32e3d6c86b200586a9850bb56a66 100644 (file)
--- a/doc/Makefile.in
+++ b/doc/Makefile.in
@@ -1,6 +1,6 @@
 # Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 #     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-#     2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+#     2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
 #     Massachusetts Institute of Technology
 #
 # This file is part of MIT/GNU Scheme.
@@ -103,7 +103,19 @@ maintainer-clean:
 
 tags TAGS:
 
-install: install-info-gz install-man $(INST_TARGETS)
+install: install-config install-info-gz install-man $(INST_TARGETS)
+
+install-config: doc-config.scm
+       $(mkinstalldirs) $(DESTDIR)$(infodir)
+       $(INSTALL_DATA) $< $(DESTDIR)$(infodir)/mit-scheme-doc-config.scm
+
+doc-config.scm:
+       @echo "Saving documentation configuration."
+       @ ( echo "(QUOTE"; \
+           echo " ((INSTALL \"$(INSTALL_DATA)\")"; \
+           echo "  (HTMLDIR \"${htmldir}\")"; \
+           echo "  (PDFDIR \"${pdfdir}\")"; \
+           echo "  (PSDIR \"${psdir}\")))" ) >doc-config.scm
 
 install-info-gz install-info:
        $(mkinstalldirs) $(DESTDIR)$(infodir)

diff --git a/doc/info-dir b/doc/info-dir
index 7a956b4dadedbe6f32fe3baf329aa6fb43f80842..0bac0e8f0afe1d72311a57127c68a1bf28e9a034 100644 (file)
--- a/doc/info-dir
+++ b/doc/info-dir
@@ -10,9 +10,10 @@ File: dir    Node: Top       This is the top of the INFO tree
   etc.
   Or click mouse button 2 on a menu item or cross reference to select
   it.
-  --- PLEASE ADD DOCUMENTATION TO THIS TREE. (See INFO topic first.) ---
 
-* Menu: The list of major topics begins on the next line.
+* Menu:
+
+Programming Languages
 
 * MIT/GNU Scheme FFI: (mit-scheme-ffi).
                                 Foreign Function Interface

diff --git a/src/ffi/build.scm b/src/ffi/build.scm
index 0f2cdb348c54470cd33008e64612e2b607e7d1cf..e31bcb5b9c214d50a392a651a49ca2f7d37b136c 100644 (file)
--- a/src/ffi/build.scm
+++ b/src/ffi/build.scm
@@ -2,7 +2,7 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
     Institute of Technology
 
 This file is part of MIT/GNU Scheme.
@@ -112,10 +112,82 @@ USA.
   (write-string "  (standard-system-loader \"" out)
   (write-string dirname out)
   (write-string "\"))" out))
+
+(define (install-html destdir title)
+  (guarantee-string destdir 'INSTALL-HTML)
+  (guarantee-string title 'INSTALL-HTML)
+  (let ((conf (doc-conf)))
+    (let ((install (conf-words conf 'INSTALL))
+         (htmldir (string-append destdir (conf-value conf 'HTMLDIR)))
+         (files (files)))
+      (run-command (append install files (list htmldir)))
+      (rewrite-file (merge-pathnames "index.html"
+                                    (pathname-as-directory htmldir))
+                   (lambda (in out)
+                     (rewrite-html-index (car files) title in out))))))
+
+(define (rewrite-html-index file title in out)
+
+  (define (match line)
+    (if (eof-object? line)
+       (error "Premature end of HTML documentation index." in))
+    (let ((regs (re-string-match "^<li><a href=\"\\(.*\\)\">\\(.*\\)</a></li>$"
+                                line)))
+      (if (not regs)
+         #f
+         (cons (re-match-extract line regs 1)
+               (re-match-extract line regs 2)))))
+
+  (define (write-item file.title)
+    (let ((file (car file.title))
+         (title (cdr file.title)))
+      (write-string (string-append "<li><a href=\""file"\">"title"</a></li>")
+                   out)
+      (newline out)))
+
+  (define (copy-prefix)
+    (let* ((line (read-line in))
+          (f.t (match line)))
+      (if (not f.t)
+         (begin
+           (write-string line out)
+           (newline out)
+           (copy-prefix))
+         f.t)))
+
+  (define (copy-items)
+    (let loop ((items (list (copy-prefix))))
+      (let* ((line (read-line in))
+            (f.t (match line)))
+       (if f.t
+           (loop (cons f.t items))
+           (let ((items (let ((entry (assoc file items)))
+                          (if entry
+                              (delq! entry items)
+                              items))))
+             (for-each write-item
+                       (sort (cons (cons file title) items)
+                             (lambda (f.title1 f.title2)
+                               (string<? (cdr f.title1)
+                                         (cdr f.title2)))))
+             line)))))
+
+  (define (copy-suffix line)
+    (if (not (eof-object? line))
+       (begin
+         (write-string line out)
+         (newline out)
+         (copy-suffix (read-line in)))))
+
+  (copy-suffix (copy-items)))
 \f
 (define (shim-conf)
   (load (system-library-pathname "shim-config.scm")))
 
+(define (doc-conf)
+  (load (string-append (conf-value (shim-conf) 'INFODIR)
+                      "mit-scheme-doc-config.scm")))
+
 (define (conf-values conf name)
   (let ((entry (assq name conf)))
     (if (pair? entry)

diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg
index 51484916c97a95e14a36bd1144ee5c7ebb4ee556..8e772b589bc6cdceac07e8d4e22878cee237484a 100644 (file)
--- a/src/ffi/ffi.pkg
+++ b/src/ffi/ffi.pkg
@@ -46,4 +46,5 @@ FFI System Packaging |#
          compile-shim
          link-shim
          install-shim
-         install-load-option))
\ No newline at end of file
+         install-load-option
+         install-html))
\ No newline at end of file

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 371c80df1f9e8e067ba417cf61744cd088434a0e..0cae19f5d8c4f6cf7a1c1803010022e549ea0c61 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -2,7 +2,7 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
     Institute of Technology
 
 This file is part of MIT/GNU Scheme.
@@ -546,6 +546,10 @@ USA.
   ((environment-lookup (->environment '(ffi)) 'install-load-option)
    destdir name directory))
 
+(define (install-html destdir title)
+  (load-ffi-quietly)
+  ((environment-lookup (->environment '(ffi)) 'install-html) destdir title))
+
 (define (load-ffi-quietly)
   (if (not (name->package '(FFI)))
       (let ((kernel (lambda ()

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a0caea3c6690b62b30f25ab2edaec99c116a3e81..47b1729bc185d704383be67b6a7c3998498d6da1 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2,7 +2,7 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
     Institute of Technology
 
 This file is part of MIT/GNU Scheme.
@@ -3340,7 +3340,8 @@ USA.
          compile-shim
          link-shim
          install-shim
-         install-load-option)
+         install-load-option
+         install-html)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)
@@ -6043,4 +6044,4 @@ USA.
          stack-sampler:debug-internal-errors?
          stack-sampler:show-expressions?
          with-stack-sampling)
-  (initialization (initialize-package!)))
+  (initialization (initialize-package!)))
\ No newline at end of file