From: Matt Birkholz Date: Wed, 7 May 2014 04:11:25 +0000 (-0700) Subject: ffi: Add install-html using documentation build parameters. X-Git-Tag: release-9.2.0~9 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=666df6f7fc55b74e1848fa918c30ce001c31fe20;p=mit-scheme.git 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 dca4c5204..79311ae38 100644 --- 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 7a956b4da..0bac0e8f0 100644 --- 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 0f2cdb348..e31bcb5b9 100644 --- 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 "^
  • \\(.*\\)
    • $" + 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 "
  • "title"
    • ") + 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) + (stringenvironment '(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 a0caea3c6..47b1729bc 100644 --- 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