Extract unroff-1.0.tar.gz
This commit is contained in:
commit
d8bfced2b7
|
|
@ -0,0 +1,26 @@
|
|||
Copyright 1995 Oliver Laumann. All rights reserved.
|
||||
|
||||
Not derived from licensed software.
|
||||
|
||||
Permission is granted to use, copy, perform, display, modify, and
|
||||
redistribute this software (including derivative works based on it) in
|
||||
any form, subject to the following restrictions:
|
||||
|
||||
i) Source distributions must be accompanied by this entire copyright
|
||||
notice.
|
||||
ii) Binary distributions must include the acknowledgement ``This
|
||||
product includes software developed by Oliver Laumann'' in the
|
||||
documentation or other materials provided with the distribution.
|
||||
iii) The origin of this software must not be misrepresented, either
|
||||
by explicit claim or by omission.
|
||||
iv) Altered versions must be plainly marked as such in the source
|
||||
and documentation and must not be misrepresented as being the
|
||||
original software.
|
||||
v) The author is not deemed to have made any representations as to
|
||||
the suitability of this software for any purpose nor is held
|
||||
responsible for any defects of this software.
|
||||
THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
|
||||
|
||||
Berlin, March 23, 1995
|
||||
|
||||
Oliver Laumann <net@cs.tu-berlin.de> # $Revision: 1.2 $
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
Installation Guide for the `unroff' Source Distribution
|
||||
-------------------------------------------------------
|
||||
|
||||
Requirements: you need Elk 2.2 or Elk 3.0 and an ANSI C compiler
|
||||
to install unroff from the source distribution. If you don't have
|
||||
Elk and don't want to install it, you may want to obtain the binary
|
||||
unroff distribution instead.
|
||||
|
||||
You can obtain Elk 3.0 in the World Wide Web at
|
||||
|
||||
http://www.informatik.uni-bremen.de/~net/elk
|
||||
|
||||
and from a number of FTP servers including these:
|
||||
|
||||
ftp://ftp.x.org/contrib/devel_tools/elk-3.0.tar.gz
|
||||
ftp://ftp.uni-bremen.de/pub/programming/languages/scheme/elk/elk-3.0.tar.gz
|
||||
|
||||
|
||||
|
||||
o If you are still using Elk 2.2, you may have to apply a small patch to
|
||||
your Elk installation. The patch is in the file src/elk-2.2-patch.
|
||||
Assuming you have unpacked unroff under /usr/local/src/unroff-1.0,
|
||||
change to the directory where the Elk "src" directory is located and call:
|
||||
|
||||
patch < /usr/local/src/unroff-1.0/src/elk-2.2-patch
|
||||
|
||||
If the patch program detects a `Reverse patch', the patch is not
|
||||
required and you are done. If the patch succeeded, recompile the
|
||||
interpreter by calling "make" and "make install" in the directory "src".
|
||||
|
||||
o Go to the sub-directory "src" below the directory where you unpacked
|
||||
unroff:
|
||||
|
||||
cd /usr/local/src/unroff-1.0/src
|
||||
|
||||
and edit the Makefile. Check the site and compiler dependencies at the
|
||||
beginning of the Makefile and modify them if necessary.
|
||||
|
||||
(Don't worry about DIR= if you just want to test unroff; you can
|
||||
override the directory later by setting the environment variable
|
||||
UNROFF_DIR before calling unroff.)
|
||||
|
||||
o Call "make depend" and then "make".
|
||||
|
||||
o You may want to remove the minimal Elk runtime environment contained
|
||||
in the directory "elk" and replace it by a symbolic link to your
|
||||
site's Elk runtime directory (i.e. the directory with sub-directories
|
||||
"scm" and "obj").
|
||||
|
||||
|
||||
o Test unroff and the HTML back-end included in the distribution.
|
||||
|
||||
For example, change to the directory "doc" and run "make" to convert
|
||||
the manual pages and the Programmer's Manual to HTML. Then view the
|
||||
resulting .html files with your favorite WWW browser.
|
||||
|
||||
Test the supplementary -ms features by calling (still in "doc"):
|
||||
|
||||
unroff -ms document=test split=1 hyper.scm manual.ms
|
||||
|
||||
This creates several files beginning with "test". Load test.html
|
||||
into your WWW browser; observe the automatically generated table of
|
||||
contents and the hypertext links embedded in the document. When
|
||||
finished, you may want to "rm test*".
|
||||
|
||||
You can proceed by using unroff with a few troff documents of your
|
||||
own. For example, try to convert a large manual page:
|
||||
|
||||
unroff -man /usr/man/man1/csh.1
|
||||
|
||||
Don't worry if this displays numerous warning messages. unroff
|
||||
usually produces good results even if many low-level troff requests
|
||||
are ignored. Check csh.1.html with your WWW browser.
|
||||
|
||||
o Read the documentation located in the directory "doc", in particular
|
||||
the manual pages.
|
||||
|
||||
You can convert the troff files to HTML and view them with your
|
||||
WWW browser (as explained in the previous step), or typeset them
|
||||
using your local troff and send the output to the printer, or read
|
||||
them online using nroff or man.
|
||||
|
||||
o You may want to place a number of default settings into an initialization
|
||||
file ".unroff" in your home directory. There is a sample init file
|
||||
"sample.unroff" in the directory "misc". If you decide to use this
|
||||
file, replace the string "net@cs.tu-berlin.de" by your e-mail address.
|
||||
|
||||
o If you find unroff useful, you may want to install it in a central
|
||||
directory at your site. If so, install the executable, the contents
|
||||
of the directory "scm", and the manual pages.
|
||||
|
||||
|
||||
If you have any questions, problems, or suggestions send a message to
|
||||
net@cs.tu-berlin.de.
|
||||
|
||||
# $Revision: 1.6 $
|
||||
|
|
@ -0,0 +1 @@
|
|||
2
|
||||
|
|
@ -0,0 +1,133 @@
|
|||
This is version 1.0 of unroff.
|
||||
|
||||
Unroff is a Scheme-based, programmable, extensible troff translator
|
||||
with a back-end for the Hypertext Markup Language. Unroff is free
|
||||
software and is distributed both as source and as precompiled binaries.
|
||||
|
||||
|
||||
* Overview
|
||||
|
||||
Unroff reads and parses UNIX troff documents and translates the embedded
|
||||
markup into a different format. Neither the actual output format nor
|
||||
any knowledge about particular troff macro sets (-man, -ms, etc.) are
|
||||
hard-wired into unroff. Instead, the translation process is controlled
|
||||
by a set of user-supplied procedures written in the Scheme programming
|
||||
language.
|
||||
|
||||
Translation rules for new output formats and troff macro packages can
|
||||
be added easily by providing a corresponding set of Scheme procedures
|
||||
(a `back-end'). Version 1.0 of unroff includes back-ends for translating
|
||||
documents using the `man' and `ms' macros into the Hypertext Markup
|
||||
Language (HTML) version 2.0. Additional requests facilitate use of
|
||||
arbitrary hypertext links in troff documents.
|
||||
|
||||
|
||||
* unroff and troff
|
||||
|
||||
In contrast to conventional troff `converters' (usually Perl scripts
|
||||
some of which process nroff output) unroff includes a full troff parser
|
||||
and closely mimics the troff processing engine.
|
||||
|
||||
This enables unroff to handle user-defined macros, strings, and
|
||||
number registers, nested if-else requests, arbitrary fonts and font
|
||||
positions, low-level formatting requests such as \l, \c, and \h, and
|
||||
idiosyncrasies such as troff `copy mode' and the subtle differences
|
||||
between request and macro invocations.
|
||||
|
||||
Unroff has adopted a number of groff extensions, among them long names
|
||||
for macros, strings, number registers, and special characters, and the
|
||||
escape sequences \$@ and \$*.
|
||||
|
||||
|
||||
* unroff and Scheme
|
||||
|
||||
Unroff uses Elk, the Scheme-based Extension Language Kit, to achieve
|
||||
programmability. It includes a full Scheme language implementation
|
||||
with the usual amenities such as garbage collection, interactive
|
||||
programming and testing, and dynamic loading. Standard Scheme has
|
||||
been augmented by a set of new Scheme data types and primitives that
|
||||
aid in writing new unroff back-ends.
|
||||
|
||||
A new troff request and an extension to the `.ig' request allow for
|
||||
Scheme code to be embedded in troff documents; the code is then
|
||||
evaluated on the fly as the documents are processed by unroff.
|
||||
|
||||
Unroff may be viewed as a prototype for hybrid applications that use
|
||||
Scheme (in particular Elk) as their extension language. Approximately
|
||||
half of its source consists of portable ANSI C code, and the other
|
||||
half is written in Scheme and can be configured and tailored easily
|
||||
without the need to recompile unroff. Authors of Elk-based applications
|
||||
are encouraged to look into the source code or reuse parts of it for
|
||||
their own projects.
|
||||
|
||||
As the time-critical Scheme primitives provided of unroff have been
|
||||
coded in (efficient) C, its performance comes close to that of nroff
|
||||
processing the same troff input.
|
||||
|
||||
|
||||
* unroff and hypertext
|
||||
|
||||
troff documents that were originally written without intentions to
|
||||
make them available in the World Wide Web (such as UNIX manual pages)
|
||||
can easily be translated to the Hypertext Markup Language using the
|
||||
predefined HTML back-ends.
|
||||
|
||||
As unroff closely simulates ordinary troff, even large or complex
|
||||
documents (like technical reports or theses with many user-defined
|
||||
macros) can be translated to HTML automatically without having to
|
||||
add any structural cues to the documents.
|
||||
|
||||
The `-man' support has been tested with several hundred vendor- and
|
||||
user-supplied manual pages and has produced good results in all but
|
||||
less than a dozen cases (a few manual pages were found to make excessive
|
||||
use of low-level troff constructs or to include tbl output verbatim).
|
||||
|
||||
|
||||
* Managing hypertext documents with troff
|
||||
|
||||
Authors can benefit from unroff not only as a converter for existing
|
||||
documents, but also when writing new documents that must exist both
|
||||
in high-quality paper form and in the World Wide Web as hypertext.
|
||||
|
||||
Rather than writing hypertext documents directly in HTML (which is
|
||||
cumbersome for long or complex texts), authors can continue using
|
||||
ordinary troff together with the usual preprocessors and macro packages.
|
||||
Unroff is then employed to produce the WWW form, while troff is used
|
||||
in the normal way to typeset the same text, producing the printed
|
||||
version (or, using nroff, an ASCII version if desired).
|
||||
|
||||
In this way authors of hypertext documents can take full advantage of
|
||||
the usual troff facilities such as user-defined macros, conditional text,
|
||||
tables, equations, and drawings, automatic table of contents generation,
|
||||
footnotes/endnotes, indexes, etc., none of which are available when
|
||||
composing documents directly in plain HTML.
|
||||
|
||||
Two new troff requests for embedding hypertext links in troff documents
|
||||
are provided by the unroff HTML back-end. Arbitrary forward and backward
|
||||
references using symbolic labels (rather than actual file names) among
|
||||
groups of troff source files are supported. Another new request and
|
||||
another extension to `.ig' allow for HTML code to be embedded directly
|
||||
in troff documents. The hypertext capabilities are demonstrated by
|
||||
the troff source of the Programmer's Manual that is part of the unroff
|
||||
distribution.
|
||||
|
||||
|
||||
* Availability
|
||||
|
||||
The source distribution of unroff 1.0 as well as binary distributions
|
||||
(with full Scheme source code and documentation) are available under:
|
||||
|
||||
http://www.informatik.uni-bremen.de/~net/unroff/unroff.html#dist
|
||||
|
||||
You can obtain Elk 3.0 from the same WWW server at:
|
||||
|
||||
http://www.informatik.uni-bremen.de/~net/elk
|
||||
|
||||
Elk 3.0 is also available from a number of FTP servers including these:
|
||||
|
||||
ftp://ftp.x.org/contrib/devel_tools/elk-3.0.tar.gz
|
||||
ftp://ftp.uni-bremen.de/pub/programming/languages/scheme/elk/elk-3.0.tar.gz
|
||||
|
||||
|
||||
--
|
||||
Oliver Laumann <net@cs.tu-berlin.de> # $Revision: 1.4 $
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
# $Revision: 1.7 $
|
||||
|
||||
SHELL = /bin/sh
|
||||
UNROFF = unroff
|
||||
|
||||
TROFF = \
|
||||
unroff.1\
|
||||
unroff-html.1\
|
||||
unroff-html-man.1\
|
||||
unroff-html-ms.1\
|
||||
manual.ms
|
||||
|
||||
HTML = \
|
||||
unroff.1.html\
|
||||
unroff-html.1.html\
|
||||
unroff-html-man.1.html\
|
||||
unroff-html-ms.1.html\
|
||||
manual.html
|
||||
|
||||
|
||||
ALL = $(HTML)
|
||||
|
||||
all: $(ALL)
|
||||
|
||||
.SUFFIXES: .1 .1.html
|
||||
|
||||
.1.1.html:
|
||||
$(UNROFF) -man $<
|
||||
|
||||
manual.html: manual.ms
|
||||
$(UNROFF) -ms document=manual hyper.scm $?
|
||||
|
||||
clean:
|
||||
rm -f $(ALL)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,19 @@
|
|||
.\" tmac.hyper: These macros implement hypertext links in troff, that is,
|
||||
.\" they basically do nothing. See scm/misc/hyper.scm for the macros as
|
||||
.\" implemented by unroff.
|
||||
.
|
||||
.ds pk tmac.hyper
|
||||
.
|
||||
.de Er
|
||||
.tm \\*(pk: \\$1 \\$2 \\$3 \\$4 \\$5 \\$6 \\$7 \\$8 \\$9
|
||||
..
|
||||
.
|
||||
.de Ha
|
||||
.if !\\n(.$=2 .Er too few arguments for .Ha
|
||||
\\$2\c
|
||||
..
|
||||
.
|
||||
.de Hr
|
||||
.if \\n(.$<1 .Er too few arguments for .Hr
|
||||
.if !'\\$1'-symbolic' .if !'\\$1'-url' \\$1
|
||||
..
|
||||
|
|
@ -0,0 +1,218 @@
|
|||
.\" $Revision: 1.6 $
|
||||
.ds Ve 1.0
|
||||
.\"
|
||||
.de Ex
|
||||
.RS
|
||||
.nf
|
||||
.nr sf \\n(.f
|
||||
.if !\\n(.U \{\
|
||||
. ft B
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
..
|
||||
.de Ee
|
||||
.if !\\n(.U \{\
|
||||
. ft \\n(sf
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
.fi
|
||||
.RE
|
||||
..
|
||||
.\"
|
||||
.de Sd
|
||||
.ds Dt \\$2
|
||||
..
|
||||
.\"
|
||||
.Sd $Date: 1995/08/23 12:07:31 $
|
||||
.TH unroff-html-man 1 "\*(Dt"
|
||||
.SH NAME
|
||||
unroff-html-man \- back-end to translate manual pages to HTML 2.0
|
||||
.SH SYNOPSIS
|
||||
.B unroff
|
||||
[
|
||||
.B \-fhtml
|
||||
] [
|
||||
.B \-man
|
||||
] [
|
||||
.IR file " | " option...\&
|
||||
]
|
||||
.SH OVERVIEW
|
||||
When called with the
|
||||
.B \-fhtml
|
||||
and
|
||||
.B \-man
|
||||
options, the troff translator
|
||||
.I unroff
|
||||
loads the back-end for converting UNIX manual pages to the Hypertext
|
||||
Markup Language (HTML) version 2.0.
|
||||
.LP
|
||||
Please read
|
||||
.BR unroff (1)
|
||||
first for an overview of the Scheme-based, programmable troff translator
|
||||
and for a description of the generic options that exist in
|
||||
addition to
|
||||
.B \-f
|
||||
and
|
||||
.BR \-m .
|
||||
The translation of basic troff requests, special characters,
|
||||
escape sequences, etc. as well as the HTML-specific options
|
||||
are described in
|
||||
.BR unroff-html (1).
|
||||
For information about extending and programming
|
||||
.I unroff
|
||||
also refer to the
|
||||
.IR "Unroff Programmer's Manual" .
|
||||
.SH OPTIONS
|
||||
The
|
||||
.B \-man
|
||||
extension provides one new keyword/value option in addition to
|
||||
those listed in
|
||||
.BR unroff (1)
|
||||
and
|
||||
.BR unroff-html (1):
|
||||
.TP
|
||||
.BR do-signature " (boolean)"
|
||||
If set to 1, a signature is appended to each output file.
|
||||
The signature is composed of a horizontal rule and a one-line
|
||||
message consisting of version information and date and time.
|
||||
The default value of this option is 1.
|
||||
.SH DESCRIPTION
|
||||
.I unroff
|
||||
reads and parses its input files (each containing a UNIX manual
|
||||
page); the HTML output is written to a separate output file
|
||||
for each input file.
|
||||
The name of an output file is obtained by appending the
|
||||
suffix \*(lq.html\*(rq to the name of the corresponding input
|
||||
file.
|
||||
Any
|
||||
.B document
|
||||
option is ignored if input files are named in the command line.
|
||||
As usual, the special file name
|
||||
.RB ` \- '
|
||||
can be used to interpolate standard input.
|
||||
.LP
|
||||
If no file name is given in the command line, a manual page
|
||||
is read from standard input and sent to standard output,
|
||||
unless the
|
||||
.B document
|
||||
option is given, in which case the HTML output is written
|
||||
to the specified file (with \*(lq.html\*(rq appended).
|
||||
Example:
|
||||
this call to
|
||||
.I unroff
|
||||
translates two manual pages and creates two corresponding output files,
|
||||
.B cc.1.html
|
||||
and
|
||||
.BR send.2.html :
|
||||
.Ex
|
||||
unroff \-fhtml \-man /usr/man/man1/cc.1 /usr/man/man2/send.2
|
||||
.Ee
|
||||
.LP
|
||||
The following
|
||||
.B \-man
|
||||
macros are recognized and translated (in addition to any user-defined macros):
|
||||
.LP
|
||||
.nf
|
||||
.if !\n(.U .ta 8n 16n 24n 32n 40n 48n 56n
|
||||
.TH .SH .SS .I .B .SB .SM
|
||||
.BI .BR .IB .IR .RB .RI .TP
|
||||
.IP .HP .RS .RE .LP .PP .P
|
||||
.fi
|
||||
.LP
|
||||
In addition, the following Sun-specific macros are silently
|
||||
ignored (.TX generates an informational message containing
|
||||
its argument):
|
||||
.LP
|
||||
.nf
|
||||
.TX .IX .DT .PD .UC
|
||||
.fi
|
||||
.LP
|
||||
The following predefined troff strings are recognized
|
||||
(\e*S expands to the empty string):
|
||||
.LP
|
||||
.nf
|
||||
\e*R \e*S \e*(lq \e*(rq
|
||||
.fi
|
||||
.LP
|
||||
The title of each HTML document generated is obtained by calling
|
||||
the primitive
|
||||
.I substitute
|
||||
(as explained in the Programmer's Manual) with the value of the option
|
||||
.B title
|
||||
and the first and second arguments passed to the initial call to
|
||||
.BR .TH .
|
||||
Thus, the specifiers \*(lq%1%\*(rq and \*(lq%2%\*(rq can be used
|
||||
in the option to interpolate the command (or whatever is documented
|
||||
in the manual page) and the section number.
|
||||
If
|
||||
.B title
|
||||
has not been specified, the string \*(lqManual page for %1%(%2%)\*(rq
|
||||
is taken.
|
||||
As generating the HTML title element is deferred until the call to
|
||||
.BR .TH ,
|
||||
any macros or other troff requests that produce output must not be
|
||||
used before the initial
|
||||
.BR .TH .
|
||||
.LP
|
||||
HTML header elements <h2> and <h3> are created for
|
||||
.B .SH
|
||||
and
|
||||
.B .SS
|
||||
requests.
|
||||
The markup created for the initial NAME section differs in that the
|
||||
contents of the section (usually a single line) is itself placed
|
||||
inside a header element.
|
||||
.LP
|
||||
The font switching macros are based on changes to the fonts `R',
|
||||
`I', and `B', as explained under FONTS in
|
||||
.BR unroff-html (1).
|
||||
Of course, this fails if the fonts (which are mounted on startup)
|
||||
are unmounted by explicit
|
||||
.B .fp
|
||||
requests.
|
||||
As HTML is lacking the concept of text size, the macro
|
||||
.B .SB
|
||||
is just an alias for
|
||||
.BR .B ,
|
||||
and
|
||||
.B .SM
|
||||
simply echoes its arguments.
|
||||
.LP
|
||||
The translation rules for
|
||||
.B .TP
|
||||
and
|
||||
.B .IP
|
||||
employ a heuristic to determine whether to generate a definition
|
||||
list or an unordered list:
|
||||
if the first in a sequence of tagged/indented paragraph macros is
|
||||
called with a tag consisting of the special character \e(bu, a
|
||||
definition list is begun, otherwise an unordered list.
|
||||
Subsequent invocations cause the list style to change if appropriate.
|
||||
Use of tagged paragraphs inside non-filled (pre-formatted) text
|
||||
violates the HTML definition and should be avoided.
|
||||
A warning message is printed in this and other questionable situations.
|
||||
.LP
|
||||
As hanging tags cannot be realized with HTML 2.0,
|
||||
a kludge is used for the
|
||||
.B .HP
|
||||
(hanging paragraph) macro:
|
||||
the macro starts a definition list (as does the ordinary
|
||||
.BR .TP
|
||||
macro), and everything up to the next request that causes a break
|
||||
is placed inside the definition tag.
|
||||
This method obviously fails if no break occurs in subsequent lines,
|
||||
but it works for the common, idiomatic use of hanging paragraphs
|
||||
in manual pages.
|
||||
.SH "SEE ALSO"
|
||||
.BR unroff (1),
|
||||
.BR unroff-html (1),
|
||||
.BR troff (1),
|
||||
.BR man "(5 or 7)."
|
||||
.LP
|
||||
Unroff Programmer's Manual.
|
||||
.LP
|
||||
http://www.informatik.uni-bremen.de/~net/unroff
|
||||
.LP
|
||||
Berners-Lee, Connolly, et al.,
|
||||
HyperText Markup Language Specification\(em2.0,
|
||||
Internet Draft, Internet Engineering Task Force.
|
||||
|
|
@ -0,0 +1,324 @@
|
|||
.\" $Revision: 1.8 $
|
||||
.ds Ve 1.0
|
||||
.\"
|
||||
.de Ex
|
||||
.RS
|
||||
.nf
|
||||
.nr sf \\n(.f
|
||||
.if !\\n(.U \{\
|
||||
. ft B
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
..
|
||||
.de Ee
|
||||
.if !\\n(.U \{\
|
||||
. ft \\n(sf
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
.fi
|
||||
.RE
|
||||
..
|
||||
.\"
|
||||
.de Sd
|
||||
.ds Dt \\$2
|
||||
..
|
||||
.\"
|
||||
.Sd $Date: 1995/08/23 12:07:31 $
|
||||
.TH unroff-html-ms 1 "\*(Dt"
|
||||
.SH NAME
|
||||
unroff-html-ms \- back-end to translate `ms' documents to HTML 2.0
|
||||
.SH SYNOPSIS
|
||||
.B unroff
|
||||
[
|
||||
.B \-fhtml
|
||||
] [
|
||||
.B \-ms
|
||||
] [
|
||||
.IR file " | " option...\&
|
||||
]
|
||||
.SH OVERVIEW
|
||||
When called with the
|
||||
.B \-fhtml
|
||||
and
|
||||
.B \-ms
|
||||
options, the troff translator
|
||||
.I unroff
|
||||
loads the back-end for converting \*(lqms\*(rq documents to the Hypertext
|
||||
Markup Language (HTML) version 2.0.
|
||||
.LP
|
||||
Please read
|
||||
.BR unroff (1)
|
||||
first for an overview of the Scheme-based, programmable troff translator
|
||||
and for a description of the generic options that exist in
|
||||
addition to
|
||||
.B \-f
|
||||
and
|
||||
.BR \-m .
|
||||
The translation of basic troff requests, special characters,
|
||||
escape sequences, etc. as well as the HTML-specific options
|
||||
are described in
|
||||
.BR unroff-html (1).
|
||||
For information about extending and programming
|
||||
.I unroff
|
||||
also refer to the
|
||||
.IR "Unroff Programmer's Manual" .
|
||||
.SH OPTIONS
|
||||
The
|
||||
.B \-ms
|
||||
extension provides a number of keyword/value options in addition to
|
||||
those listed in
|
||||
.BR unroff (1)
|
||||
and
|
||||
.BR unroff-html (1):
|
||||
.TP
|
||||
.BR signature " (string)"
|
||||
If non-empty, the value of this option together with a <hr> tag is
|
||||
appended to each HTML output file created.
|
||||
The
|
||||
.I substitute
|
||||
Scheme primitive (as described in the Programmer's Manual) is
|
||||
applied to the value of the option, so that date, time, environment
|
||||
variables, etc. can be interpolated.
|
||||
.TP
|
||||
.BR split " (integer)"
|
||||
This option specifies whether to split the output document into
|
||||
individual files for each major section.
|
||||
If a positive integer
|
||||
.I level
|
||||
is assigned to the option, a new output file is opened for each
|
||||
numbered header
|
||||
.RB ( .NH
|
||||
request) with a level equal to or numerically less than
|
||||
.IR level .
|
||||
Use of this feature requires that the
|
||||
.B document
|
||||
option has bee set, as otherwise the HTML document is sent
|
||||
to standard output.
|
||||
The default value is 0, i.\|e. all sections will be written to
|
||||
a single file.
|
||||
.TP
|
||||
.BR toc " (boolean)"
|
||||
If true, a table of contents with a hypertext link for each section
|
||||
is generated automatically and inserted after the front matter
|
||||
(title, author information, abstract) and before the first section.
|
||||
Use of this feature requires a non-zero value for the
|
||||
.B split
|
||||
option.
|
||||
The default is to produce a table of contents if
|
||||
.B split
|
||||
is non-zero.
|
||||
.TP
|
||||
.BR toc-header " (string)"
|
||||
This option defines the contents of the <h2> header element prepended to
|
||||
an automatically generated table of contents.
|
||||
Its value is subject to a call to
|
||||
.IR substitute .
|
||||
The default is the string \*(lqTable of Contents\*(rq.
|
||||
.TP
|
||||
.BR pp-indent " (integer)"
|
||||
The number of non-breakable spaces (as specified by the predefined
|
||||
Scheme variable
|
||||
.IR nbsp )
|
||||
to generate for a paragraph created by the
|
||||
.B .PP
|
||||
macro.
|
||||
The default is 3.
|
||||
This option, as well as
|
||||
.BR signature ,
|
||||
is typically set in the user-preferences file
|
||||
.BR ~/.unroff ,
|
||||
or in a document-specific Scheme file or at the beginning of
|
||||
the document proper.
|
||||
.TP
|
||||
.BR footnotes-header " (string)"
|
||||
The contents of the <h2> header element prepended to the footnotes
|
||||
section that is appended to the document if any footnotes were used,
|
||||
and that also appears in the automatically generated table of contents.
|
||||
As with all string option listed in this section, the
|
||||
.I substitute
|
||||
primitive is applied to the option's value.
|
||||
The default is the string \*(lqFootnotes\*(rq.
|
||||
.TP
|
||||
.BR footnote-reference " (string)"
|
||||
This option controls the text generated by each use of the variable
|
||||
\&`\e**', which produces a footnote (hypertext) reference.
|
||||
Its value is passed to a call to
|
||||
.I substitute
|
||||
with the current footnote number as another argument, so that the
|
||||
specifier \*(lq%1%\*(rq can be used to interpolate the footnote
|
||||
number.
|
||||
The default is the string \*(lq[note %1%]\*(rq.
|
||||
.TP
|
||||
.BR footnote-anchor " (string)"
|
||||
This options specifies the footnote reference that appears at the
|
||||
beginning of each footnote proper if
|
||||
.B .FS
|
||||
was called without an argument.
|
||||
The option's value is passed to a call to
|
||||
.I substitute
|
||||
with the footnote number generated by the last use of `\e**' as
|
||||
another argument.
|
||||
The default is \*(lq[%1%]\*(rq.
|
||||
.SH FILES
|
||||
.I unroff
|
||||
reads and parses an \*(rqms\*(lq document composed of one ore more
|
||||
input files.
|
||||
As usual, the special file name
|
||||
.RB ` \- '
|
||||
can be used to interpolate standard input.
|
||||
If no file name is given in the command line,
|
||||
.I unroff
|
||||
reads from standard input.
|
||||
.LP
|
||||
The resulting HTML document is sent to standard output, unless a
|
||||
file name prefix is assigned to the
|
||||
.B document
|
||||
option.
|
||||
In the latter case, the
|
||||
.B split
|
||||
option controls splitting of the output into separate files at
|
||||
section boundaries as described under OPTIONS above.
|
||||
A number of other features, such as footnotes, also require
|
||||
that the
|
||||
.B document
|
||||
option is supplied, as separate output files are created for them
|
||||
(regardless of the value of
|
||||
.BR split ).
|
||||
In any case, the name of each output file consists of the value of
|
||||
.BR document ,
|
||||
followed by an optional suffix, followed by the extension \*(lq.html\*(rq.
|
||||
.SH EXAMPLE
|
||||
To translate an \*(lqms\*(rq document composed of several
|
||||
input files,
|
||||
.I unroff
|
||||
could be invoked like this:
|
||||
.Ex
|
||||
.if n \{unroff \-fhtml \-ms document=thesis split=2\e
|
||||
intro.ms 1.ms 2.ms 3.ms app.ms\}
|
||||
.if !n unroff \-fhtml \-ms document=thesis split=2 intro.ms 1.ms 2.ms 3.ms app.ms
|
||||
.Ee
|
||||
The names of all output files will have the prefix \*(lqthesis\*(rq,
|
||||
and the resulting HTML document will be split into separate files
|
||||
at each level 1 section or level 2 section.
|
||||
.SH DESCRIPTION
|
||||
The following
|
||||
.B \-ms
|
||||
macros are translated (in addition to any user-defined macros):
|
||||
.LP
|
||||
.nf
|
||||
.if !\n(.U .ta 8n 16n 24n 32n 40n 48n 56n
|
||||
.AB .AE .AI .AU .B .B1 .B2
|
||||
.BD .BX .CD .DE .DS .FA .FE
|
||||
.FS .I .ID .IP .LD .LG .LP
|
||||
.NH .PP .PX .QP .R .RE .RS
|
||||
.RT .SH .SM .TL .UL .UX .XA
|
||||
.XE .XS
|
||||
.fi
|
||||
.LP
|
||||
These predefined strings and number registers are recognized:
|
||||
.LP
|
||||
.nf
|
||||
\e*- \e*(DY \e*(MO \e*Q \e*U \en(PN
|
||||
.fi
|
||||
.LP
|
||||
In addition, a number of macros are either silently ignored
|
||||
or cause a warning to be printed, because their function either
|
||||
cannot be mapped to HTML 2.0 elements or assumes a page
|
||||
structure:
|
||||
.LP
|
||||
.nf
|
||||
.AM .BT .CM .CT .DA .EF .EH
|
||||
.HD .KE .KF .KS .ND .NL .OF
|
||||
.OH .P1 .PT .TM .MC .1C .2C
|
||||
.fi
|
||||
.LP
|
||||
The font switching macros are based on changes to the fonts `R',
|
||||
`I', and `B', as explained under FONTS in
|
||||
.BR unroff-html (1).
|
||||
Of course, this fails if the fonts (which are mounted on startup)
|
||||
are unmounted by explicit
|
||||
.B .fp
|
||||
requests.
|
||||
.LP
|
||||
Upper or lower case letters are accepted as section numbers by
|
||||
.B .NH
|
||||
when the argument ``S'' is used to set new section numbers.
|
||||
This is useful for appendices and similar constructs.
|
||||
.LP
|
||||
The translation rule for
|
||||
.B .IP
|
||||
employs a heuristic to determine whether to generate a definition
|
||||
list or an unordered list:
|
||||
if the first in a sequence of indented paragraph macros is
|
||||
called with a tag consisting of one of the special character \e(bu
|
||||
or \e(sq, a definition list is begun, otherwise an unordered list.
|
||||
Since
|
||||
.RI exdented[ sic ]
|
||||
paragraphs cannot be expressed in HTML 2.0, a warning
|
||||
message is printed when a call to the macro
|
||||
.B .XP
|
||||
is encountered.
|
||||
.LP
|
||||
All footnotes are concatenated and placed in a separate output file,
|
||||
and a corresponding section (with a user-defined header) holding
|
||||
the footnotes is appended to the document automatically.
|
||||
Use of the string `\e**' generates a hypertext link to the beginning
|
||||
of the footnote created by the next call to
|
||||
.B .FS
|
||||
and
|
||||
.BR .FE .
|
||||
The actual text generated by using `\e**' as well as the footnote
|
||||
reference that appears in the footnote proper are controlled by
|
||||
two options as explained under OPTIONS above.
|
||||
A warning message is printed on termination if `\e**' has been
|
||||
used but a corresponding footnote was not seen.
|
||||
As an alternative to `\e**', the new request
|
||||
.B .FA
|
||||
can be used to produce a footnote anchor together with a hypertext
|
||||
link; the anchor is the argument to the macro
|
||||
(however, `\e**' itself must not be used in a call to
|
||||
.BR .FA ).
|
||||
.LP
|
||||
Likewise, a hypertext reference is created for each use of the
|
||||
table of contents macros
|
||||
.BR .XS
|
||||
and
|
||||
.BR .XE
|
||||
(optionally accompanied by calls to
|
||||
.BR .XA ).
|
||||
.SH "SEE ALSO"
|
||||
.BR unroff (1),
|
||||
.BR unroff-html (1),
|
||||
.BR troff (1),
|
||||
.BR ms "(5 or 7)."
|
||||
.LP
|
||||
Unroff Programmer's Manual.
|
||||
.LP
|
||||
http://www.informatik.uni-bremen.de/~net/unroff
|
||||
.LP
|
||||
Berners-Lee, Connolly, et al.,
|
||||
HyperText Markup Language Specification\(em2.0,
|
||||
Internet Draft, Internet Engineering Task Force.
|
||||
.SH BUGS
|
||||
The macro
|
||||
.B .UL
|
||||
is currently mapped to a call to
|
||||
.BR .I ,
|
||||
as underlining is not supported by the HTML back-end of
|
||||
.I unroff
|
||||
\*(Ve.
|
||||
.LP
|
||||
Footnote references and requests such as
|
||||
.B .sp
|
||||
that cause non-character-level markup to be generated must not
|
||||
be used inside a numbered header.
|
||||
.LP
|
||||
When creating a hypertext anchor for
|
||||
.B .XS
|
||||
and
|
||||
.BR .XE ,
|
||||
there is nothing to put inside the <a> element;
|
||||
therefore a non-breaking space is used.
|
||||
.LP
|
||||
Changing the number register format of `NH' to get roman or alphabetic
|
||||
section numbers does not work, obviously.
|
||||
|
|
@ -0,0 +1,671 @@
|
|||
.\" $Revision: 1.12 $
|
||||
.ds Ve 1.0
|
||||
.\"
|
||||
.de Ex
|
||||
.RS
|
||||
.nf
|
||||
.nr sf \\n(.f
|
||||
.if !\\n(.U \{\
|
||||
. ft B
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
..
|
||||
.de Ee
|
||||
.if !\\n(.U \{\
|
||||
. ft \\n(sf
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
.fi
|
||||
.RE
|
||||
..
|
||||
.\"
|
||||
.de Sd
|
||||
.ds Dt \\$2
|
||||
..
|
||||
.\"
|
||||
.Sd $Date: 1995/08/23 12:07:31 $
|
||||
.TH unroff-html 1 "\*(Dt"
|
||||
.SH NAME
|
||||
unroff-html \- HTML 2.0 back-end for the programmable troff translator
|
||||
.SH SYNOPSIS
|
||||
.B unroff
|
||||
[
|
||||
.B \-fhtml
|
||||
] [
|
||||
.BI \-m package
|
||||
] [
|
||||
.IR file " | " option...\&
|
||||
]
|
||||
.SH OVERVIEW
|
||||
When called with the
|
||||
.B \-fhtml
|
||||
option,
|
||||
.I unroff
|
||||
loads the back-end for the Hypertext Markup Language (HTML) version 2.0.
|
||||
Please read
|
||||
.BR unroff (1)
|
||||
first for an overview of the Scheme-based, programmable troff translator
|
||||
and for a description of the generic options that exist in
|
||||
addition to
|
||||
.B \-f
|
||||
and
|
||||
.BR \-m .
|
||||
For information about extending and programming
|
||||
.I unroff
|
||||
also refer to the
|
||||
.IR "Unroff Programmer's Manual" .
|
||||
.LP
|
||||
.I unroff
|
||||
is usually invoked with an additional
|
||||
.BI \-m package
|
||||
option (such as
|
||||
.B \-ms
|
||||
or
|
||||
.BR \-man )
|
||||
to load the translation rules for the troff macros and other elements
|
||||
defined by the macro package that is used to typeset the document.
|
||||
If no
|
||||
.B \-m
|
||||
option is supplied, only the standard troff requests, special characters,
|
||||
escape sequences, etc. are recognized and translated to HTML by
|
||||
.I unroff
|
||||
as described in this manual.
|
||||
.SH OPTIONS
|
||||
The following HTML-specific options can be specified in the command
|
||||
line after the generic options.
|
||||
See
|
||||
.BR unroff (1)
|
||||
for a general description of keyword/value options and their types
|
||||
and for a list of options that are not specific to the target language.
|
||||
.TP
|
||||
.BR title " (string)"
|
||||
The value to be used for the <title> element in HTML output files.
|
||||
This option may be ignored by the code implementing a specific
|
||||
macro set, e.\|g. when special rules are employed to derive the title
|
||||
from the contents of the troff input files.
|
||||
Whether or not this option is required also depends on the specific
|
||||
.B \-m
|
||||
option used, but it may be omitted if no
|
||||
.B \-m
|
||||
option is given.
|
||||
.TP
|
||||
.BR document " (string)"
|
||||
The prefix used for the names of all output files.
|
||||
May be ignored depending on the macro package that has been selected.
|
||||
.TP
|
||||
.BR mail-address " (string)"
|
||||
The caller's mail address; may be used for \*(lqmailto:\*(rq URLs,
|
||||
in particular for the \*(lqhref\*(rq attribute of the <link>
|
||||
element that is usually generated.
|
||||
.TP
|
||||
.BR tt-preformat " (boolean)"
|
||||
If 1, font changes to a font that is mapped to the <tt> element
|
||||
are honored inside non-filled text (as described below).
|
||||
The default is 0, i.\|e. the font changes will be recorded, but no
|
||||
corresponding HTML tags will be emitted for them.
|
||||
.TP
|
||||
.BR handle-eqn " (string)"
|
||||
.TP
|
||||
.BR handle-tbl " (string)"
|
||||
.TP
|
||||
.BR handle-pic " (string)"
|
||||
These options specify how equations, tables, and pictures encountered
|
||||
in the troff input are processed.
|
||||
Possible values are \*(lqcopy\*(rq to include the raw eqn, tbl, or
|
||||
pic commands as pre-formatted text, \*(lqtext\*(rq to run the
|
||||
respective troff preprocessor (eqn, tbl, or pic) and include its output
|
||||
as pre-formatted text, or \*(lqgif\*(rq to convert the preprocessor
|
||||
output to a GIF image and include it in the HTML document as
|
||||
an inline image.
|
||||
The default is \*(lqtext\*(rq for
|
||||
.BR handle-tbl ,
|
||||
\*(lqgif\*(rq for the other options.
|
||||
See DESCRIPTION below for more information.
|
||||
.TP
|
||||
.BR eqn " (string)"
|
||||
.TP
|
||||
.BR tbl " (string)"
|
||||
.TP
|
||||
.BR pic " (string)"
|
||||
These options specify the programs to invoke as the eqn, tbl,
|
||||
and pic preprocessors.
|
||||
The defaults are site-dependent.
|
||||
.TP
|
||||
.BR troff-to-text " (string)"
|
||||
.TP
|
||||
.BR troff-to-gif " (string)"
|
||||
The programs to invoke for converting the output of a troff preprocessor
|
||||
to plain text or to a GIF image.
|
||||
The default values are site-dependent.
|
||||
See DESCRIPTION below for more information on these options.
|
||||
.SH FILES
|
||||
If no
|
||||
.B \-m
|
||||
option is supplied,
|
||||
.I unroff
|
||||
reads the specified input files and sends the HTML document to
|
||||
standard output, unless the
|
||||
.B document
|
||||
option is given, in which case its value together
|
||||
with the suffix \*(lq.html\*(rq is used as the name of an
|
||||
output file.
|
||||
If no input files are specified, input is taken from standard input.
|
||||
The output is enclosed by the usual HTML boiler-plate (<html>, <head>,
|
||||
and <body> elements), a <title> element with the specified title
|
||||
(or the value of
|
||||
.B document
|
||||
if no title has been given, or a default title if both are omitted),
|
||||
a <link> element with rev= and href= attributes if
|
||||
.B mail-address
|
||||
has been set, and any pending end tags are generated on end of input.
|
||||
.LP
|
||||
Note that this is the default action that is performed in the
|
||||
rare case when no macro package name has been specified, i.\|e. when
|
||||
processing \*(lqbare\*(rq troff input.
|
||||
Somewhat different rules may apply when processing, for
|
||||
example, a group of UNIX manual pages
|
||||
.RB ( \-man ).
|
||||
.LP
|
||||
See
|
||||
.BR unroff (1)
|
||||
for a list of Scheme files that are loaded on startup.
|
||||
.SH DESCRIPTION
|
||||
.SS "OUTPUT TRANSLATIONS"
|
||||
The characters `<', `>', and `&' are replaced by the entities
|
||||
`<', `>', and `&' on output.
|
||||
In addition, the quote character is mapped to `"' where
|
||||
appropriate.
|
||||
New mappings can be added by means of the
|
||||
.I defchar
|
||||
Scheme primitive as explained in the Programmer's Manual.
|
||||
.SS COMMENTS
|
||||
each troff comment is translated to a corresponding HTML tag
|
||||
followed by a newline; empty comments are ignored.
|
||||
Comments are also ignored when appearing inside a macro body.
|
||||
.SS "ESCAPE SEQUENCES"
|
||||
The following is a list of troff escape sequences that are recognized
|
||||
and the HTML output generated for them.
|
||||
Any escape sequence that does not appear in the list
|
||||
expands to the character after the escape character, and
|
||||
a warning is printed in this case.
|
||||
New definitions can be added and the predefined mappings can
|
||||
be replaced by calling the
|
||||
.I defescape
|
||||
Scheme primitive in the user's initialization file, in a user-supplied
|
||||
Scheme file, in a document, or on a site-wide basis by modifying
|
||||
the file
|
||||
.B scm/html/common.scm
|
||||
in the installation directory.
|
||||
.LP
|
||||
.nf
|
||||
.if !\n(.U .ta 8n 16n 24n 32n 40n 48n 56n
|
||||
\e& nothing
|
||||
\e- -
|
||||
\e| nothing
|
||||
\e^ nothing
|
||||
\e\e \e
|
||||
\e' '
|
||||
\e` `
|
||||
\e" rest of line as HTML comment tag
|
||||
\e% nothing
|
||||
\e{ conditional input begin
|
||||
\e} conditional input end
|
||||
\e* contents of string
|
||||
\espace space
|
||||
\e0 space
|
||||
\ec nothing; eats following newline
|
||||
\ee \e
|
||||
\es nothing
|
||||
\eu nothing, prints warning
|
||||
\ed nothing, prints warning
|
||||
\ev nothing, prints warning
|
||||
\eo its argument, prints warning
|
||||
\ez its argument, prints warning
|
||||
\ek sets specified register to zero
|
||||
\eh appropriate number of spaces for positive argument
|
||||
\ew length of argument in units
|
||||
\el repeats specified character, or <hr>
|
||||
\en contents of number register
|
||||
\ef see description of fonts below
|
||||
.fi
|
||||
.SS "SPECIAL CHARACTERS"
|
||||
The following special characters are mapped to their equivalent
|
||||
ISO-Latin 1 entities:
|
||||
.LP
|
||||
.nf
|
||||
\e(12 \e(14 \e(34 \e(*b \e(*m \e(+- \e(:A
|
||||
\e(:O \e(:U \e(:a \e(:o \e(:u \e(A: \e(Cs
|
||||
\e(O: \e(Po \e(S1 \e(S2 \e(S3 \e(U: \e(Ye
|
||||
\e(a: \e(bb \e(cd \e(co \e(ct \e(de \e(di
|
||||
\e(es \e(hy \e(mu \e(no \e(o: \e(r! \e(r?
|
||||
\e(rg \e(sc \e(ss \e(tm \e(u:
|
||||
.fi
|
||||
.LP
|
||||
Heuristics have to be used for the following special characters:
|
||||
.LP
|
||||
.nf
|
||||
\e(** *
|
||||
\e(-> ->
|
||||
\e(<- <-
|
||||
\e(<= <=
|
||||
\e(== ==
|
||||
\e(>= >=
|
||||
\e(Fi ffi
|
||||
\e(Fl ffl
|
||||
\e(aa '
|
||||
\e(ap ~
|
||||
\e(br |
|
||||
\e(bu + (prints a warning)
|
||||
\e(bv |
|
||||
\e(ci O
|
||||
\e(dd *** (prints a warning)
|
||||
\e(dg ** (prints a warning)
|
||||
\e(em --
|
||||
\e(en -
|
||||
\e(eq =
|
||||
\e(ff ff
|
||||
\e(fi fi
|
||||
\e(fl fl
|
||||
\e(fm '
|
||||
\e(ga `
|
||||
\e(lh <=
|
||||
\e(lq ``
|
||||
\e(mi -
|
||||
\e(or |
|
||||
\e(pl +
|
||||
\e(rh =>
|
||||
\e(rq ''
|
||||
\e(ru _
|
||||
\e(sl /
|
||||
\e(sq o (prints a warning)
|
||||
\e(ul _
|
||||
\e(~= ~
|
||||
.fi
|
||||
.LP
|
||||
A warning is printed to standard error output for any special
|
||||
character not mentioned in this section.
|
||||
To add new definitions, and to customize existing ones, the
|
||||
.I defspecial
|
||||
Scheme primitive can be used.
|
||||
.SS "NON-FILLED TEXT"
|
||||
The
|
||||
.B .nf
|
||||
and
|
||||
.B .fi
|
||||
troff requests generate pairs of <pre> and </pre> tags.
|
||||
Nested requests are treated correctly, and currently
|
||||
active character formatting elements such as <i> (resulting
|
||||
from troff font changes) are temporarily disabled while
|
||||
the <pre> or </pre> is emitted.
|
||||
A warning is printed if a \*(lqtab\*(rq character is encountered
|
||||
within filled text.
|
||||
.SS FONTS
|
||||
The `\ef' escape sequence and the requests
|
||||
.B .ft
|
||||
(change current font) and
|
||||
.B .fp
|
||||
(mount font at font position) are supported in the usual way,
|
||||
both with numeric font positions as well as font names and
|
||||
the special name `P' to denote the previous font.
|
||||
The font position of the currently active font is available
|
||||
through the read-only number register `.f'.
|
||||
Initially, the font `R' is mounted on font positions 1 and 4,
|
||||
font `I' on font position 2, and font `B' on position 3.
|
||||
.LP
|
||||
To map troff font names to HTML character formatting elements,
|
||||
the \f2define-font\fP Scheme procedure is called with the name
|
||||
of a troff font to be used in documents, and
|
||||
HTML start and end tags to be emitted when changing to this font,
|
||||
or when changing
|
||||
.I from
|
||||
this font to another font, respectively.
|
||||
Whether <tt> and </tt> is generated inside non-filled (pre-formatted)
|
||||
text for fixed-width fonts is controlled by the option
|
||||
.BR tt-preformat .
|
||||
The following calls to
|
||||
.I define-font
|
||||
are evaluated on startup:
|
||||
.LP
|
||||
.nf
|
||||
.if !\n(.U \{\
|
||||
. ft C
|
||||
. ps -1
|
||||
. vs -1 \}
|
||||
(define-font "R" "" "")
|
||||
(define-font "I" '<i> '</i>)
|
||||
(define-font "B" '<b> '</b>)
|
||||
(define-font "C" '<tt> '</tt>)
|
||||
(define-font "CW" '<tt> '</tt>)
|
||||
(define-font "CO" '<i> '</i>) ; kludge for Courier-Oblique
|
||||
.if !\n(.U \{\
|
||||
. ft
|
||||
. ps
|
||||
. vs \}
|
||||
.fi
|
||||
.LP
|
||||
Site administrators may add definitions here for fonts used
|
||||
at their site.
|
||||
Users can define mappings for new fonts by placing corresponding
|
||||
definitions in their documents or document-specific Scheme files.
|
||||
.SS "OTHER TROFF REQUESTS"
|
||||
The
|
||||
.B .br
|
||||
request generates a <br> tag.
|
||||
.LP
|
||||
.B .sp
|
||||
requires a positive argument and is mapped to the appropriate number
|
||||
of <p> tags (or newline characters inside non-filled/pre-formatted
|
||||
text).
|
||||
Likewise, the request
|
||||
.BR .ti ,
|
||||
when called with a positive indent, produces a <br> followed by the
|
||||
appropriate number of non-breakable spaces.
|
||||
.LP
|
||||
The
|
||||
.B .tl
|
||||
requests justs emits the title parts delimited by spaces.
|
||||
It is impossible to preserve the meaning of this request
|
||||
in HTML 2.0.
|
||||
.LP
|
||||
The horizontal line drawing escape sequence `\el' just repeats
|
||||
the specified character (or underline as default) to draw
|
||||
a line.
|
||||
If the given length looks like it could be the line length
|
||||
(that is, if it exceeds a certain value), a <hr> tag
|
||||
is produced instead.
|
||||
Example:
|
||||
.LP
|
||||
.nf
|
||||
\el'5c\e&-'
|
||||
\el'60'
|
||||
.fi
|
||||
.LP
|
||||
The first of these two requests
|
||||
would produce a line of 20 dashes, while the second
|
||||
request would generate a <hr> tag (the '\e&' is required
|
||||
because the dash could be interpreted as a continuation of
|
||||
the numeric expression).
|
||||
.LP
|
||||
Centering
|
||||
.RB ( .ce )
|
||||
is simulated by producing a <br> at the end of each line, as
|
||||
this functionality is not supported by HTML 2.0.
|
||||
.LP
|
||||
The following requests are silently ignored; as the corresponding
|
||||
functions cannot be expressed in HTML 2.0 or are controlled by
|
||||
the client.
|
||||
Ignoring these requests most likely does no harm.
|
||||
.LP
|
||||
.nf
|
||||
.ad .bp .ch .fl .hw .hy .lg
|
||||
.na .ne .nh .ns .pl .ps .rs
|
||||
.vs .wh
|
||||
.fi
|
||||
.LP
|
||||
All troff requests not mentioned in this section by default
|
||||
cause a warning message to be printed to standard error output,
|
||||
except for these basic requests which have their usual
|
||||
semantics:
|
||||
.LP
|
||||
.nf
|
||||
.am .as .de .ds .ec .el .ie
|
||||
.if .ig .nr .rm .rr .so .tm
|
||||
.fi
|
||||
.LP
|
||||
The
|
||||
.I defrequest
|
||||
Scheme primitive is used to associate an event handling procedure
|
||||
with a request as documented in the Programmer's Manual.
|
||||
.SS "END OF SENTENCE"
|
||||
The sequence \*(lq<tt>space</tt>\*(rq is produced at the end of
|
||||
each sentence to provide additional space, except inside non-filled text.
|
||||
A sentence is defined a sequence of characters followed by
|
||||
a period, a question mark, or an exclamation mark, followed
|
||||
by a newline.
|
||||
The usual convention to suppress end-of-sentence recognition
|
||||
by adding the escape sequence `\e&' is correctly implemented by
|
||||
.IR unroff .
|
||||
To change the end-of-sentence function, the
|
||||
.I sentence-event
|
||||
can be redefined from within Scheme code as described in
|
||||
the Programmer's Manual.
|
||||
.SS "SCALE INDICATORS"
|
||||
As the notions of vertical spacing, character width, device
|
||||
resolution, etc. do not exist in HTML, the scaling for the
|
||||
usual troff scale indicators is defined once on startup and
|
||||
then remains constant.
|
||||
For simplicity, the scaling usually employed by
|
||||
.BR nroff (1)
|
||||
is taken.
|
||||
.SS "EQUATIONS, TABLES, PICTURES"
|
||||
Interpretation of embedded eqn, tbl, and pic preprocessor input
|
||||
is controlled by the options
|
||||
.BR handle-eqn ,
|
||||
.BR handle-tbl ,
|
||||
and
|
||||
.B handle-pic
|
||||
(see OPTIONS above).
|
||||
These options affect the input lines from a starting
|
||||
.BR .EQ ,
|
||||
.BR .TS ,
|
||||
or
|
||||
.B .PS
|
||||
request up to and including the matching
|
||||
.BR .EN ,
|
||||
.BR .TE ,
|
||||
or
|
||||
.B .PE
|
||||
request, as well as text surrounded by the current eqn
|
||||
inline equation delimiters.
|
||||
Each of the options can have one the following values:
|
||||
.TP
|
||||
.B copy
|
||||
The preprocessor input (including the enclosing requests) is
|
||||
placed inside <pre> and </pre>.
|
||||
If assigned to the option
|
||||
.BR handle-eqn ,
|
||||
inline equations are rendered in the font currently mounted
|
||||
on font position 2.
|
||||
.TP
|
||||
.B text
|
||||
The input is sent to the respective preprocessor (as specified
|
||||
by the options
|
||||
.BR eqn ,
|
||||
.BR tbl ,
|
||||
or
|
||||
.BR pic ),
|
||||
and its result is piped to the shell command referred to by the
|
||||
option
|
||||
.BR troff-to-text ,
|
||||
which typically involves a call to
|
||||
.BR nroff (1)
|
||||
or an equivalent command.
|
||||
As with \*(lqcopy\*(rq, the result is then placed inside
|
||||
<pre> and </pre>, unless the source is an inline equation.
|
||||
.IP
|
||||
The value of
|
||||
.B troff-to-text
|
||||
is filtered through a call to the
|
||||
.I substitute
|
||||
Scheme primitive with the name of an output file as its argument;
|
||||
this file name can be referenced from within the option's value
|
||||
by the substitute specifier \*(lq%1%\*(rq (see the Programmer's
|
||||
Manual for a description of
|
||||
.I substitute
|
||||
and a list of substitute specifiers).
|
||||
Here is a typical value for the
|
||||
.B troff-to-text
|
||||
option:
|
||||
.Ex
|
||||
"groff \-Tascii | col \-b | sed '/^[ \et]*$/d' > %1%"
|
||||
.Ee
|
||||
.TP
|
||||
.B gif
|
||||
Input lines are preprocessed as described under \*(lqtext\*(rq, and
|
||||
the result is piped to the shell command named by the option
|
||||
.BR troff-to-gif .
|
||||
The latter is subject to a call to
|
||||
.I substitute
|
||||
with the name of a temporary file (which may be used to store intermediate
|
||||
PostScript output) and the name of the output file where the resulting
|
||||
GIF image must be stored.
|
||||
The entire preprocessor input is replaced by an <img> element with
|
||||
a reference to the GIF file and a suitable \*(lqalt=\*(rq attribute.
|
||||
Unless processing an inline equation, the <img> element is
|
||||
surrounded by <p> tags.
|
||||
.IP
|
||||
The names of the files containing the GIF images are generated
|
||||
from the value of the
|
||||
.B document
|
||||
option, a sequence number, and the suffix \*(lq.gif\*(rq.
|
||||
Therefore, the
|
||||
.B document
|
||||
option must have been set when using the \*(lqgif\*(rq method,
|
||||
otherwise a warning is printed and the preprocessor input
|
||||
is skipped.
|
||||
.LP
|
||||
In any case, the output of a call to eqn is ignored if the
|
||||
input consists of calls to \*(lqdelim\*(rq or \*(lqdefine\*(rq
|
||||
and empty lines exclusively.
|
||||
When processing eqn input, calls to \*(lqdelim\*(rq are intercepted by
|
||||
.I unroff
|
||||
to record changes of the inline equation delimiters.
|
||||
.SS "HYPERTEXT LINKS"
|
||||
The facilities for embedding arbitrary hypertext links in troff
|
||||
documents are still experimental in this version of
|
||||
.I unroff
|
||||
and thus are likely to change in future releases.
|
||||
To use them, mention the file name \*(lqhyper.scm\*(rq in the
|
||||
command line before any troff source files.
|
||||
At the beginning of the first troff file, source the file
|
||||
\*(lqtmac.hyper\*(rq from the directory \*(lqdoc\*(rq like this:
|
||||
.LP
|
||||
.nf
|
||||
.if !\en(.U .so tmac.hyper
|
||||
.fi
|
||||
.LP
|
||||
The request
|
||||
.B .Hr
|
||||
can then be used to create a hypertext link.
|
||||
Its usage is:
|
||||
.LP
|
||||
.nf
|
||||
.Hr -url URL anchor-text [suffix]
|
||||
.Hr -symbolic label anchor-text [suffix]
|
||||
.Hr troff-text
|
||||
.fi
|
||||
.LP
|
||||
The first two forms are recognized by
|
||||
.I unroff
|
||||
and the third form is recognized by troff.
|
||||
The first form is used for links pointing to external resources,
|
||||
and the second one is used for forward or backward links referencing
|
||||
anchors defined in a file belonging to the same document.
|
||||
An anchor is placed in the document by calling the request
|
||||
.BR .Ha :
|
||||
.LP
|
||||
.nf
|
||||
.Ha label anchor-text
|
||||
.fi
|
||||
.LP
|
||||
The label specified in a call to
|
||||
.B .Ha
|
||||
can then be used in calls to
|
||||
.BR ".Hr -symbolic" .
|
||||
All symbolic references must have been resolved at the end of the document.
|
||||
The \*(lqanchor-text\*(rq is placed between the tags <a> and </a>;
|
||||
\*(lqsuffix\*(rq is appended to the closing </a> if present.
|
||||
\*(lqtroff-text\*(rq is just formatted in the normal way.
|
||||
Quotes must be used if any of the arguments contains spaces.
|
||||
.LP
|
||||
Use of the hypertext facilities is demonstrated by the troff source
|
||||
of the Programmer's Manual that is included in the
|
||||
.I unroff
|
||||
distribution.
|
||||
.SH "SCHEME PROCEDURES"
|
||||
The following Scheme procedures, macros, and variables are defined
|
||||
by the HTML 2.0 back-end and can be used from within user-supplied
|
||||
Scheme code:
|
||||
.TP
|
||||
(\f2define-font name start-tag end-tag\fP)
|
||||
Associates a HTML start tag and end tag (symbols) with a troff
|
||||
font name (string) as explained under FONTS above.
|
||||
The font name can then be used in
|
||||
.BR .fp ,
|
||||
.BR .ft ,
|
||||
and `\ef' requests.
|
||||
.TP
|
||||
(\f2reset-font\fP)
|
||||
Resets both the current and previous font to the font mounted
|
||||
on position 1.
|
||||
.TP
|
||||
\f2current-font\fP
|
||||
.TP
|
||||
\f2previous-font\fP
|
||||
These variables hold the current and previous font as
|
||||
(integer) font positions.
|
||||
.TP
|
||||
(\f2with-font-preserved\fP . \f2body\fP)
|
||||
This macro can be used to temporarily change to font \*(lqR\*(rq,
|
||||
evaluate \f2body\fP, and revert to the font that has been
|
||||
active when the form was entered.
|
||||
The macro returns a string that can be output using the
|
||||
primitive \f2emit\fP or returned from an event procedure.
|
||||
.TP
|
||||
(\f2preform enable?\fP)
|
||||
If the argument is #t, pre-formatted text is enabled, otherwise disabled.
|
||||
.TP
|
||||
\f2preform?\fP
|
||||
This boolean variable holds #t if pre-formatted text is enabled,
|
||||
#f otherwise.
|
||||
.TP
|
||||
(\f2with-preform-preserved\fP . \f2body\fP)
|
||||
A macro that can be used to temporarily disable pre-formatted
|
||||
text, evaluate \f2body\fP, and then re-enable it if appropriate.
|
||||
The macro expands to a string that must be output or returned from
|
||||
an event procedure.
|
||||
.TP
|
||||
(\f2parse-unquote string\fP)
|
||||
Temporarily establishes an output translation to map the quote
|
||||
character to \*(lq"\*(rq, applies \f2parse\fP (explained
|
||||
in the Programmer's Manual) to its argument, and returns the result.
|
||||
.TP
|
||||
(\f2center n\fP)
|
||||
Centers the next \f2n\fP input lines (see description of
|
||||
.B .ce
|
||||
under TROFF REQUESTS above).
|
||||
If \f2n\fP is zero, centering is stopped.
|
||||
.TP
|
||||
\f2nbsp\fP
|
||||
A Scheme variable that holds a string interpreted as a non-breaking
|
||||
space by HTML clients.
|
||||
.SH "SEE ALSO"
|
||||
.BR unroff (1),
|
||||
.BR unroff-html-man (1),
|
||||
.BR unroff-html-ms (1);
|
||||
.br
|
||||
.BR troff (1),
|
||||
.BR nroff (1),
|
||||
.BR groff (1),
|
||||
.BR eqn (1),
|
||||
.BR tbl (1),
|
||||
.BR pic (1).
|
||||
.LP
|
||||
Unroff Programmer's Manual.
|
||||
.LP
|
||||
http://www.informatik.uni-bremen.de/~net/unroff
|
||||
.LP
|
||||
Berners-Lee, Connolly, et al.,
|
||||
HyperText Markup Language Specification\(em2.0,
|
||||
Internet Draft, Internet Engineering Task Force.
|
||||
.SH BUGS
|
||||
The `\espace' escape sequence should be mapped to the   entity
|
||||
(non-breaking space), but this entity is not supported by a number
|
||||
of HTML clients.
|
||||
.LP
|
||||
Only the font positions 1 to 9 can currently be used.
|
||||
There should be no limit.
|
||||
.LP
|
||||
The extra space generated for end of sentence should be configurable.
|
||||
.LP
|
||||
Underlining should be supported.
|
||||
|
|
@ -0,0 +1,682 @@
|
|||
.\" $Revision: 1.16 $
|
||||
.ds Ve 1.0
|
||||
.\"
|
||||
.de Ex
|
||||
.RS
|
||||
.nf
|
||||
.nr sf \\n(.f
|
||||
.if !\\n(.U \{\
|
||||
. ft B
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
..
|
||||
.de Ee
|
||||
.if !\\n(.U \{\
|
||||
. ft \\n(sf
|
||||
. if n .sp
|
||||
. if t .sp .5 \}
|
||||
.fi
|
||||
.RE
|
||||
..
|
||||
.\"
|
||||
.de Sd
|
||||
.ds Dt \\$2
|
||||
..
|
||||
.\"
|
||||
.Sd $Date: 1995/08/23 12:07:31 $
|
||||
.TH unroff 1 "\*(Dt"
|
||||
.SH NAME
|
||||
unroff \- programmable, extensible troff translator
|
||||
.SH SYNOPSIS
|
||||
.B unroff
|
||||
[
|
||||
.BI \-f format
|
||||
] [
|
||||
.BI \-m package
|
||||
] [
|
||||
.BI \-h heapsize
|
||||
] [
|
||||
.B \-C
|
||||
]
|
||||
.if n .ti +0.5i
|
||||
[
|
||||
.B \-t
|
||||
] [
|
||||
.IR file " | " option...\&
|
||||
]
|
||||
.SH OVERVIEW
|
||||
.I unroff
|
||||
reads and parses documents with embedded troff markup
|
||||
and translates them to a different format\(emtypically
|
||||
to a different markup language such as SGML.
|
||||
The actual output format is not hard-wired into
|
||||
.IR unroff ;
|
||||
instead, the translation is performed by a set of user-supplied rules
|
||||
and functions written in the
|
||||
.I Scheme
|
||||
programming language.
|
||||
.I unroff
|
||||
employs the Extension Language Kit
|
||||
.I Elk
|
||||
to achieve programmability based on the Scheme language:
|
||||
a fully-functional Scheme interpreter is embedded in the translator.
|
||||
.LP
|
||||
The documents that can be processed by
|
||||
.I unroff
|
||||
are not restricted to a specific troff macro set.
|
||||
Translation rules for a new macro package can be added by supplying
|
||||
a set of corresponding Scheme procedures (a \*(lqback-end\*(rq).
|
||||
Predefined sets of such procedures exist for a number of combinations
|
||||
of target language and troff macro package:
|
||||
.I unroff
|
||||
\*(Ve supports translation to the \*(lqHypertext Markup Language\*(rq
|
||||
(HTML) version 2.0 for the
|
||||
.B \-man
|
||||
and
|
||||
.B \-ms
|
||||
macro packages as well as \*(lqbare\*(rq troff (see
|
||||
.BR unroff-html (1),
|
||||
.BR unroff-html-man (1),
|
||||
and
|
||||
.BR unroff-html-ms (1)
|
||||
for a description).
|
||||
.LP
|
||||
Unlike conventional troff conversion tools,
|
||||
.I unroff
|
||||
includes a full troff parser and can therefore handle user-defined
|
||||
macros, strings, and number registers, nested if-else requests
|
||||
(with text blocks enclosed by `\e{' and `\e}' escape sequences), arbitrary
|
||||
fonts and font positions, troff \*(lqcopy mode\*(rq, low-level formatting
|
||||
requests such as `\el' and '\eh', and the subtle
|
||||
differences between request and macro invocations that are inherent
|
||||
in the troff processing model.
|
||||
.I unroff
|
||||
has adopted a number of troff extensions introduced by
|
||||
.IR groff ,
|
||||
among them long names for macros, strings, number registers, and
|
||||
special characters, and the `\e$@' and `\e$*' escape sequences.
|
||||
.LP
|
||||
.I unroff
|
||||
interprets its input stream as a sequence of \*(lqevents\*(rq.
|
||||
Events include the invocation of a troff request or macro, the use of a
|
||||
troff escape sequence or special character, a troff string
|
||||
or number register reference, end of sentence, start
|
||||
of a new input file, and so on.
|
||||
For each event encountered
|
||||
.I unroff
|
||||
invokes a Scheme procedure associated with that event.
|
||||
Some types of events require a procedure that returns a string (or an
|
||||
object that can be coerced into a string),
|
||||
which is then interpolated into the input or output stream;
|
||||
for other types of events, the event procedures are just called
|
||||
for their side-effects.
|
||||
.LP
|
||||
The set of Scheme procedures to be used by
|
||||
.I unroff
|
||||
is determined by the output format and the name of the troff
|
||||
macro package.
|
||||
In addition, users can supply event procedures for their own macro
|
||||
definitions (or replace existing ones) in form of a simple Scheme
|
||||
program passed to
|
||||
.I unroff
|
||||
along with the troff input files; Scheme code can even be directly
|
||||
embedded in the troff input as described below.
|
||||
.LP
|
||||
The full capabilities of
|
||||
.IR unroff
|
||||
and the Scheme primitives required to write extensions or support
|
||||
for new output formats are described in the
|
||||
.IR "Unroff Programmer's Manual" .
|
||||
.SH "GENERIC OPTIONS"
|
||||
.TP
|
||||
.BI \-f format
|
||||
Specifies the output format into which the troff input files are
|
||||
translated.
|
||||
If no
|
||||
.B \-f
|
||||
option is given, a default output format is used (for
|
||||
.I unroff
|
||||
version \*(Ve the default is
|
||||
.B \-f\c
|
||||
.IR html ).
|
||||
This default can be overridden by setting the
|
||||
.SB UNROFF_FORMAT
|
||||
environment variable.
|
||||
.TP
|
||||
.BI \-m name
|
||||
Specifies the name of the macro package that would be used by ordinary
|
||||
troff to typeset the document.
|
||||
In contrast to troff
|
||||
.I unroff
|
||||
does not actually load the macro package.
|
||||
Instead, the specified name\-in combination with the specified output
|
||||
format\-selects a set of Scheme files providing the procedure definitions
|
||||
that control the translation process (see
|
||||
.B FILES
|
||||
below).
|
||||
Therefore a corresponding
|
||||
.B tmac
|
||||
file need not exist for a given
|
||||
.B \-m
|
||||
option.
|
||||
.TP
|
||||
.BI \-h heapsize
|
||||
This option can be used to specify a non-standard heap size (in Kbytes)
|
||||
for the Scheme interpreter included in
|
||||
.IR unroff ;
|
||||
see
|
||||
.BR elk (1).
|
||||
.TP
|
||||
.B \-C
|
||||
Enables troff compatibility mode.
|
||||
In compatibility mode certain
|
||||
.I groff
|
||||
extensions such as long names are not recognized.
|
||||
.TP
|
||||
.B \-t
|
||||
Enables test mode.
|
||||
Instead of processing troff input files,
|
||||
.I unroff
|
||||
enters an interactive Scheme top-level.
|
||||
This can be useful to interactively experiment with the Scheme
|
||||
primitives defined by
|
||||
.I unroff
|
||||
or to test or debug user-defined Scheme procedures.
|
||||
.SH "KEYWORD/VALUE OPTIONS"
|
||||
In addition to the generic options, a set of output-format-specific
|
||||
options can be set from the command line and from within troff and
|
||||
Scheme input files.
|
||||
When specified on the command line, these options have the form
|
||||
.Ex
|
||||
\f2option\fP=\f2value\fP
|
||||
.Ee
|
||||
where the format of
|
||||
.I value
|
||||
depends on the
|
||||
.I type
|
||||
of the option.
|
||||
For example, most output formats defines an option
|
||||
.B document
|
||||
whose value is used as a prefix for all output files created during
|
||||
the translation.
|
||||
The option is assigned a value by specifying a token such as
|
||||
.Ex
|
||||
document=thesis
|
||||
.Ee
|
||||
on the command line.
|
||||
This option's value is interpreted as a plain string, i.\|e.\&
|
||||
its type is
|
||||
.BR string .
|
||||
.LP
|
||||
The Scheme back-ends and user-supplied extensions can define their
|
||||
own option types, but at least the following types are recognized:
|
||||
.TP 10n
|
||||
.B integer
|
||||
the option value is composed of an optional sign and an (arbitrary)
|
||||
string of digits
|
||||
.TP 10n
|
||||
.B boolean
|
||||
the option value must either be the character 1 (true) or the
|
||||
character 0 (false)
|
||||
.TP 10n
|
||||
.B character
|
||||
a single character must be specified as the option value
|
||||
.TP 10n
|
||||
.B string
|
||||
an arbitrary string of characters can be specified
|
||||
.TP 10n
|
||||
.B dynstring
|
||||
\*(lqdynamic string\*(rq; the option value is either
|
||||
.RS
|
||||
.TP
|
||||
.I string
|
||||
to assign a string to the option in the normal way, or
|
||||
.TP
|
||||
.BI + string
|
||||
to append the characters after the plus sign
|
||||
to the option's current value, or
|
||||
.TP
|
||||
.BI \- string
|
||||
to remove the characters after the minus sign from the
|
||||
option's current value.
|
||||
.RE
|
||||
.LP
|
||||
These extension-specific options must appear after the generic
|
||||
.I unroff
|
||||
options and may be mixed with the file name arguments.
|
||||
As the option assignments and specified input files are processed in
|
||||
order, the value given for an option is in effect for all the input
|
||||
files that appear on the command line to the right of the option.
|
||||
.LP
|
||||
The exact set of keyword/value options is determined by the
|
||||
Scheme code loaded for a given combination of output format
|
||||
and macro package name and is described in the corresponding
|
||||
manuals.
|
||||
The following few options can always be set, regardless of the
|
||||
actual output format:
|
||||
.TP
|
||||
.BR include-files " (boolean)"
|
||||
If true,
|
||||
.B .so
|
||||
requests are executed by
|
||||
.I unroff
|
||||
in the normal way (that is, the named input file is read and
|
||||
parsed), otherwise
|
||||
.B .so
|
||||
requests are ignored.
|
||||
The default value is 1.
|
||||
.TP
|
||||
.BR if-true " (dynstring)"
|
||||
the specified characters are assigned to (appended to, removed from)
|
||||
the set of one-character conditions that are regarded as true
|
||||
by the
|
||||
.B .if
|
||||
and
|
||||
.B .ie
|
||||
requests.
|
||||
The default value is "to".
|
||||
.TP
|
||||
.BR if-false " (dynstring)"
|
||||
like
|
||||
.BR if-true ;
|
||||
specifies the one-character conditions regarded as false.
|
||||
The default value is "ne".
|
||||
.SH FILES
|
||||
.SS "INPUT FILES"
|
||||
On startup,
|
||||
.I unroff
|
||||
loads the Scheme source files that control the translation process.
|
||||
All these files are loaded from subdirectories of a site-specific
|
||||
\*(lqlibrary directory\*(rq, typically something like
|
||||
.BR /usr/local/lib/unroff .
|
||||
The directory is usually chosen by the system administrator when
|
||||
installing the software and can be overridden by setting the
|
||||
.SB UNROFF_DIR
|
||||
environment variable.
|
||||
The path names mentioned in the following are relative to this
|
||||
library directory.
|
||||
.LP
|
||||
The first Scheme file loaded is
|
||||
.B scm/troff.scm
|
||||
which contains basic definitions such as the built-in options
|
||||
and option types, implementations for troff requests that are
|
||||
not output-format specific, and utility functions to be used
|
||||
by the back-ends or by user-supplied extensions.
|
||||
Next, the file
|
||||
.BI scm/ format /common.scm
|
||||
is loaded, where
|
||||
.I format
|
||||
is the value of the option
|
||||
.B \-f
|
||||
as given on the command line (or its default value).
|
||||
The file implements the translation of the basic troff
|
||||
requests, escape sequences, and special characters, etc.
|
||||
The code dealing with macro invocations is loaded from
|
||||
.BI scm/ format / package .scm
|
||||
where
|
||||
.I package
|
||||
is the value of the option
|
||||
.B \-m
|
||||
with the letter `m' prepended.
|
||||
.LP
|
||||
Finally, the file
|
||||
.B .unroff
|
||||
is loaded from the caller's home directory if present.
|
||||
Arbitrary Scheme code can be placed in this initialization file.
|
||||
It is typically used to assign values to package-specific
|
||||
keyword/value options according to the user's preferences
|
||||
(by means of the
|
||||
.I set-option!
|
||||
Scheme primitive as explained in the Programmer's Manual).
|
||||
.LP
|
||||
When the initial files have been loaded, any troff input files specified
|
||||
in the command line are read and parsed.
|
||||
The special file name
|
||||
.RB ` \- '
|
||||
can be used to indicate standard input (usually in combination with
|
||||
ordinary file names).
|
||||
If no file name is given,
|
||||
.I unroff
|
||||
reads from standard input.
|
||||
.LP
|
||||
In addition to troff input files, file containing Scheme code can
|
||||
be mentioned in the command line.
|
||||
Scheme files (which by convention end in
|
||||
.BR .scm )
|
||||
are loaded into the Scheme interpreter and usually contain
|
||||
used-defined Scheme procedures to translate specific macros or
|
||||
to replace existing procedures, or other user-supplied extensions
|
||||
of any kind.
|
||||
Scheme files named in the command line (or loaded explicitly from
|
||||
within other files) are resolved against the directory
|
||||
.B scm/misc/
|
||||
which may hold site-specific extensions or other supplementary
|
||||
packages.
|
||||
troff files and Scheme files can be mixed freely in the command line.
|
||||
.SS "OUTPUT FILES"
|
||||
Whether
|
||||
.I unroff
|
||||
sends its output to standard output or produces one or more output
|
||||
files is not hard-wired but determined by the combination of output
|
||||
format and macro package.
|
||||
Generally, if no troff input files are specified, output is directed
|
||||
to standard output, but this rule is not mandatory and may
|
||||
be overridden by specific back-ends.
|
||||
The
|
||||
.B document
|
||||
option is usually honored, although other rules may be employed to
|
||||
determine the names of output files (for example, the extension
|
||||
that implements
|
||||
.B \-man
|
||||
for a given output format may derive the name of the output file
|
||||
for a manual page from the input file name; see
|
||||
.BR unroff-html-man (1)).
|
||||
.LP
|
||||
If
|
||||
.I unroff
|
||||
is interrupted or quits early, any output files produced so far may be
|
||||
incomplete or may contain wrong or inconsistent data, because
|
||||
several passes may be required to complete an output file (for example,
|
||||
to resolve cross references between a set of files), or because
|
||||
an output file is not necessarily produced as a whole, but
|
||||
.I unroff
|
||||
may work on several files simultaneously.
|
||||
.SH EXAMPLES
|
||||
.LP
|
||||
To translate a troff document composed of two files and written with the
|
||||
\*(lqms\*(rq macro package to HTML 2.0,
|
||||
.I unroff
|
||||
might be called like this:
|
||||
.Ex
|
||||
unroff \-fhtml \-ms doc.tr doc.tr
|
||||
.Ee
|
||||
Two options specific to the combination of
|
||||
.B \-fhtml
|
||||
and
|
||||
.B \-ms
|
||||
might be added to specify a prefix for output files and to have
|
||||
the resulting output split into separate files after each section
|
||||
(see
|
||||
.BR unroff-html-ms (1)):
|
||||
.Ex
|
||||
unroff \-fhtml \-ms document=out/ split=1 doc.tr doc.tr
|
||||
.Ee
|
||||
Additional features may be loaded from Scheme files specified in the
|
||||
command line, e.\|g.\&
|
||||
.B hyper.scm
|
||||
which implements general Hypertext requests (and gets loaded from
|
||||
.BR scm/misc/ )
|
||||
and a user-supplied file in the current directory providing translation
|
||||
rules for user-defined troff macros:
|
||||
.Ex
|
||||
.ne 2
|
||||
unroff \-fhtml \-ms document=out/ split=1 hyper.scm doc.scm\e
|
||||
doc.tr doc.tr
|
||||
.Ee
|
||||
.SH "TROFF SUPPORT AND EXTENSIONS"
|
||||
As
|
||||
.I unroff
|
||||
translates troff input into another language rather than typesetting
|
||||
the text in the usual way, its processing model necessarily differs
|
||||
from that of conventional troff.
|
||||
For a detailed description refer to the Programmer's Manual.
|
||||
.LP
|
||||
In brief,
|
||||
.I unroff
|
||||
copies characters from input to output, optionally performing
|
||||
target-language-specific character translations.
|
||||
For each request or macro invocation, string or number register
|
||||
reference, special character, escape sequence, sentence end, or
|
||||
.BR eqn (1)
|
||||
inline equation encountered in the input stream,
|
||||
.I unroff
|
||||
checks whether an \*(lqevent value\*(rq has been specified by
|
||||
the Scheme code (user-supplied or part of the back-end).
|
||||
An event value is either a plain string, which is then treated as
|
||||
if it had been part of the input stream, or a Scheme procedure,
|
||||
which is then invoked and must in turn return a string.
|
||||
The Scheme procedures are passed arguments, e.\|g. the macro
|
||||
or request arguments in case of a procedure attached to a macro
|
||||
or request, or an escape sequence argument for functions such as
|
||||
`\ef' or `\ew'.
|
||||
.LP
|
||||
If no event value has been associated with a particular macro,
|
||||
string, or number register,
|
||||
.I unroff
|
||||
checks whether a definition has been supplied in the normal way,
|
||||
i.\|e. by means of
|
||||
.BR .de ,
|
||||
.BR .ds ,
|
||||
or
|
||||
.BR .nr .
|
||||
In this case, the value of the macro, string, or register is
|
||||
interpolated as done by ordinary troff.
|
||||
If no definition can be found, a fallback definition is looked up
|
||||
as a last resort; and if everything fails, a warning is printed
|
||||
and the event is ignored.
|
||||
Similarly, event procedures are invoked at end of input line,
|
||||
when an input file is opened or closed, at program start and
|
||||
termination, and for each option specified in the command line;
|
||||
but these procedures are called solely for their side-effects
|
||||
(i.\|e. the return values are ignored).
|
||||
.LP
|
||||
Most Scheme procedures just emit the target language's representation
|
||||
of the event with which they are associated.
|
||||
Other procedures perform various kinds of bookkeeping; the procedure
|
||||
associated with the
|
||||
.B .de
|
||||
request, for example, puts the text following
|
||||
aside for later expansion, and the event procedures attached to
|
||||
the requests
|
||||
.B .ds
|
||||
and
|
||||
.B .nr
|
||||
and to the escape sequences `\e*' and `\en'
|
||||
implement troff strings and number registers.
|
||||
This way, even basic troff functions need not be hard-wired and can
|
||||
be altered or replaced freely without recompiling
|
||||
.IR unroff .
|
||||
.LP
|
||||
The rule that an event value associated with a macro has precedence
|
||||
over the actual macro definition accommodates higher-level,
|
||||
structure-oriented target languages (such as SGML).
|
||||
While the micro-formatting contained in a typical
|
||||
.B \-ms
|
||||
macro definition, for example, makes sense to an ordinary typesetting
|
||||
program, it is usually impossible to infer the macro's
|
||||
.I structural
|
||||
function from it (new paragraph, quotation, etc.).
|
||||
On the other hand, troff documents often define a few additional,
|
||||
simple macros that just serve as an abbreviation for a sequence
|
||||
of predefined macros; in this case event procedures need not
|
||||
specified, as
|
||||
.I unroff
|
||||
will then perform normal macro expansion.
|
||||
.LP
|
||||
.I unroff
|
||||
usually takes care to not rescan the characters returned by event
|
||||
procedures as if their results had been normal input, because
|
||||
most event procedures already return code in the target language rather
|
||||
than troff input that can be rescanned.
|
||||
This, however, cannot always be avoided; for example, if a troff string
|
||||
reference occurs at macro definition time (because `\e*' is used rather
|
||||
than `\e\e*'), the string value ends up in the macro body and will still
|
||||
be rescanned when the macro is invoked.
|
||||
A few other pitfalls caused by differences in the processing models of
|
||||
troff and
|
||||
.I unroff
|
||||
are listed in the BUGS section below.
|
||||
.LP
|
||||
The scaling performed for the usual troff scale indicators
|
||||
can be manipulated by a calling a Scheme primitive from within
|
||||
the Scheme code implementing a particular back-end.
|
||||
.SS "NEW TROFF REQUESTS"
|
||||
To aid transparent output of code in the target language and
|
||||
evaluation of inline Scheme code,
|
||||
.I unroff
|
||||
supports two new requests and two extensions to the
|
||||
.B .ig
|
||||
(ignore input lines) troff request.
|
||||
.LP
|
||||
If
|
||||
.B .ig
|
||||
is called with the symbol
|
||||
.B >>
|
||||
as its first argument, all input lines up to (but not including)
|
||||
the terminating
|
||||
.B .>>
|
||||
are sent to the current output file.
|
||||
Example:
|
||||
when translating to the Hypertext Markup Language, the construct
|
||||
could be used to emit literal HTML code like this:
|
||||
.Ex
|
||||
.ne 6
|
||||
\&.ig >>
|
||||
<address>
|
||||
Bart Simpson<br>
|
||||
Springfield
|
||||
</address>
|
||||
\&.>>
|
||||
.Ee
|
||||
.LP
|
||||
To produce a single line of output, the new request
|
||||
.B .>>
|
||||
can be used as in this HTML example:
|
||||
.Ex
|
||||
\&.>> "<code>result = i+1;</code>"
|
||||
.Ee
|
||||
.LP
|
||||
If the
|
||||
.B .ig
|
||||
request is called with the argument
|
||||
.BR ##,
|
||||
everything up to the terminating
|
||||
.B .##
|
||||
is passed to the Scheme interpreter for evaluation.
|
||||
This allows users to embed Scheme code in a troff document which
|
||||
is executed when the document is processed by
|
||||
.IR unroff .
|
||||
One use of this construct is to provide a Scheme event procedure
|
||||
for a user-defined macro by placing the corresponding Scheme
|
||||
definition in the same source file right below the troff macro definition.
|
||||
Similarly, the request
|
||||
.B .##
|
||||
can be used to evaluate a short S-expression; all arguments to
|
||||
the request are concatenated and then passed to the Scheme
|
||||
interpreter.
|
||||
.LP
|
||||
Note that inline Scheme code is a potentially dangerous feature,
|
||||
as a document received by someone else may contain embedded code
|
||||
that does something unexpected when the file is processed by
|
||||
.I unroff
|
||||
(but it is probably not more dangerous than the standard troff
|
||||
.B .pi
|
||||
request or the
|
||||
.B .sy
|
||||
request of
|
||||
.IR ditroff ).
|
||||
.LP
|
||||
.I unroff
|
||||
defines the following new read-only number registers:
|
||||
.TP
|
||||
.B .U
|
||||
This register always expand to 1.
|
||||
It can be used by macros to determine whether the document is
|
||||
being processed by
|
||||
.IR unroff .
|
||||
.TP
|
||||
.B .C
|
||||
Expands to 1 if troff compatibility mode has been enabled
|
||||
by using the option
|
||||
.BR \-C ,
|
||||
to 0 otherwise.
|
||||
.LP
|
||||
The following new escape sequences are available in a macro
|
||||
body during macro expansion:
|
||||
.TP
|
||||
.B $0
|
||||
The name of the current macro.
|
||||
.TP
|
||||
.B $*
|
||||
The concatenation of all arguments, separated by spaces.
|
||||
.TP
|
||||
.B $@
|
||||
The concatenation of all arguments, separated by spaces, and
|
||||
with each argument enclosed by double quotes.
|
||||
.LP
|
||||
The names of strings, macros, number registers, and fonts may be of
|
||||
any length.
|
||||
As in
|
||||
.IR groff ,
|
||||
square brackets can be used for names of arbitrary length:
|
||||
.Ex
|
||||
\ef[font] \e*[string] \en[numreg] ...
|
||||
.Ee
|
||||
.LP
|
||||
There is no limit on the number of macro arguments, and the following
|
||||
syntax can be used to reference the 10th, 11th, etc. macro argument:
|
||||
.Ex
|
||||
\e$(12 \e$[12] \e$[123]
|
||||
.Ee
|
||||
.LP
|
||||
Unless troff compatibility mode has been enabled, the arguments to the
|
||||
.IR groff -specific
|
||||
escape sequences `\eA', `\eC', '\eL', '\eN', '\eR', '\eV', '\eY',
|
||||
and '\eZ' are recognized and parsed, so that event procedures
|
||||
can be implemented correctly for these escape sequences.
|
||||
.SH "SEE ALSO"
|
||||
.BR unroff-html (1),
|
||||
.BR unroff-html-man (1),
|
||||
.BR unroff-html-ms (1);
|
||||
.br
|
||||
.BR troff (1),
|
||||
.BR groff (1);
|
||||
.BR elk (1).
|
||||
.LP
|
||||
Unroff Programmer's Manual.
|
||||
.LP
|
||||
http://www.informatik.uni-bremen.de/~net/unroff
|
||||
.SH AUTHOR
|
||||
Oliver Laumann, net@cs.tu-berlin.de
|
||||
.SH BUGS
|
||||
A number of low-level formatting features of troff (such as the
|
||||
absolute position indicator in numerical expressions)
|
||||
are not yet supported by
|
||||
.I unroff
|
||||
version \*(Ve, which is not critical for higher-level,
|
||||
structure-oriented target languages such as the Hypertext
|
||||
Markup Language.
|
||||
.LP
|
||||
Diversions are not supported, although specific back-ends are
|
||||
free to add this functionality.
|
||||
.LP
|
||||
Special characters are not treated right in certain contexts;
|
||||
in particular, special characters may not be used in place
|
||||
of plain characters where the characters act as some kind of
|
||||
delimiter as in
|
||||
.Ex
|
||||
\&.if \e(bsfoo\e(bsbar\e(bs ...
|
||||
.Ee
|
||||
.LP
|
||||
Spaces in an
|
||||
.B .if
|
||||
condition do not work; e.\|g. the following fails:
|
||||
.Ex
|
||||
\&.if ' ' ' ...
|
||||
.Ee
|
||||
.LP
|
||||
Conditional input is subject to string and number register
|
||||
expansion even if the corresponding if-condition evaluates to false.
|
||||
.LP
|
||||
There are no number register formats, i.\|e. the request
|
||||
.B .af
|
||||
does not work.
|
||||
.LP
|
||||
The set of punctuation marks that indicate end of sentence
|
||||
should be configurable.
|
||||
.LP
|
||||
Empty input lines and leading space should trigger a special
|
||||
event, so that their break semantics can be implemented correctly.
|
||||
.LP
|
||||
A comment in a line by itself currently does not generate a
|
||||
blank line.
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
This directory holds a minimal, self-contained Elk runtime environment.
|
||||
All the files have been copied from the Elk 3.0 distribution. If you
|
||||
have Elk installed at your site, you can replace this directory by
|
||||
a symbolic link to your site's Elk runtime directory.
|
||||
|
|
@ -0,0 +1,212 @@
|
|||
;;; -*-Scheme-*-
|
||||
;;;
|
||||
;;; A simple debugger (improvements by Thomas M. Breuel <tmb@ai.mit.edu>).
|
||||
|
||||
(define (backtrace . args)
|
||||
(if (> (length args) 1)
|
||||
(error 'backtrace "too many arguments"))
|
||||
(if (not (null? args))
|
||||
(if (not (eq? (type (car args)) 'control-point))
|
||||
(error 'backtrace "argument must be a control point")))
|
||||
(let ((trace (apply backtrace-list args)))
|
||||
(if (null? args)
|
||||
(set! trace (cdddr trace)))
|
||||
(show-backtrace trace 0 999999)))
|
||||
|
||||
(define (show-backtrace trace start-frame end-frame)
|
||||
(define (rjust n x)
|
||||
(let* ((y (string-append (make-string n #\space) x))
|
||||
(l (string-length y)))
|
||||
(substring y (- l n) l)))
|
||||
(let ((maxlen 28))
|
||||
(let loop ((frames (list-tail trace start-frame)) (num start-frame))
|
||||
(if (or (null? frames) (>= num end-frame)) #v
|
||||
(let ((frame (car frames)))
|
||||
(let* ((func
|
||||
(format #f "~s" (vector-ref frame 0)))
|
||||
(indent
|
||||
(- maxlen (+ 5 (string-length func)))))
|
||||
(display (rjust 4 (number->string num)))
|
||||
(display " ")
|
||||
(display func)
|
||||
(if (negative? indent)
|
||||
(begin
|
||||
(newline)
|
||||
(set! indent maxlen)))
|
||||
(do ((i indent (1- i)))
|
||||
((> 0 i))
|
||||
(display " ")))
|
||||
(fluid-let
|
||||
((print-depth 2)
|
||||
(print-length 3))
|
||||
(display (vector-ref frame 1)))
|
||||
(newline))
|
||||
(loop (cdr frames) (1+ num))))))
|
||||
|
||||
(define (show-environment env)
|
||||
(fluid-let
|
||||
((print-length 2)
|
||||
(print-depth 2))
|
||||
(do ((f (environment->list env) (cdr f)))
|
||||
((null? f))
|
||||
(do ((b (car f) (cdr b)))
|
||||
((null? b))
|
||||
(format #t "~s\t~s~%" (caar b) (cdar b)))
|
||||
(print '-------)))
|
||||
#v)
|
||||
|
||||
(define inspect)
|
||||
|
||||
(let ((frame)
|
||||
(trace)
|
||||
(help-text
|
||||
'("q -- quit inspector"
|
||||
"f -- print current frame"
|
||||
"u -- go up one frame"
|
||||
"d -- go down one frame"
|
||||
"^ -- go to top frame"
|
||||
"$ -- go to bottom frame"
|
||||
"g <n> -- goto to n-th frame"
|
||||
"e -- eval expressions in environment"
|
||||
"p -- pretty-print procedure"
|
||||
"v -- show environment"
|
||||
"<n> -- pretty-print n-th argument"
|
||||
"b -- show backtrace starting at current frame"
|
||||
"t -- show top of bracktrace starting at current frame"
|
||||
"z -- show and move top of backtrace starting at current frame"
|
||||
"o -- obarray information")))
|
||||
|
||||
(define (inspect-command-loop)
|
||||
(let ((input) (done #f))
|
||||
(display "inspect> ")
|
||||
(set! input (read))
|
||||
(case input
|
||||
(q
|
||||
(set! done #t))
|
||||
(?
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(display msg)
|
||||
(newline))
|
||||
help-text))
|
||||
(f
|
||||
(print-frame))
|
||||
(^
|
||||
(set! frame 0)
|
||||
(print-frame))
|
||||
($
|
||||
(set! frame (1- (length trace)))
|
||||
(print-frame))
|
||||
(u
|
||||
(if (zero? frame)
|
||||
(format #t "Already on top frame.~%")
|
||||
(set! frame (1- frame))
|
||||
(print-frame)))
|
||||
(d
|
||||
(if (= frame (1- (length trace)))
|
||||
(format #t "Already on bottom frame.~%")
|
||||
(set! frame (1+ frame))
|
||||
(print-frame)))
|
||||
(g
|
||||
(set! input (read))
|
||||
(if (integer? input)
|
||||
(set! frame
|
||||
(cond ((negative? input) 0)
|
||||
((>= input (length trace)) (1- (length trace)))
|
||||
(else input)))
|
||||
(format #t "Frame number must be an integer.~%")))
|
||||
(v
|
||||
(show-environment (vector-ref (list-ref trace frame) 2)))
|
||||
(e
|
||||
(format #t "Type ^D to return to Inspector.~%")
|
||||
(let loop ()
|
||||
(display "eval> ")
|
||||
(set! input (read))
|
||||
(if (not (eof-object? input))
|
||||
(begin
|
||||
(write (eval input
|
||||
(vector-ref (list-ref trace frame) 2)))
|
||||
(newline)
|
||||
(loop))))
|
||||
(newline))
|
||||
(p
|
||||
(pp (vector-ref (list-ref trace frame) 0))
|
||||
(newline))
|
||||
(z
|
||||
(show-backtrace trace frame (+ frame 10))
|
||||
(set! frame (+ frame 9))
|
||||
(if (>= frame (length trace)) (set! frame (1- (length trace)))))
|
||||
(t
|
||||
(show-backtrace trace frame (+ frame 10)))
|
||||
(b
|
||||
(show-backtrace trace frame 999999))
|
||||
(o
|
||||
(let ((l (map length (oblist))))
|
||||
(let ((n 0))
|
||||
(for-each (lambda (x) (set! n (+ x n))) l)
|
||||
(format #t "~s symbols " n)
|
||||
(format #t "(maximum bucket: ~s).~%" (apply max l)))))
|
||||
(else
|
||||
(cond
|
||||
((integer? input)
|
||||
(let ((args (vector-ref (list-ref trace frame) 1)))
|
||||
(if (or (< input 1) (> input (length args)))
|
||||
(format #t "No such argument.~%")
|
||||
(pp (list-ref args (1- input)))
|
||||
(newline))))
|
||||
((eof-object? input)
|
||||
(set! done #t))
|
||||
(else
|
||||
(format #t "Invalid command. Type ? for help.~%")))))
|
||||
(if (not done)
|
||||
(inspect-command-loop))))
|
||||
|
||||
(define (print-frame)
|
||||
(format #t "~%Frame ~s of ~s:~%~%" frame (1- (length trace)))
|
||||
(let* ((f (list-ref trace frame)) (args (vector-ref f 1)))
|
||||
(format #t "Procedure: ~s~%" (vector-ref f 0))
|
||||
(format #t "Environment: ~s~%" (vector-ref f 2))
|
||||
(if (null? args)
|
||||
(format #t "No arguments.~%")
|
||||
(fluid-let
|
||||
((print-depth 2)
|
||||
(print-length 3))
|
||||
(do ((i 1 (1+ i)) (args args (cdr args))) ((null? args))
|
||||
(format #t "Argument ~s: ~s~%" i (car args))))))
|
||||
(newline))
|
||||
|
||||
(define (find-frame proc)
|
||||
(let loop ((l trace) (i 0))
|
||||
(cond ((null? l) -1)
|
||||
((eq? (vector-ref (car l) 0) proc) i)
|
||||
(else (loop (cdr l) (1+ i))))))
|
||||
|
||||
(set! inspect
|
||||
(lambda ()
|
||||
(set! trace (backtrace-list))
|
||||
(set! trace (cddr trace))
|
||||
(do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
|
||||
(if (not (null? (vector-ref (car t) 1)))
|
||||
(let ((last (last-pair (vector-ref (car t) 1))))
|
||||
(if (not (null? (cdr last)))
|
||||
(begin
|
||||
(format #t
|
||||
"[inspector: fixing improper arglist in frame ~s]~%" f)
|
||||
(set-cdr! last (cons (cdr last) '())))))))
|
||||
(set! frame (find-frame error-handler))
|
||||
(if (negative? frame)
|
||||
(set! frame 0))
|
||||
(format #t "Inspector (type ? for help):~%")
|
||||
(let loop ()
|
||||
(if (call-with-current-continuation
|
||||
(lambda (control-point)
|
||||
(push-frame control-point)
|
||||
(inspect-command-loop)
|
||||
#f))
|
||||
(begin
|
||||
(pop-frame)
|
||||
(loop))))
|
||||
(newline)
|
||||
(pop-frame)
|
||||
(let ((next-frame (car rep-frames)))
|
||||
(next-frame #t)))))
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
;;; -*-Scheme-*-
|
||||
;;;
|
||||
;;; Initialization code for the Elk interpreter kernel.
|
||||
;;;
|
||||
;;; This file is loaded on startup before the toplevel (or the file
|
||||
;;; supplied along with the -l option) is loaded.
|
||||
;;;
|
||||
;;; If a garbage collection is triggered while loading this file,
|
||||
;;; it is regarded as an indication that the heap size is too small
|
||||
;;; and an error message is printed.
|
||||
|
||||
|
||||
;;; Primitives that are part of the core functionality but are not
|
||||
;;; implemented in C. This is a bad thing, because extension or
|
||||
;;; application writers should be able to rely on P_Expt().
|
||||
|
||||
(define (expt x y)
|
||||
|
||||
(define (square x) (* x x))
|
||||
|
||||
(define (integer-expt b n)
|
||||
(cond ((= n 0) 1)
|
||||
((negative? n) (/ 1 (integer-expt b (abs n))))
|
||||
((even? n) (square (integer-expt b (/ n 2))))
|
||||
(else (* b (integer-expt b (- n 1))))))
|
||||
|
||||
(cond ((zero? x) (if (zero? y) 1 0))
|
||||
((integer? y) (integer-expt x y))
|
||||
(else (exp (* (log x) y)))))
|
||||
|
||||
|
||||
;;; Synonyms:
|
||||
|
||||
(define call/cc call-with-current-continuation)
|
||||
|
||||
|
||||
;;; Backwards compatibility. These procedures are really obsolete;
|
||||
;;; please do not use them any longer.
|
||||
|
||||
(define (close-port p)
|
||||
(if (input-port? p) (close-input-port p) (close-output-port p)))
|
||||
|
||||
(define (void? x) (eq? x (string->symbol "")))
|
||||
|
||||
(define (re-entrant-continuations?) #t)
|
||||
|
||||
|
||||
;;; Useful macros (these were loaded by the standard toplevel in
|
||||
;;; earlier versions of Elk). They shouldn't really be here, but
|
||||
;;; it's too late...
|
||||
|
||||
(define (expand form)
|
||||
(if (or (not (pair? form)) (null? form))
|
||||
form
|
||||
(let ((head (expand (car form))) (args (expand (cdr form))) (result))
|
||||
(if (and (symbol? head) (bound? head))
|
||||
(begin
|
||||
(set! result (macro-expand (cons head args)))
|
||||
(if (not (equal? result form))
|
||||
(expand result)
|
||||
result))
|
||||
(cons head args)))))
|
||||
|
||||
(define-macro (unwind-protect body . unwind-forms)
|
||||
`(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () ,body)
|
||||
(lambda () ,@unwind-forms)))
|
||||
|
||||
(define-macro (while test . body)
|
||||
`(let loop ()
|
||||
(cond (,test ,@body (loop)))))
|
||||
|
||||
(define-macro (when test . body)
|
||||
`(cond (,test ,@body)))
|
||||
|
||||
(define-macro (unless test . body)
|
||||
`(when (not ,test) ,@body))
|
||||
|
||||
(define-macro (multiple-value-bind vars form . body)
|
||||
`(apply (lambda ,vars ,@body) ,form))
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
;;; -*-Scheme-*-
|
||||
;;;
|
||||
;;; Trivial pretty-printer
|
||||
|
||||
(provide 'pp)
|
||||
|
||||
(define pp)
|
||||
|
||||
(let ((max-pos 55) (pos 0) (tab-stop 8))
|
||||
|
||||
(put 'lambda 'special #t)
|
||||
(put 'macro 'special #t)
|
||||
(put 'define 'special #t)
|
||||
(put 'define-macro 'special #t)
|
||||
(put 'define-structure 'special #t)
|
||||
(put 'fluid-let 'special #t)
|
||||
(put 'let 'special #t)
|
||||
(put 'let* 'special #t)
|
||||
(put 'letrec 'special #t)
|
||||
(put 'case 'special #t)
|
||||
|
||||
(put 'call-with-current-continuation 'long #t)
|
||||
|
||||
(put 'quote 'abbr "'")
|
||||
(put 'quasiquote 'abbr "`")
|
||||
(put 'unquote 'abbr ",")
|
||||
(put 'unquote-splicing 'abbr ",@")
|
||||
|
||||
(set! pp (lambda (x)
|
||||
(set! pos 0)
|
||||
(cond ((eq? (type x) 'compound)
|
||||
(set! x (procedure-lambda x)))
|
||||
((eq? (type x) 'macro)
|
||||
(set! x (macro-body x))))
|
||||
(fluid-let ((garbage-collect-notify? #f))
|
||||
(pp-object x))
|
||||
#v))
|
||||
|
||||
(define (flat-size s)
|
||||
(fluid-let ((print-length 50) (print-depth 10))
|
||||
(string-length (format #f "~a" s))))
|
||||
|
||||
(define (pp-object x)
|
||||
(if (or (null? x) (pair? x))
|
||||
(pp-list x)
|
||||
(if (void? x)
|
||||
(display "#v")
|
||||
(write x))
|
||||
(set! pos (+ pos (flat-size x)))))
|
||||
|
||||
(define (pp-list x)
|
||||
(if (and (pair? x)
|
||||
(symbol? (car x))
|
||||
(string? (get (car x) 'abbr))
|
||||
(= 2 (length x)))
|
||||
(let ((abbr (get (car x) 'abbr)))
|
||||
(display abbr)
|
||||
(set! pos (+ pos (flat-size abbr)))
|
||||
(pp-object (cadr x)))
|
||||
(if (> (flat-size x) (- max-pos pos))
|
||||
(pp-list-vertically x)
|
||||
(pp-list-horizontally x))))
|
||||
|
||||
(define (pp-list-vertically x)
|
||||
(maybe-pp-list-vertically #t x))
|
||||
|
||||
(define (pp-list-horizontally x)
|
||||
(maybe-pp-list-vertically #f x))
|
||||
|
||||
(define (maybe-pp-list-vertically vertical? list)
|
||||
(display "(")
|
||||
(set! pos (1+ pos))
|
||||
(if (null? list)
|
||||
(begin
|
||||
(display ")")
|
||||
(set! pos (1+ pos)))
|
||||
(let ((pos1 pos))
|
||||
(pp-object (car list))
|
||||
(if (and vertical?
|
||||
(or
|
||||
(and (pair? (car list))
|
||||
(not (null? (cdr list))))
|
||||
(and (symbol? (car list))
|
||||
(get (car list) 'long))))
|
||||
(indent-newline (1- pos1)))
|
||||
(let ((pos2 (1+ pos)) (key (car list)))
|
||||
(let tail ((flag #f) (l (cdr list)))
|
||||
(cond ((pair? l)
|
||||
(if flag
|
||||
(indent-newline
|
||||
(if (and (symbol? key) (get key 'special))
|
||||
(1+ pos1)
|
||||
pos2))
|
||||
(display " ")
|
||||
(set! pos (1+ pos)))
|
||||
(pp-object (car l))
|
||||
(tail vertical? (cdr l)))
|
||||
(else
|
||||
(cond ((not (null? l))
|
||||
(display " . ")
|
||||
(set! pos (+ pos 3))
|
||||
(if flag (indent-newline pos2))
|
||||
(pp-object l)))
|
||||
(display ")")
|
||||
(set! pos (1+ pos)))))))))
|
||||
|
||||
(define (indent-newline x)
|
||||
(newline)
|
||||
(set! pos x)
|
||||
(let loop ((i x))
|
||||
(cond ((>= i tab-stop)
|
||||
(display "\t")
|
||||
(loop (- i tab-stop)))
|
||||
((> i 0)
|
||||
(display " ")
|
||||
(loop (1- i)))))))
|
||||
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
;;; -*-Scheme-*-
|
||||
;;;
|
||||
;;; Read-eval-print loop and error handler
|
||||
|
||||
|
||||
(autoload 'pp 'pp.scm)
|
||||
(autoload 'apropos 'apropos.scm)
|
||||
(autoload 'sort 'qsort.scm)
|
||||
(autoload 'describe 'describe.scm)
|
||||
(autoload 'backtrace 'debug.scm)
|
||||
(autoload 'inspect 'debug.scm)
|
||||
|
||||
(define ?)
|
||||
(define ??)
|
||||
(define ???)
|
||||
(define !)
|
||||
(define !!)
|
||||
(define !!!)
|
||||
(define &)
|
||||
|
||||
(define (rep-loop env)
|
||||
(define input)
|
||||
(define value)
|
||||
(let loop ()
|
||||
(set! ??? ??)
|
||||
(set! ?? ?)
|
||||
(set! ? &)
|
||||
;;; X Windows hack
|
||||
(if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
|
||||
(display-flush-output dpy))
|
||||
(if (> rep-level 0)
|
||||
(display rep-level))
|
||||
(display "> ")
|
||||
(set! input (read))
|
||||
(set! & input)
|
||||
(if (not (eof-object? input))
|
||||
(begin
|
||||
(set! value (eval input env))
|
||||
(set! !!! !!)
|
||||
(set! !! !)
|
||||
(set! ! value)
|
||||
(write value)
|
||||
(newline)
|
||||
(loop)))))
|
||||
|
||||
(define rep-frames)
|
||||
(define rep-level)
|
||||
|
||||
(set! interrupt-handler
|
||||
(lambda ()
|
||||
(format #t "~%\7Interrupt!~%")
|
||||
(let ((next-frame (car rep-frames)))
|
||||
(next-frame #t))))
|
||||
|
||||
(define-macro (push-frame control-point)
|
||||
`(begin
|
||||
(set! rep-frames (cons ,control-point rep-frames))
|
||||
(set! rep-level (1+ rep-level))))
|
||||
|
||||
(define-macro (pop-frame)
|
||||
'(begin
|
||||
(set! rep-frames (cdr rep-frames))
|
||||
(set! rep-level (1- rep-level))))
|
||||
|
||||
(define (error-print error-msg)
|
||||
(format #t "~s: " (car error-msg))
|
||||
(apply format `(#t ,@(cdr error-msg)))
|
||||
(newline))
|
||||
|
||||
(set! error-handler
|
||||
(lambda error-msg
|
||||
(error-print error-msg)
|
||||
(let loop ((intr-level (enable-interrupts)))
|
||||
(if (positive? intr-level)
|
||||
(loop (enable-interrupts))))
|
||||
(let loop ()
|
||||
(if (call-with-current-continuation
|
||||
(lambda (control-point)
|
||||
(push-frame control-point)
|
||||
(rep-loop (the-environment))
|
||||
#f))
|
||||
(begin
|
||||
(pop-frame)
|
||||
(loop))))
|
||||
(newline)
|
||||
(pop-frame)
|
||||
(let ((next-frame (car rep-frames)))
|
||||
(next-frame #t))))
|
||||
|
||||
(define top-level-environment (the-environment))
|
||||
|
||||
(define (top-level)
|
||||
(let loop ()
|
||||
;;; Allow GC to free old rep-frames when we get here on "reset":
|
||||
(set! rep-frames (list top-level-control-point))
|
||||
(if (call-with-current-continuation
|
||||
(lambda (control-point)
|
||||
(set! rep-frames (list control-point))
|
||||
(set! top-level-control-point control-point)
|
||||
(set! rep-level 0)
|
||||
(rep-loop top-level-environment)
|
||||
#f))
|
||||
(loop))))
|
||||
|
||||
(define (the-top-level)
|
||||
(top-level)
|
||||
(newline)
|
||||
(exit))
|
||||
|
||||
(the-top-level)
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; ~/.unroff -- initializations for unroff
|
||||
|
||||
(define signature
|
||||
(concat "Markup created by <em>%progname%</em> %version%," nbsp nbsp
|
||||
"%monthname+% %day%, %year%," nbsp nbsp "net@cs.tu-berlin.de"))
|
||||
|
||||
(eval-if-mode (* html)
|
||||
(set-option! 'mail-address "net@cs.tu-berlin.de"))
|
||||
|
||||
(eval-if-mode (ms html)
|
||||
(set-option! 'title "An `ms' document")
|
||||
(set-option! 'signature signature))
|
||||
|
|
@ -0,0 +1,597 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.20 $
|
||||
;;;;
|
||||
;;;; Common definitions for HTML output format
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Configurable, site-specific definitions.
|
||||
|
||||
(define-option 'troff-to-gif 'string
|
||||
"groff -ms > %1%; /usr/www/lib/latex2html/pstogif %1% -out %2%")
|
||||
|
||||
(define-option 'troff-to-text 'string
|
||||
"groff -Tlatin1 -P-b -P-u |sed '/^[ \t]*$/d' > %1%")
|
||||
|
||||
(define-option 'tbl 'string 'gtbl)
|
||||
(define-option 'eqn 'string 'geqn)
|
||||
(define-option 'pic 'string 'gpic)
|
||||
|
||||
|
||||
;; A non-breaking space that is really non-breaking even in broken browsers:
|
||||
|
||||
(define nbsp " <tt> </tt>")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Options.
|
||||
|
||||
|
||||
(define-option 'title 'string #f) ; May be used for <title>
|
||||
(define-option 'mail-address 'string #f) ; May be used for `mailto:'
|
||||
(define-option 'document 'string #f) ; Prefix for output file(s)
|
||||
(define-option 'tt-preformat 'boolean #f) ; do <tt>-changes inside .nf/.fi
|
||||
|
||||
(define-option 'handle-eqn 'string "gif") ; gif/text/copy
|
||||
(define-option 'handle-tbl 'string "text") ;
|
||||
(define-option 'handle-pic 'string "gif") ;
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Preformatted text.
|
||||
|
||||
(define preform? #f)
|
||||
|
||||
(define (preform on?)
|
||||
(cond ((and on? (not preform?))
|
||||
(defsentence #f)
|
||||
(with-font-preserved
|
||||
(begin (set! preform? #t) "<pre>\n")))
|
||||
((and (not on?) preform?)
|
||||
(defsentence sentence-event)
|
||||
(with-font-preserved
|
||||
(begin (set! preform? #f) "</pre>\n")))
|
||||
(else "")))
|
||||
|
||||
(defrequest 'nf (lambda _ (preform #t)))
|
||||
(defrequest 'fi (lambda _ (preform #f)))
|
||||
|
||||
(define-macro (with-preform-preserved . body)
|
||||
`(let (($p preform?))
|
||||
(concat (preform #f) ,@body (preform $p))))
|
||||
|
||||
(defchar #\tab
|
||||
(lambda (c)
|
||||
(if (not preform?) (surprise "tab outside .nf/.fi")) c))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Silently ignoring these requests probably will not harm. There is
|
||||
;;; nothing sensible we can do.
|
||||
|
||||
(defrequest 'ne "")
|
||||
(defrequest 'hw "")
|
||||
(defrequest 'nh "")
|
||||
(defrequest 'hy "")
|
||||
(defrequest 'lg "")
|
||||
(defrequest 'ps "")
|
||||
(defrequest 'vs "")
|
||||
(defrequest 'pl "")
|
||||
(defrequest 'bp "")
|
||||
(defrequest 'ns "")
|
||||
(defrequest 'rs "")
|
||||
(defrequest 'wh "")
|
||||
(defrequest 'ch "")
|
||||
(defrequest 'fl "")
|
||||
(defrequest 'na "")
|
||||
(defrequest 'ad "")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Basic escape sequences and special characters.
|
||||
|
||||
(defescape #\c "") ; swallows its character argument
|
||||
(defescape #\& "")
|
||||
(defescape #\- #\-)
|
||||
(defescape #\| "")
|
||||
(defescape #\^ "")
|
||||
(defescape #\space #\space) ; should be   (doesn't work in Mosaic)
|
||||
(defescape #\0 #\space)
|
||||
(defescape #\s "")
|
||||
(defescape #\e #\\)
|
||||
(defescape #\\ #\\)
|
||||
(defescape #\' #\')
|
||||
(defescape #\` #\`)
|
||||
(defescape #\% "")
|
||||
|
||||
(defescape ""
|
||||
(lambda (c . _)
|
||||
(warn "escape sequence `\\~a' expands to `~a'" c c)
|
||||
(translate c)))
|
||||
|
||||
(defspecial 'em "--")
|
||||
(defspecial 'en #\-)
|
||||
(defspecial 'mi #\-)
|
||||
(defspecial 'pl #\+) ; plus
|
||||
(defspecial 'lq "``")
|
||||
(defspecial 'rq "''")
|
||||
(defspecial '** #\*)
|
||||
(defspecial 'bv #\|) ; bold vertical (what is this?)
|
||||
(defspecial 'hy "­") ; `soft hyphen'
|
||||
(defspecial 'co "©") ; copyright
|
||||
(defspecial 'ap #\~) ; approximates
|
||||
(defspecial '~= #\~)
|
||||
(defspecial 'cd "·") ; centered dot
|
||||
(defspecial 'de "°") ; degree
|
||||
(defspecial '>= ">=")
|
||||
(defspecial '<= "<=")
|
||||
(defspecial 'eq #\=)
|
||||
(defspecial '== "==")
|
||||
(defspecial 'mu "×") ; multiplication
|
||||
(defspecial 'tm "®")
|
||||
(defspecial 'rg "®")
|
||||
(defspecial '*m "µ") ; mu
|
||||
(defspecial '*b "ß") ; beta (#223 is German sharp-s actually)
|
||||
(defspecial 'aa #\') ; acute accent
|
||||
(defspecial 'ga #\`) ; grave accent
|
||||
(defspecial 'br #\|) ; vertical box rule
|
||||
(defspecial 'or #\|)
|
||||
(defspecial 'sl #\/)
|
||||
(defspecial 'ru #\_)
|
||||
(defspecial 'ul #\_)
|
||||
(defspecial 'ci #\O)
|
||||
(defspecial "14" "¼")
|
||||
(defspecial "12" "½")
|
||||
(defspecial "34" "¾")
|
||||
(defspecial 'es "Ø")
|
||||
(defspecial '+- "±")
|
||||
(defspecial 'sc "§")
|
||||
(defspecial 'fm #\') ; foot mark
|
||||
(defspecial 'lh "<=")
|
||||
(defspecial 'rh "=>")
|
||||
(defspecial '-> "->")
|
||||
(defspecial '<- "<-")
|
||||
(defspecial 'no "¬") ; negation
|
||||
(defspecial 'di "÷") ; division
|
||||
(defspecial 'ss "ß")
|
||||
(defspecial ':a "ä")
|
||||
(defspecial 'a: "ä")
|
||||
(defspecial ':o "ö")
|
||||
(defspecial 'o: "ö")
|
||||
(defspecial ':u "ü")
|
||||
(defspecial 'u: "ü")
|
||||
(defspecial ':A "Ä")
|
||||
(defspecial 'A: "Ä")
|
||||
(defspecial ':O "Ö")
|
||||
(defspecial 'O: "Ö")
|
||||
(defspecial ':U "Ü")
|
||||
(defspecial 'U: "Ü")
|
||||
(defspecial 'ct "¢") ; cent
|
||||
(defspecial 'Po "£") ; pound
|
||||
(defspecial 'Cs "¤") ; currency sign
|
||||
(defspecial 'Ye "¥") ; yen
|
||||
(defspecial 'ff "ff")
|
||||
(defspecial 'fi "fi")
|
||||
(defspecial 'fl "fl")
|
||||
(defspecial 'Fi "ffi")
|
||||
(defspecial 'Fl "ffl")
|
||||
(defspecial 'S1 "¹")
|
||||
(defspecial 'S2 "²")
|
||||
(defspecial 'S3 "³")
|
||||
(defspecial 'bb "¦") ; broken bar
|
||||
(defspecial 'r! "¡") ; reverse exclamation mark
|
||||
(defspecial 'r? "¿") ; reverse question mark
|
||||
|
||||
|
||||
(defspecial 'bu (lambda _ (warn "rendering \\(bu as `+'") #\+))
|
||||
(defspecial 'sq (lambda _ (warn "rendering \\(sq as `o'") #\o))
|
||||
(defspecial 'dg (lambda _ (warn "rendering \\(dg as `**'") "**"))
|
||||
(defspecial 'dd (lambda _ (warn "rendering \\(dd as `***'") "***"))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Local motion requests and related stuff (mostly ignored).
|
||||
|
||||
(define (motion-ignored request . _)
|
||||
(warn "local motion request \\~a ignored" request))
|
||||
|
||||
(defescape #\u motion-ignored)
|
||||
(defescape #\d motion-ignored)
|
||||
(defescape #\v motion-ignored)
|
||||
|
||||
(define (motion-no-effect request arg)
|
||||
(warn "local motion request \\~a has no effect" request)
|
||||
(parse arg))
|
||||
|
||||
(defescape #\o motion-no-effect)
|
||||
(defescape #\z motion-no-effect)
|
||||
|
||||
(defescape #\k
|
||||
(lambda (k reg)
|
||||
((requestdef 'nr) 'nr reg "0" "")))
|
||||
|
||||
(defescape #\h
|
||||
(lambda (h arg)
|
||||
(let* ((x (parse arg))
|
||||
(n (get-hunits (parse-expression x 0 #\m))))
|
||||
(if (negative? n)
|
||||
(warn "\\h with negative argument ignored")
|
||||
(make-string n #\space)))))
|
||||
|
||||
(defescape #\w
|
||||
(lambda (w s)
|
||||
(let ((scale (get-scaling #\m))
|
||||
(len (string-length (parse s))))
|
||||
(number->string (quotient (* len (car scale)) (cdr scale))))))
|
||||
|
||||
;; Heuristic: generate <hr> if length could be line length, else
|
||||
;; repeat specified character:
|
||||
|
||||
(defescape #\l
|
||||
(lambda (l s)
|
||||
(let* ((p (parse-expression-rest s '(0 . "") #\m))
|
||||
(n (get-hunits (car p)))
|
||||
(c (parse (cdr p))))
|
||||
(if (>= n line-length)
|
||||
"<hr>"
|
||||
(repeat-string n (if (eqv? c "") "_" c))))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Output translations for HTML special characters.
|
||||
|
||||
(defchar #\< "<")
|
||||
(defchar #\> ">")
|
||||
(defchar #\& "&")
|
||||
|
||||
;;; Like parse, but also take char of `"':
|
||||
|
||||
(define (parse-unquote s)
|
||||
(let ((old (defchar #\" """)))
|
||||
(begin1 (parse s) (defchar #\" old))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Font handling.
|
||||
|
||||
(define font-table (make-table 100))
|
||||
|
||||
(define (define-font name open close)
|
||||
(table-store! font-table name (cons open close)))
|
||||
|
||||
(define-font "R" "" "")
|
||||
(define-font "I" '<i> '</i>)
|
||||
(define-font "B" '<b> '</b>)
|
||||
(define-font "C" '<tt> '</tt>)
|
||||
(define-font "CW" '<tt> '</tt>)
|
||||
(define-font "CO" '<i> '</i>) ; a kludge for Courier-Oblique
|
||||
|
||||
(define font-positions (make-vector 10 #f))
|
||||
|
||||
(define (find-font f start)
|
||||
(cond
|
||||
((= start (vector-length font-positions)) #f)
|
||||
((equal? (vector-ref font-positions start) f) start)
|
||||
(else (find-font f (1+ start)))))
|
||||
|
||||
(define (font->position f)
|
||||
(let* ((m (find-font f 1)) (n (if m m (find-font #f 1))))
|
||||
(cond
|
||||
(n (mount-font n f) n)
|
||||
(else
|
||||
(warn "no free font position for font ~a" f) #f))))
|
||||
|
||||
(define (get-font-name name)
|
||||
(cond
|
||||
((table-lookup font-table name) name)
|
||||
(else (warn "unknown font: ~a" name) "R")))
|
||||
|
||||
(define (mount-font i name)
|
||||
(if (and (>= i 1) (< i (vector-length font-positions)))
|
||||
(vector-set! font-positions i (get-font-name name))
|
||||
(warn "invalid font position: `~a'" i)))
|
||||
|
||||
(mount-font 1 "R")
|
||||
(mount-font 2 "I")
|
||||
(mount-font 3 "B")
|
||||
(mount-font 4 "R")
|
||||
|
||||
(defrequest 'fp
|
||||
(lambda (fp where name)
|
||||
(if (not (string->number where))
|
||||
(warn "invalid font position `~a' in .fp" where)
|
||||
(mount-font (string->number where) name) "")))
|
||||
|
||||
(define previous-font 1)
|
||||
(define current-font 1)
|
||||
|
||||
(define (reset-font)
|
||||
(concat (change-font 1) (change-font 1))) ; current and previous
|
||||
|
||||
(define (change-font-at i)
|
||||
(cond
|
||||
((or (< i 1) (>= i (vector-length font-positions)))
|
||||
(warn "invalid font position: `~a'" i))
|
||||
((vector-ref font-positions i)
|
||||
(let ((o (table-lookup font-table
|
||||
(vector-ref font-positions current-font)))
|
||||
(n (table-lookup font-table (vector-ref font-positions i))))
|
||||
(set! previous-font current-font)
|
||||
(set! current-font i)
|
||||
(if (and preform? (not (option 'tt-preformat)))
|
||||
(concat (if (eq? (cdr o) '</tt>) "" (cdr o))
|
||||
(if (eq? (car n) '<tt>) "" (car n)))
|
||||
(concat (cdr o) (car n)))))
|
||||
(else (warn "no font mounted at position ~a" i))))
|
||||
|
||||
(define (change-font f)
|
||||
(cond
|
||||
((number? f)
|
||||
(change-font-at f))
|
||||
((string->number f)
|
||||
(change-font-at (string->number f)))
|
||||
((string=? f "P")
|
||||
(change-font-at previous-font))
|
||||
(else
|
||||
(let ((n (font->position (get-font-name f))))
|
||||
(if n (change-font-at n) "")))))
|
||||
|
||||
(defrequest 'ft
|
||||
(lambda (ft font)
|
||||
(change-font (if (eqv? font "") "P" font))))
|
||||
|
||||
(defescape #\f (requestdef 'ft))
|
||||
|
||||
(defnumreg '.f (lambda _ (number->string current-font)))
|
||||
|
||||
(define-macro (with-font-preserved . body)
|
||||
`(let (($f current-font))
|
||||
(concat (change-font "R") ,@body (change-font $f))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; tbl, eqn, pic.
|
||||
|
||||
(define (copy-preprocess for-eqn? proc-1 proc-2 stop inline)
|
||||
(cond
|
||||
(inline
|
||||
(emit inline #\newline stop)
|
||||
(filter-eqn-line inline))
|
||||
(else
|
||||
(let loop ((x (read-line-expand))
|
||||
(use-output? (not for-eqn?)))
|
||||
(cond ((eof-object? x) use-output?)
|
||||
(else
|
||||
(proc-1 (proc-2 x))
|
||||
(if (string=? x stop)
|
||||
use-output?
|
||||
(loop (read-line-expand)
|
||||
(or (not for-eqn?) (filter-eqn-line x))))))))))
|
||||
|
||||
(define troff-to-gif
|
||||
(let ((image-seqnum 1))
|
||||
(lambda (processor start stop what args inline)
|
||||
(let ((docname (option 'document)))
|
||||
(if (not docname)
|
||||
(begin
|
||||
(warn "~a skipped, because no `document' option given" what)
|
||||
(if (not inline)
|
||||
(skip-lines stop))
|
||||
"")
|
||||
(let* ((num (number->string image-seqnum))
|
||||
(psname (concat docname #\- num ".ps"))
|
||||
(gifname (concat docname #\- num ".gif"))
|
||||
(ref (concat "<img src=\"" gifname
|
||||
"\" alt=\"[" what "]\">\n"))
|
||||
(use-output? #f))
|
||||
(++ image-seqnum)
|
||||
(with-output-to-stream
|
||||
(substitute (concat #\| (option processor)
|
||||
#\| (option 'troff-to-gif)) psname gifname)
|
||||
(emit start #\space (apply spread args) #\newline)
|
||||
(set! use-output? (copy-preprocess (eq? processor 'eqn)
|
||||
emit identity stop inline)))
|
||||
(remove-file psname)
|
||||
(if use-output?
|
||||
(if inline ref (concat "<p>" ref "<p>\n"))
|
||||
(remove-file gifname) "")))))))
|
||||
|
||||
(define (troff-to-text processor start stop what args inline)
|
||||
(let* ((tmpname (substitute "%tmpname%"))
|
||||
(use-output? #f))
|
||||
(with-output-to-stream
|
||||
(substitute (concat #\| (option processor) #\| (option 'troff-to-text))
|
||||
tmpname)
|
||||
(emit start #\space (apply spread args) #\newline)
|
||||
(set! use-output? (copy-preprocess (eq? processor 'eqn)
|
||||
emit identity stop inline)))
|
||||
(let ((text (translate (stream->string tmpname))))
|
||||
(remove-file tmpname)
|
||||
(if use-output?
|
||||
(if inline
|
||||
(with-font-preserved (concat (change-font 2) text))
|
||||
(concat (preform #t) text (preform #f)))
|
||||
""))))
|
||||
|
||||
(define (troff-to-preform processor start stop what args inline)
|
||||
(cond
|
||||
(inline (with-font-preserved (concat (change-font 2) inline)))
|
||||
(else
|
||||
(emit (preform #t) start #\space (apply spread args) #\newline)
|
||||
(copy-preprocess (eq? processor 'eqn) emit translate stop)
|
||||
(preform #f))))
|
||||
|
||||
(define (troff-select-method option-name)
|
||||
(let ((method (option option-name)))
|
||||
(cond ((string=? method "gif") troff-to-gif)
|
||||
((string=? method "text") troff-to-text)
|
||||
((string=? method "copy") troff-to-preform)
|
||||
(else
|
||||
(warn "bad value `~a' for ~a, assuming `text'" method option-name)
|
||||
troff-to-text))))
|
||||
|
||||
(defmacro 'TS
|
||||
(lambda (TS . args)
|
||||
((troff-select-method 'handle-tbl) 'tbl ".TS" ".TE\n" "table" args #f)))
|
||||
|
||||
(defmacro 'EQ
|
||||
(lambda (EQ . args)
|
||||
((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN\n" "equation" args #f)))
|
||||
|
||||
(defmacro 'PS
|
||||
(lambda (PS . args)
|
||||
((troff-select-method 'handle-pic) 'pic ".PS" ".PE\n" "picture" args #f)))
|
||||
|
||||
(defmacro 'TE "")
|
||||
(defmacro 'EN "")
|
||||
(defmacro 'PE "")
|
||||
|
||||
(defequation
|
||||
(lambda (eqn)
|
||||
((troff-select-method 'handle-eqn) 'eqn ".EQ" ".EN\n" "equation" '() eqn)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Miscellaneous troff requests.
|
||||
|
||||
(defrequest 'br
|
||||
(lambda _
|
||||
(if (positive? lines-to-center) "" "<br>\n")))
|
||||
|
||||
(defrequest 'sp
|
||||
(lambda (sp num)
|
||||
(let ((n (if (eqv? num "") 1 (get-vunits (parse-expression num 0 #\v)))))
|
||||
(cond
|
||||
((negative? n)
|
||||
(warn ".sp with negative spacing ignored"))
|
||||
(preform?
|
||||
(repeat-string n "\n"))
|
||||
((zero? n)
|
||||
"<br>\n")
|
||||
(else
|
||||
(with-font-preserved (repeat-string n "<p>\n")))))))
|
||||
|
||||
(defrequest 'ti
|
||||
(lambda (ti num)
|
||||
(let ((n (if (eqv? num "") 0 (get-hunits (parse-expression num 0 #\m)))))
|
||||
(if (negative? n)
|
||||
(warn ".ti with negative indent ignored")
|
||||
(concat "<br>\n" (repeat-string n nbsp))))))
|
||||
|
||||
|
||||
;;; There is no reasonable way to create markup for .tl; just emit the
|
||||
;;; argument:
|
||||
|
||||
(defrequest 'tl
|
||||
(lambda (tl s)
|
||||
(let* ((p (parse s))
|
||||
(t (parse-triple p)))
|
||||
(cond
|
||||
(t
|
||||
(spread (car t) (cadr t) (cddr t) #\newline))
|
||||
((eqv? s "")
|
||||
"")
|
||||
(else
|
||||
(warn "badly formed .tl argument: `~a'" p))))))
|
||||
|
||||
|
||||
;;; Until HTML can center, at least generate a <br> after each line:
|
||||
|
||||
(defrequest 'ce
|
||||
(lambda (ce num)
|
||||
(let ((n (if (eqv? num "") 1 (string->number num))))
|
||||
(if n
|
||||
(center (round n))
|
||||
(warn ".ce argument `~a' not understood" num)))))
|
||||
|
||||
(define lines-to-center 0)
|
||||
|
||||
(define (center n)
|
||||
(set! lines-to-center n)
|
||||
(defevent 'line 50 (if (positive? n) center-processor #f))
|
||||
"")
|
||||
|
||||
(define (center-processor c)
|
||||
(if (positive? (-- lines-to-center))
|
||||
(if (eqv? c #\newline)
|
||||
(emit "<br>\n")))
|
||||
(if (not (positive? lines-to-center))
|
||||
(center 0)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Other definitions.
|
||||
|
||||
;;; Suppress comment if writing to a buffer, because in this case the
|
||||
;;; output is likely to be re-read later (e.g. it may be a macro):
|
||||
|
||||
(defescape #\"
|
||||
(lambda (_ x)
|
||||
(let ((c (string-prune-right x "\n" x))
|
||||
(old (defchar #\tab #f)))
|
||||
(if (and (not (eqv? c "")) (not (stream-buffer? (output-stream))))
|
||||
(emit "<!-- " (translate c) " -->\n"))
|
||||
(defchar #\tab old)
|
||||
#\newline)))
|
||||
|
||||
|
||||
;;; Extra white space at end of sentence:
|
||||
|
||||
(define sentence-event
|
||||
(lambda (c)
|
||||
(concat c "<tt> </tt>\n")))
|
||||
|
||||
(defsentence sentence-event)
|
||||
|
||||
|
||||
;;; Emit standardized output file prolog:
|
||||
|
||||
(define (emit-HTML-prolog)
|
||||
(let ((mailto (option 'mail-address)))
|
||||
(emit "<html>\n<head>\n")
|
||||
(emit "<!-- This file has been generated by "
|
||||
(substitute "%progname% %version%, %date% %time%. -->\n")
|
||||
"<!-- Do not edit! -->\n")
|
||||
(if mailto (emit "<link rev=\"made\" href=\"mailto:" mailto "\">\n"))))
|
||||
|
||||
|
||||
;;; Define a scaling for the usual scaling indicators. Note that the
|
||||
;;; vertical spacing and character width will never change; and the
|
||||
;;; device's vertical/horizontal resolution is 1.
|
||||
|
||||
(define inch 240) ; units per inch
|
||||
|
||||
(set-scaling! #\i inch 1)
|
||||
(set-scaling! #\c (* 50 inch) 127)
|
||||
(set-scaling! #\P inch 6) ; Pica
|
||||
(set-scaling! #\m inch 10)
|
||||
(set-scaling! #\n inch 10)
|
||||
(set-scaling! #\p inch 72)
|
||||
(set-scaling! #\v inch 7)
|
||||
|
||||
;;; Convert from units back to ems and Vs:
|
||||
|
||||
(define (get-hunits x)
|
||||
(let ((s (get-scaling #\m)))
|
||||
(if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
|
||||
|
||||
(define (get-vunits x)
|
||||
(let ((s (get-scaling #\v)))
|
||||
(if x (inexact->exact (/ (* x (cdr s)) (car s))) x)))
|
||||
|
||||
;;; Fake line length:
|
||||
|
||||
(define line-length 65)
|
||||
|
||||
(defnumreg '.l "1560") ; 65 ems
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.4 $
|
||||
;;;;
|
||||
;;;; Definitions for HTML output format to be loaded when no -mfoo
|
||||
;;;; option has been given.
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Simple default start and exit handler.
|
||||
|
||||
(defevent 'start 10
|
||||
(lambda _
|
||||
(let* ((docname (option 'document))
|
||||
(title (option 'title))
|
||||
(t (if title title (if docname docname "(untitled)"))))
|
||||
(if docname
|
||||
(set-output-stream! (open-output-stream (concat docname ".html"))))
|
||||
(emit-HTML-prolog)
|
||||
(emit "<title>" (translate t) "</title>\n</head>\n<body>\n"))))
|
||||
|
||||
(defevent 'exit 10
|
||||
(lambda _
|
||||
(emit (change-font "R") (preform #f))
|
||||
(emit "</body>\n</html>\n")
|
||||
(close-stream (set-output-stream! #f))))
|
||||
|
|
@ -0,0 +1,316 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.18 $
|
||||
;;;;
|
||||
;;;; `man' specific definitions for HTML output format
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Options.
|
||||
|
||||
(define-option 'do-signature 'boolean #t)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Miscellaneous definitions.
|
||||
|
||||
(defstring 'R "®") ; trademark
|
||||
(defstring 'S "") ; change to default point size
|
||||
(defstring 'lq "``")
|
||||
(defstring 'rq "''")
|
||||
|
||||
(define-font 'L '<b> '</b>) ; whatever font L is supposed to be...
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Bookkeeping for .TH, for requests that occur in pairs, etc.
|
||||
|
||||
(define-pair header header? "<h2>\n" "<hr></h2>\n")
|
||||
(define-pair tag-para tag-para? "<dl>\n" "</dl>\n")
|
||||
(define-pair list-para list-para? "<ul>\n" "</ul>\n")
|
||||
(define-pair hang-para hang-para? "<dt>" "<dd>\n")
|
||||
|
||||
(define (reset-everything)
|
||||
(concat
|
||||
(reset-font)
|
||||
(center 0)
|
||||
(header #f)
|
||||
(preform #f)
|
||||
(hang-para #f)
|
||||
(tag-para #f)
|
||||
(list-para #f)))
|
||||
|
||||
(define-nested-pair indent indent-level "<dl><dt><dd>\n" "</dl>\n")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; File prolog and epilog functions.
|
||||
|
||||
(defevent 'prolog 10
|
||||
(lambda (pathname filename)
|
||||
(if (not (string=? filename "stdin"))
|
||||
(set-option! 'document filename))
|
||||
(let ((docname (option 'document)))
|
||||
(if docname
|
||||
(set-output-stream! (open-output-stream (concat docname ".html"))))
|
||||
(emit-HTML-prolog))))
|
||||
|
||||
(defevent 'epilog 10
|
||||
(lambda _
|
||||
(complain-if-no-title)
|
||||
(emit (reset-everything) (indent 0))
|
||||
(if (option 'do-signature)
|
||||
(emit
|
||||
(substitute
|
||||
"<p><hr>\nMarkup created by <em>%progname%</em> %version%,")
|
||||
nbsp nbsp
|
||||
(substitute "%monthname+% %day%, %year%.\n")))
|
||||
(emit "</body>\n</html>\n")
|
||||
(close-stream (set-output-stream! #f))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Title, section, subsection.
|
||||
|
||||
(define title-seen? #f)
|
||||
|
||||
(define (complain-if-no-title)
|
||||
(if (not title-seen?)
|
||||
(quit "manual page must begin with .TH request")))
|
||||
|
||||
(defmacro 'TH
|
||||
(lambda (TH what section . _)
|
||||
(let ((title (option 'title)))
|
||||
(set! title-seen? #t)
|
||||
(concat "<title>"
|
||||
(substitute (if title title "Manual page for %1%(%2%)")
|
||||
(translate what) (translate section))
|
||||
"</title>\n</head>\n<body>\n"))))
|
||||
|
||||
(defmacro 'SH
|
||||
(lambda (SH first . rest)
|
||||
(complain-if-no-title)
|
||||
(emit (reset-everything) (indent 0))
|
||||
(if (string=? first "NAME")
|
||||
(header #t)
|
||||
(concat "<h2>" (parse (apply spread first rest)) "</h2>\n"))))
|
||||
|
||||
(defmacro 'SS
|
||||
(lambda (SS . args)
|
||||
(complain-if-no-title)
|
||||
(emit (reset-everything) (indent 0))
|
||||
(cond
|
||||
((null? args)
|
||||
(defevent 'line 11
|
||||
(lambda _ (emit "</h3>\n") (defevent 'line 11 #f)))
|
||||
(emit "<h3>"))
|
||||
(else
|
||||
(concat "<h3>" (parse (apply spread args)) "</h3>\n")))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Font switching requests.
|
||||
;;;
|
||||
;;; Both with-font and with-fonts include a terminating newline in the
|
||||
;;; parsing, because people are using .I xxx\c and .BR xxx\c etc., and
|
||||
;;; end-of-sentence must be detected in situations like .BR send(2) .
|
||||
|
||||
(define (with-font font words)
|
||||
(let ((old current-font))
|
||||
(cond
|
||||
((null? words)
|
||||
(defevent 'line 10
|
||||
(lambda _ (emit (change-font old)) (defevent 'line 10 #f)))
|
||||
(emit (change-font font) #\newline))
|
||||
(else
|
||||
(concat (change-font font)
|
||||
(parse (apply spread words) #\newline)
|
||||
(change-font old))))))
|
||||
|
||||
(defmacro 'I (lambda (I . args) (with-font "I" args)))
|
||||
(defmacro 'B (lambda (B . args) (with-font "B" args)))
|
||||
|
||||
(defmacro 'SB (requestdef 'B))
|
||||
|
||||
(defmacro 'SM
|
||||
(lambda (SM . words)
|
||||
(if (null? words) "" (parse (apply spread words) #\newline))))
|
||||
|
||||
(define (with-fonts f1 f2 words)
|
||||
(define (recurse f1 f2 words)
|
||||
(if (null? words)
|
||||
""
|
||||
(concat (change-font f1)
|
||||
(parse (concat (car words)
|
||||
(if (null? (cdr words)) #\newline "")))
|
||||
(recurse f2 f1 (cdr words)))))
|
||||
(let ((old current-font))
|
||||
(concat (recurse f1 f2 words) (change-font old))))
|
||||
|
||||
(defmacro 'BI (lambda (BI . args) (with-fonts "B" "I" args)))
|
||||
(defmacro 'BR (lambda (BR . args) (with-fonts "B" "R" args)))
|
||||
(defmacro 'IB (lambda (IB . args) (with-fonts "I" "B" args)))
|
||||
(defmacro 'IR (lambda (IR . args) (with-fonts "I" "R" args)))
|
||||
(defmacro 'RB (lambda (RB . args) (with-fonts "R" "B" args)))
|
||||
(defmacro 'RI (lambda (RB . args) (with-fonts "R" "I" args)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Indented paragraphs with labels.
|
||||
;;;
|
||||
;;; A heuristic is used to determine whether to emit a bulleted list
|
||||
;;; or a tagged list: .TP with \(bu in the next input line and
|
||||
;;; .IP with \(bu as argument both start a bulleted list. Of course, in
|
||||
;;; case the style changes later, we have a problem and may want to end
|
||||
;;; the current list and begin a new one with the new style.
|
||||
|
||||
(define (next-para-TP)
|
||||
(cond
|
||||
(tag-para?
|
||||
(defevent 'line 12
|
||||
(lambda _ (emit (reset-font) "<dd>\n") (defevent 'line 12 #f)))
|
||||
(emit "<dt>"))
|
||||
(else
|
||||
"<li>")))
|
||||
|
||||
(define (next-para-IP arg)
|
||||
(cond
|
||||
(tag-para?
|
||||
(if (null? arg)
|
||||
"<dt><dd><p>\n"
|
||||
(concat "<dt>" (parse (car arg)) "<dd>\n")))
|
||||
((or (null? arg) (string=? (car arg) "\\(bu"))
|
||||
"<li>\n")
|
||||
(else
|
||||
(warn ".IP `arg' in a list that was begun as non-tagged")
|
||||
(concat "<li>" (parse (car arg)) "<br>\n"))))
|
||||
|
||||
(defmacro 'TP
|
||||
(lambda _
|
||||
(emit (reset-font) (hang-para #f))
|
||||
(if preform?
|
||||
(begin
|
||||
(surprise ".TP inside .nf/.fi") #\newline)
|
||||
(let ((next (read-line)))
|
||||
(if (eof-object? next) (set! next #\newline))
|
||||
(cond
|
||||
((string=? next "\\(bu\n")
|
||||
(cond
|
||||
(tag-para?
|
||||
(emit (tag-para #f) (list-para #t))) ; change style
|
||||
(else
|
||||
(emit (list-para #t)))))
|
||||
(else
|
||||
(unread-line next)
|
||||
(cond
|
||||
(list-para?
|
||||
(emit (list-para #f) (tag-para #t))) ; change style
|
||||
(else
|
||||
(emit (tag-para #t))))))
|
||||
(next-para-TP)))))
|
||||
|
||||
(defmacro 'IP
|
||||
(lambda (IP . arg)
|
||||
(emit (reset-font) (hang-para #f))
|
||||
(if preform?
|
||||
(begin
|
||||
(surprise ".IP inside .nf/.fi")
|
||||
(if (not (null? arg)) (concat (parse (car arg)) #\newline) #\newline))
|
||||
(if (or tag-para? list-para?)
|
||||
(next-para-IP arg)
|
||||
(cond
|
||||
((and (not (null? arg)) (string=? (car arg) "\\(bu"))
|
||||
(emit (list-para #t))
|
||||
(set! arg '()))
|
||||
(else
|
||||
(emit (tag-para #t))))
|
||||
(next-para-IP arg)))))
|
||||
|
||||
|
||||
;;; A hanging indent cannot be achieved in HTML. Therefore we have to
|
||||
;;; kludge .HP by beginning a `tag-para' and putting everything up to
|
||||
;;; the next line break between the <dt> and <dd>.
|
||||
|
||||
(defmacro 'HP
|
||||
(lambda _
|
||||
(emit (reset-font) (hang-para #f))
|
||||
(cond
|
||||
(preform?
|
||||
(surprise ".HP inside .nf/.fi") #\newline)
|
||||
(else
|
||||
(if list-para? (emit (list-para #f))) ; change style
|
||||
(concat (tag-para #t) (hang-para #t))))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Relative indent.
|
||||
|
||||
(define (relative-indent request . _)
|
||||
(if preform?
|
||||
(surprise ".RS/.RE inside .nf/.fi"))
|
||||
(emit (reset-font) (hang-para #f) (tag-para #f) (list-para #f))
|
||||
(with-preform-preserved
|
||||
(indent (if (string=? request "RS") '+ '-))))
|
||||
|
||||
(defmacro 'RS relative-indent)
|
||||
(defmacro 'RE relative-indent)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Paragraphs.
|
||||
|
||||
(define (paragraph . _)
|
||||
(concat (reset-everything) "<p>\n"))
|
||||
|
||||
(defmacro 'LP paragraph)
|
||||
(defmacro 'PP paragraph)
|
||||
(defmacro 'P paragraph)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Miscellaneous break-causing requests (must end .HP paragraph).
|
||||
|
||||
(defrequest 'sp
|
||||
(let ((orig (requestdef 'sp)))
|
||||
(lambda (sp num)
|
||||
(concat (hang-para #f) (orig sp num)))))
|
||||
|
||||
(defrequest 'bp (lambda _ (hang-para #f)))
|
||||
|
||||
(defrequest 'ti
|
||||
(let ((orig (requestdef 'ti)))
|
||||
(lambda (ti num)
|
||||
(concat (hang-para #f) (orig ti num)))))
|
||||
|
||||
;;; Kludge: Suppress <br> immediately after `hang-para' to avoid excessive
|
||||
;;; white space
|
||||
|
||||
(defrequest 'br
|
||||
(lambda _
|
||||
(if hang-para?
|
||||
(hang-para #f)
|
||||
(concat (hang-para #f) "<br>\n"))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Bogus or SunOS-specific stuff.
|
||||
|
||||
(defmacro 'TX
|
||||
(lambda (TX name . id)
|
||||
(concat "[a manual with the abbreviation " (parse name) "]"
|
||||
(if (null? id) "" (car id)) #\newline)))
|
||||
|
||||
(defmacro 'IX "")
|
||||
(defmacro 'DT "")
|
||||
(defmacro 'PD "")
|
||||
(defmacro 'UC "")
|
||||
|
|
@ -0,0 +1,628 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.14 $
|
||||
;;;;
|
||||
;;;; `ms' specific definitions for HTML output format
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Options.
|
||||
|
||||
(define-option 'signature 'string "")
|
||||
(define-option 'split 'integer 0)
|
||||
(define-option 'toc 'boolean #t)
|
||||
(define-option 'toc-header 'string "Table of Contents")
|
||||
(define-option 'pp-indent 'integer 3)
|
||||
(define-option 'footnotes-header 'string "Footnotes")
|
||||
(define-option 'footnote-reference 'string "[note %1%]")
|
||||
(define-option 'footnote-anchor 'string "[%1%]")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Predefined strings and number registers.
|
||||
|
||||
(defstring 'Q "``")
|
||||
(defstring 'U "''")
|
||||
(defstring '- "--") ; em-dash
|
||||
(defstring 'MO (substitute "%monthname+%"))
|
||||
(defstring 'DY (substitute "%monthname+% %day%, %year%"))
|
||||
|
||||
(defnumreg 'PN #\0)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; General bookkeeping.
|
||||
|
||||
|
||||
(define split-sections? #f) ; #t if `split' option is positive
|
||||
|
||||
|
||||
(define-pair abstract abstract? "" "<hr>\n")
|
||||
(define-pair title title? "<h1>\n" "</h1>\n")
|
||||
(define-pair secthdr secthdr? "<h2>\n" "</h2>\n")
|
||||
(define-pair tag-para tag-para? "<dl>\n" "</dl>\n")
|
||||
(define-pair list-para list-para? "<ul>\n" "</ul>\n")
|
||||
(define-pair quoted quoted? "<blockquote>\n" "</blockquote>\n")
|
||||
|
||||
(define (reset-everything)
|
||||
(emit
|
||||
(reset-font)
|
||||
(center 0)
|
||||
(quoted #f)
|
||||
(secthdr #f)
|
||||
(preform #f)
|
||||
(tag-para #f)
|
||||
(list-para #f)
|
||||
(reset-title-features))
|
||||
(header-processor #f))
|
||||
|
||||
(define-nested-pair indent indent-level "<dl><dt><dd>\n" "</dl>\n")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Manage HTML output files.
|
||||
|
||||
(define HTML-streams '())
|
||||
|
||||
(define (push-HTML-stream file-suffix title-suffix)
|
||||
(let* ((docname (option 'document))
|
||||
(title (option 'title))
|
||||
(t (concat (if title title docname) title-suffix))
|
||||
(fn (if file-suffix (concat docname file-suffix ".html") #f))
|
||||
(s (if fn (open-output-stream fn) #f)))
|
||||
(close-stream (set-output-stream! #f))
|
||||
(set-output-stream! s)
|
||||
(list-push! HTML-streams fn)
|
||||
(emit-HTML-prolog)
|
||||
(emit "<title>" (translate t) "</title>\n</head><body>\n")))
|
||||
|
||||
(define (pop-HTML-stream)
|
||||
(if (not (eqv? (option 'signature) ""))
|
||||
(emit "<p><hr>\n" (substitute (option 'signature))) #\newline)
|
||||
(emit "</body>\n</html>\n")
|
||||
(list-pop! HTML-streams)
|
||||
(close-stream (set-output-stream! #f))
|
||||
(if (and (not (null? HTML-streams)) (car HTML-streams))
|
||||
(set-output-stream! (append-output-stream (car HTML-streams)))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Callback procedure called by hyper.scm when creating hypertext anchor.
|
||||
|
||||
(define (query-anchor request label)
|
||||
(lambda (op)
|
||||
(case op
|
||||
(allowed? #t)
|
||||
(emit-anchor? #t)
|
||||
(filename
|
||||
(if (not (stream-file? (output-stream)))
|
||||
(car HTML-streams)
|
||||
(stream-target (output-stream)))))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Generate hypertext reference and anchor.
|
||||
|
||||
(define (make-href type index contents)
|
||||
(let* ((docname (option 'document))
|
||||
(file
|
||||
(case type
|
||||
((section toc) (car HTML-streams))
|
||||
(footnote (if split-sections? (concat docname "-notes.html") "")))))
|
||||
(format #f "<a href=\"~a#~a~a\">~a" file type index
|
||||
(if contents (concat contents "</a>\n") ""))))
|
||||
|
||||
(define (make-anchor type index contents)
|
||||
(format #f "<a name=\"~a~a\">~a</a>" type index contents))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Automatically generated TOC.
|
||||
|
||||
(define auto-toc-entry
|
||||
(let ((last-level 0))
|
||||
(lambda (anchor entry level labelnum)
|
||||
(with-output-appended-to-stream "[autotoc]"
|
||||
(emit (repeat-string (- level last-level) "<ul>")
|
||||
(repeat-string (- last-level level) "</ul>"))
|
||||
(set! last-level level)
|
||||
(if (positive? level)
|
||||
(emit "<li>" (make-href 'section labelnum anchor) entry))))))
|
||||
|
||||
(define (auto-toc-spill)
|
||||
(auto-toc-entry "" "" 0 0)
|
||||
(let ((toc (stream->string "[autotoc]")))
|
||||
(if (not (eqv? toc ""))
|
||||
(emit "<h2>" (substitute (option 'toc-header)) "</h2>\n" toc))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Start and exit event functions.
|
||||
|
||||
(defevent 'start 10
|
||||
(lambda _
|
||||
(set! split-sections? (positive? (option 'split)))
|
||||
(let ((docname (option 'document)))
|
||||
(if (not (or docname (option 'title)))
|
||||
(quit "you must set either document= or title="))
|
||||
(if (and split-sections? (not docname))
|
||||
(quit "you must set document= for non-zero `split'"))
|
||||
(push-HTML-stream (if docname "" #f) ""))))
|
||||
|
||||
(defevent 'exit 10
|
||||
(lambda _
|
||||
(reset-everything)
|
||||
(emit (indent 0))
|
||||
(footnote-processor 'spill)
|
||||
(do () ((null? (cdr HTML-streams))) (pop-HTML-stream))
|
||||
(if (option 'toc)
|
||||
(auto-toc-spill))
|
||||
(pop-HTML-stream)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Title features, abstract.
|
||||
|
||||
(define got-title? #f)
|
||||
|
||||
(define (reset-title-features)
|
||||
(concat (title #f)
|
||||
(begin1 (if got-title? "<hr>\n" "") (set! got-title? #f))))
|
||||
|
||||
(defmacro 'TL
|
||||
(lambda _
|
||||
(cond
|
||||
(got-title?
|
||||
(warn ".TL is only allowed once"))
|
||||
(else
|
||||
(reset-everything)
|
||||
(set! got-title? #t)
|
||||
(title #t)))))
|
||||
|
||||
(defmacro 'AU
|
||||
(lambda _
|
||||
(emit (title #f) "<p>\n" (change-font 2))
|
||||
(center 999)))
|
||||
|
||||
(defmacro 'AI
|
||||
(lambda _
|
||||
(emit (title #f) "<br>\n" (change-font 1))
|
||||
(center 999)))
|
||||
|
||||
(defmacro 'AB
|
||||
(lambda (AB . args)
|
||||
(reset-everything)
|
||||
(abstract #t)
|
||||
(cond ((null? args)
|
||||
"<h2>ABSTRACT</h2>\n<p>\n")
|
||||
((string=? (car args) "no")
|
||||
"<p>\n")
|
||||
(else
|
||||
(concat "<h2>" (parse (car args)) "</h2>\n<p>\n")))))
|
||||
|
||||
(defmacro 'AE
|
||||
(lambda _
|
||||
(cond (abstract? (reset-everything) (abstract #f))
|
||||
(else (warn ".AE without preceding .AB")))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Numbered sections.
|
||||
|
||||
(define sections (list 0))
|
||||
|
||||
(define (increment-section! s n)
|
||||
(if (positive? n)
|
||||
(increment-section! (cdr s) (1- n))
|
||||
(set-car! s (if (char? (car s))
|
||||
(integer->char (modulo (1+ (char->integer (car s))) 256))
|
||||
(1+ (car s))))
|
||||
(set-cdr! s '())))
|
||||
|
||||
(define (section-number s n)
|
||||
(if (zero? n)
|
||||
""
|
||||
(format #f "~a.~a" (car s) (section-number (cdr s) (1- n)))))
|
||||
|
||||
(define (verify-section-number s)
|
||||
(cond ((eqv? s "") #f)
|
||||
((string->number s) (string->number s))
|
||||
((char-alphabetic? (string-ref s 0)) (string-ref s 0))
|
||||
(else #f)))
|
||||
|
||||
(define (numbered-section args)
|
||||
(cond
|
||||
((null? args)
|
||||
(increment-section! sections 0)
|
||||
(defstring 'SN (section-number sections 1))
|
||||
1)
|
||||
((string=? (car args) "S")
|
||||
(cond
|
||||
((null? (cdr args))
|
||||
(warn ".NH with `S' argument but no numbers")
|
||||
1)
|
||||
(else
|
||||
(let ((new (map verify-section-number (cdr args))))
|
||||
(if (memq #f new)
|
||||
(warn "bad section number in .NH request")
|
||||
(set! sections new))
|
||||
(defstring 'SN (section-number new (length new)))
|
||||
(length new)))))
|
||||
(else
|
||||
(let ((level (string->number (car args))))
|
||||
(if (not level)
|
||||
(begin
|
||||
(warn "~a is not a valid section level" (car args))
|
||||
(set! level 1)))
|
||||
(if (< (length sections) level)
|
||||
(append! sections (make-list (- level (length sections)) 0)))
|
||||
(increment-section! sections (1- level))
|
||||
(defstring 'SN (section-number sections level))
|
||||
level))))
|
||||
|
||||
(defmacro 'NH
|
||||
(lambda (NH . args)
|
||||
(reset-everything)
|
||||
(emit (indent 0))
|
||||
(let ((level (numbered-section args)))
|
||||
(if (and split-sections? (<= level (option 'split)))
|
||||
(let* ((sect (stringdef 'SN))
|
||||
(suff (concat #\- (string-prune-right sect "." sect))))
|
||||
(push-HTML-stream suff (concat ", section " sect))))
|
||||
(header-processor #t level))))
|
||||
|
||||
(define header-processor
|
||||
(let ((stream #f) (inside? #f) (seq 1) (level 0))
|
||||
(lambda (enter? . arg)
|
||||
(cond
|
||||
((and enter? (not inside?))
|
||||
(set! level (car arg))
|
||||
(set! stream (set-output-stream! (open-output-stream "[header]"))))
|
||||
((and inside? (not enter?))
|
||||
(close-stream (set-output-stream! stream))
|
||||
(let ((hdr (stream->string "[header]"))
|
||||
(sectno (stringdef 'SN)))
|
||||
(cond
|
||||
((and split-sections? (option 'toc))
|
||||
(auto-toc-entry (concat sectno #\space) hdr level seq)
|
||||
(emit "<h2>" (make-anchor 'section seq sectno)))
|
||||
(else
|
||||
(emit "<h2>" sectno)))
|
||||
(emit nbsp hdr "</h2>\n")
|
||||
(++ seq))))
|
||||
(set! inside? enter?)
|
||||
"")))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Font switching and related requests.
|
||||
|
||||
(define (with-font font . args)
|
||||
(let ((old current-font))
|
||||
(cond
|
||||
((null? args)
|
||||
(concat (change-font font) #\newline))
|
||||
((null? (cdr args))
|
||||
(concat (change-font font) (parse (car args) #\newline)
|
||||
(change-font old)))
|
||||
(else
|
||||
(concat (change-font font) (parse (car args)) (change-font old)
|
||||
(parse (cadr args) #\newline))))))
|
||||
|
||||
(defmacro 'I with-font)
|
||||
(defmacro 'B with-font)
|
||||
(defmacro 'R with-font)
|
||||
|
||||
(defmacro 'UL (lambda (UL) (with-font "I"))) ; <u> doesn't work
|
||||
|
||||
(defmacro 'SM
|
||||
(lambda (SM . words)
|
||||
(if (null? words) "" (parse (apply spread words) #\newline))))
|
||||
|
||||
(defmacro 'LG (requestdef 'SM))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Indented paragraph with optional label.
|
||||
|
||||
(define (indented-paragraph IP . arg)
|
||||
(define (non-tagged? s)
|
||||
(or (null? s) (member (car s) '("\\(bu" "\\(sq" "\\-"))))
|
||||
(emit (reset-font) (secthdr #f) (reset-title-features))
|
||||
(header-processor #f)
|
||||
(cond
|
||||
(preform?
|
||||
(surprise ".IP inside .nf/.fi")
|
||||
(if (not (null? arg)) (concat (parse (car arg)) #\newline) #\newline))
|
||||
(tag-para?
|
||||
(if (null? arg)
|
||||
"<dt><dd><p>\n"
|
||||
(concat "<dt>" (parse (car arg)) "<dd>\n")))
|
||||
(list-para?
|
||||
(cond
|
||||
((non-tagged? arg)
|
||||
"<li>\n")
|
||||
(else
|
||||
(warn ".IP `arg' in a list that was begun as non-tagged")
|
||||
(concat "<li>" (parse (car arg)) "<br>\n"))))
|
||||
((non-tagged? arg)
|
||||
(concat (list-para #t) (indented-paragraph IP)))
|
||||
(else
|
||||
(concat (tag-para #t) (indented-paragraph IP (car arg))))))
|
||||
|
||||
(defmacro 'IP indented-paragraph)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Relative indent.
|
||||
|
||||
(define (relative-indent request . _)
|
||||
(if preform?
|
||||
(surprise ".RS/.RE inside .nf/.fi"))
|
||||
(emit (reset-font) (tag-para #f) (list-para #f))
|
||||
(with-preform-preserved
|
||||
(indent (if (string=? request "RS") '+ '-))))
|
||||
|
||||
(defmacro 'RS relative-indent)
|
||||
(defmacro 'RE relative-indent)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Displays.
|
||||
|
||||
(define display-saved-font #f)
|
||||
(define inside-display? #f)
|
||||
(define indented-display? #f)
|
||||
|
||||
(define (display-start type)
|
||||
(if (or (string=? type "C") (string=? type "B"))
|
||||
(begin
|
||||
(warn "display type ~a not supported (using I)" type)
|
||||
(set! type "I")))
|
||||
(cond
|
||||
((or (not (= (string-length type) 1))
|
||||
(not (memq (string-ref type 0) '(#\I #\L #\C #\B))))
|
||||
(warn "illegal display type `~a'" type))
|
||||
(inside-display?
|
||||
(warn "nested display ignored"))
|
||||
(preform?
|
||||
(warn "display inside .nf/.fi ignored"))
|
||||
(else
|
||||
(set! display-saved-font current-font)
|
||||
(emit (reset-font))
|
||||
(set! indented-display? (string=? type "I"))
|
||||
(if indented-display?
|
||||
(emit (indent '+)))
|
||||
(set! inside-display? #t)
|
||||
(preform #t))))
|
||||
|
||||
(defmacro 'DS
|
||||
(lambda (DS . args)
|
||||
(display-start (if (null? args) "I" (car args)))))
|
||||
|
||||
(defmacro 'ID (lambda _ (display-start "I")))
|
||||
(defmacro 'LD (lambda _ (display-start "L")))
|
||||
(defmacro 'CD (lambda _ (display-start "C")))
|
||||
(defmacro 'BD (lambda _ (display-start "B")))
|
||||
|
||||
(defmacro 'DE
|
||||
(lambda _
|
||||
(cond
|
||||
((not inside-display?)
|
||||
(warn ".DE without matching display start"))
|
||||
(else
|
||||
(set! inside-display? #f)
|
||||
(emit
|
||||
(with-font-preserved
|
||||
(preform #f)
|
||||
(if indented-display? (indent '-) ""))
|
||||
(change-font display-saved-font))
|
||||
""))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Footnotes.
|
||||
|
||||
;; Generating \[***] for \** allows us to defer creating the anchor from
|
||||
;; string expansion time to output time. Otherwise we couldn't use <...>.
|
||||
|
||||
(defstring '* "\\[***]")
|
||||
|
||||
(define **-count 0)
|
||||
|
||||
(defspecial '***
|
||||
(lambda _
|
||||
(++ **-count)
|
||||
(footnote-anchor (substitute (option 'footnote-reference)
|
||||
(number->string **-count)))))
|
||||
|
||||
(define next-footnote 0)
|
||||
|
||||
(define (footnote-anchor sym)
|
||||
(++ next-footnote)
|
||||
(with-font-preserved
|
||||
(concat (change-font 1) (make-href 'footnote next-footnote sym))))
|
||||
|
||||
;; New request to generate a footnote anchor; an alternative to \**.
|
||||
;; Should be followed by .FS. Do not use `.FA \**'.
|
||||
|
||||
(defmacro 'FA
|
||||
(lambda (FA arg) (footnote-anchor (parse arg))))
|
||||
|
||||
|
||||
(define footnote-processor
|
||||
(let ((stream #f) (inside? #f))
|
||||
(lambda (op . arg)
|
||||
(case op
|
||||
(begin
|
||||
(cond
|
||||
(inside?
|
||||
(surprise "nested .FS"))
|
||||
(else
|
||||
(set! inside? #t)
|
||||
(set! stream (set-output-stream!
|
||||
(append-output-stream "[footnotes]")))
|
||||
(emit "<p>\n")
|
||||
(let ((anchor
|
||||
(cond ((not (null? arg))
|
||||
(parse (car arg)))
|
||||
((positive? **-count)
|
||||
(substitute (option 'footnote-anchor)
|
||||
(number->string **-count)))
|
||||
(else #f))))
|
||||
(if anchor
|
||||
(emit "<b>" (make-anchor 'footnote next-footnote anchor)
|
||||
"</b>" nbsp))))))
|
||||
(end
|
||||
(cond
|
||||
(inside?
|
||||
(set! inside? #f)
|
||||
(close-stream (set-output-stream! stream)))
|
||||
(else (warn ".FE without matching .FS"))))
|
||||
(spill
|
||||
(if inside? (quit "unterminated footnote at end of document"))
|
||||
(let ((contents (stream->string "[footnotes]"))
|
||||
(hdr (substitute (option 'footnotes-header))))
|
||||
(cond
|
||||
((not (eqv? contents ""))
|
||||
(if split-sections?
|
||||
(push-HTML-stream "-notes" ", footnotes"))
|
||||
(cond ((and split-sections? (option 'toc))
|
||||
(auto-toc-entry hdr "" 1 0)
|
||||
(emit "<h2>" (make-anchor 'section 0 hdr)))
|
||||
(else (emit "<h2>" hdr)))
|
||||
(emit "</h2>\n" contents))
|
||||
((positive? next-footnote)
|
||||
(warn "footnote anchor used, but no .FS"))))))
|
||||
"")))
|
||||
|
||||
(defmacro 'FS
|
||||
(lambda (FS . arg)
|
||||
(apply footnote-processor 'begin arg)))
|
||||
|
||||
(defmacro 'FE
|
||||
(lambda _ (footnote-processor 'end)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; TOC macros.
|
||||
|
||||
(define toc-processor
|
||||
(let ((stream #f) (inside? #f) (seq 1))
|
||||
(lambda (op . arg)
|
||||
(case op
|
||||
(begin
|
||||
(cond
|
||||
(inside?
|
||||
(surprise "nested .XS"))
|
||||
(else
|
||||
(set! inside? #t)
|
||||
(emit (make-anchor 'toc seq " ") #\newline)
|
||||
(set! stream (set-output-stream! (append-output-stream "[toc]")))
|
||||
(if (>= (length arg) 2)
|
||||
(emit
|
||||
(repeat-string
|
||||
(get-hunits (parse-expression (cadr arg) 0 #\n)) nbsp)))
|
||||
(if (option 'document)
|
||||
(emit (make-href 'toc seq #f)))
|
||||
(++ seq))))
|
||||
(end
|
||||
(cond
|
||||
(inside?
|
||||
(set! inside? #f)
|
||||
(if (option 'document) (emit "</a>\n"))
|
||||
(emit "<br>\n")
|
||||
(close-stream (set-output-stream! stream)))
|
||||
(else (warn ".XE or .XA without matching .XS"))))
|
||||
(spill
|
||||
(if inside? (quit "unterminated .XE"))
|
||||
(if (or (null? arg) (not (string=? (car arg) "no")))
|
||||
(emit "<h2>Table of Contents</h2>\n"))
|
||||
(emit (stream->string "[toc]"))))
|
||||
"")))
|
||||
|
||||
(defmacro 'XS
|
||||
(lambda (XS . arg)
|
||||
(apply toc-processor 'begin arg)))
|
||||
|
||||
(defmacro 'XE (lambda _ (toc-processor 'end)))
|
||||
(defmacro 'XA (lambda _ (toc-processor 'end) (toc-processor 'begin)))
|
||||
|
||||
(defmacro 'PX
|
||||
(lambda (PX . arg)
|
||||
(apply toc-processor 'spill arg)))
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Paragraphs of various kinds.
|
||||
|
||||
(define-macro (define-paragraph request . body)
|
||||
`(defmacro ,request (lambda _ (reset-everything) ,@body)))
|
||||
|
||||
(define-paragraph 'LP "<p>\n")
|
||||
(define-paragraph 'PP (concat "<p>\n"
|
||||
(repeat-string (option 'pp-indent) nbsp)))
|
||||
(define-paragraph 'QP (quoted #t))
|
||||
(define-paragraph 'SH (secthdr #t))
|
||||
(define-paragraph 'RT)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Requests that must be ignored, either because the function cannot
|
||||
;;; be expressed in HTML or because they assume a page structure.
|
||||
|
||||
(defmacro 'AM "") ; better accents
|
||||
(defmacro 'BT "") ; bottom title
|
||||
(defmacro 'CM "") ; cut mark between pages
|
||||
(defmacro 'CT "") ; chapter title
|
||||
(defmacro 'DA "") ; force date at page bottom
|
||||
(defmacro 'EF "") ; even footer
|
||||
(defmacro 'EH "") ; even header
|
||||
(defmacro 'HD "") ; optional page header
|
||||
(defmacro 'KE "") ; keep end
|
||||
(defmacro 'KF "") ; floating keep
|
||||
(defmacro 'KS "") ; keep
|
||||
(defmacro 'ND "") ; no date in footer
|
||||
(defmacro 'NL "") ; reset point size to normal
|
||||
(defmacro 'OF "") ; odd footer
|
||||
(defmacro 'OH "") ; odd header
|
||||
(defmacro 'P1 "") ; print header on 1st page
|
||||
(defmacro 'PT "") ; page title
|
||||
(defmacro 'TM "") ; UCB thesis mode
|
||||
|
||||
(defmacro 'BX ; boxed word
|
||||
(lambda (BX word)
|
||||
(parse word #\newline)))
|
||||
|
||||
(define (multi-column-ignored request . _)
|
||||
(warn "multi-column request .~a not supported" request))
|
||||
|
||||
(defmacro 'MC multi-column-ignored)
|
||||
(defmacro '1C multi-column-ignored)
|
||||
(defmacro '2C multi-column-ignored)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Anachronisms, kludges, etc.
|
||||
|
||||
(defmacro 'UX "UNIX")
|
||||
|
||||
(defmacro 'B1 "<hr>\n")
|
||||
(defmacro 'B2 "<hr>\n")
|
||||
|
|
@ -0,0 +1,166 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.5 $
|
||||
;;;;
|
||||
;;;; General-purpose hypertext requests
|
||||
;;;;
|
||||
;;;; This implementation is undocumented and is likely to change in
|
||||
;;;; future relases.
|
||||
|
||||
|
||||
(if (not (string=? (substitute "%format%") "html"))
|
||||
(quit "hypertext functions require -fhtml"))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Data structures.
|
||||
|
||||
(define ht-anchors '())
|
||||
(define ht-references '())
|
||||
|
||||
|
||||
(define anchor-name car)
|
||||
(define anchor-location cdr)
|
||||
|
||||
(define (anchor-create name location)
|
||||
(cons name location))
|
||||
|
||||
(define ref-filename car)
|
||||
(define ref-offset cadr)
|
||||
(define ref-location caddr)
|
||||
(define ref-name cadddr)
|
||||
|
||||
(define (ref-unresolved? x)
|
||||
(eqv? (ref-location x) ""))
|
||||
|
||||
(define (set-ref-location! x l)
|
||||
(set-car! (cddr x) l))
|
||||
|
||||
(define (ref-create filename offset name)
|
||||
(list filename offset "" name))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Figure out if hypertext request is allowed at a given place and the
|
||||
;;; filename to use in hypertext anchor.
|
||||
|
||||
(define (default-query-anchor request label)
|
||||
(lambda (op)
|
||||
(case op
|
||||
(allowed? #t)
|
||||
(emit-anchor? #t)
|
||||
(filename (stream-target (output-stream))))))
|
||||
|
||||
(define (ht-querier request label)
|
||||
(let ((q (if (bound? 'query-anchor) query-anchor default-query-anchor)))
|
||||
(q request label)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Create hypertext anchor.
|
||||
;;;
|
||||
;;; .Ha label anchor-text
|
||||
|
||||
(defmacro 'Ha
|
||||
(lambda (Ha name contents)
|
||||
(let* ((q (ht-querier '.Ha name))
|
||||
(location (q 'filename)))
|
||||
(cond
|
||||
((not (q 'allowed?))
|
||||
"")
|
||||
((assoc name ht-anchors)
|
||||
(warn ".Ha with duplicate anchor name `~a'" name))
|
||||
(else
|
||||
(resolve-ht-reference name location)
|
||||
(list-push! ht-anchors (anchor-create name location))
|
||||
(if (q 'emit-anchor?)
|
||||
(concat (format #f "<a name=\"~a\">~a</a>" (parse-unquote name)
|
||||
(parse contents)))
|
||||
""))))))
|
||||
|
||||
(define (resolve-ht-reference name location)
|
||||
(let loop ((x ht-references))
|
||||
(cond
|
||||
((not (null? x))
|
||||
(if (and (ref-unresolved? (car x))
|
||||
(string=? (ref-name (car x)) name))
|
||||
(set-ref-location! (car x) location))
|
||||
(loop (cdr x))))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Create hypertext reference.
|
||||
;;;
|
||||
;;; .Hr -url url anchor-text [suffix]
|
||||
;;; .Hr -symbolic label anchor-text [suffix]
|
||||
;;; .Hr troff-text
|
||||
|
||||
(defmacro 'Hr
|
||||
(lambda (Hr type . args)
|
||||
(cond
|
||||
((string=? type "-url")
|
||||
(if (< (length args) 2)
|
||||
(warn "too few arguments for .Hr")
|
||||
(concat
|
||||
(format #f "<a href=\"~a\">~a</a>~a"
|
||||
(parse-unquote (car args))
|
||||
(parse (cadr args))
|
||||
(if (null? (cddr args))
|
||||
#\newline
|
||||
(parse (caddr args) #\newline))))))
|
||||
((string=? type "-symbolic")
|
||||
(if (< (length args) 2)
|
||||
(warn "too few arguments for .Hr")
|
||||
(let* ((ref (car args))
|
||||
(q (ht-querier '.Hr ref))
|
||||
(filename (q 'filename))
|
||||
(a (assoc ref ht-anchors))
|
||||
(location (if a (cdr a) "")))
|
||||
(cond
|
||||
((not (q 'allowed?))
|
||||
"")
|
||||
((and (not a) (not (output-stream)))
|
||||
(warn ".Hr forward reference requires `document' option"))
|
||||
(else
|
||||
(emit "<a href=\"")
|
||||
(if (not a)
|
||||
(list-push! ht-references
|
||||
(ref-create filename (stream-position (output-stream))
|
||||
ref)))
|
||||
(concat (if (string=? filename location) "" location)
|
||||
#\# (parse-unquote ref) "\">"
|
||||
(parse (cadr args)) "</a>"
|
||||
(if (null? (cddr args))
|
||||
#\newline
|
||||
(parse (caddr args) #\newline))))))))
|
||||
(else ""))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Complain about unresolved references and weed out references that
|
||||
;;; point into the file where they appear; then do the file insertions.
|
||||
|
||||
(define (check-ht-references)
|
||||
(let loop ((x ht-references) (new '()))
|
||||
(cond
|
||||
((null? x)
|
||||
new)
|
||||
((ref-unresolved? (car x))
|
||||
(warn "unresolved hypertext reference `~a' in file ~a"
|
||||
(ref-name (car x)) (ref-filename (car x)))
|
||||
(loop (cdr x) new))
|
||||
((string=? (ref-filename (car x)) (ref-location (car x)))
|
||||
(loop (cdr x) new))
|
||||
(else
|
||||
(loop (cdr x) (cons (car x) new))))))
|
||||
|
||||
(define (insert-ht-references)
|
||||
(let ((refs (check-ht-references)))
|
||||
(file-insertions refs)))
|
||||
|
||||
(defevent 'exit 90 insert-ht-references)
|
||||
|
|
@ -0,0 +1,541 @@
|
|||
;;;; -*-Scheme-*-
|
||||
;;;;
|
||||
;;;; $Revision: 1.22 $
|
||||
;;;;
|
||||
;;;; Basic initializations
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Define minimal reset, interrupt handler, and error handlers.
|
||||
|
||||
(if (call-with-current-continuation
|
||||
(lambda (c)
|
||||
(set! top-level-control-point c) #f))
|
||||
(exit 1))
|
||||
|
||||
(define (interrupt-handler) (exit 1))
|
||||
|
||||
(define (error-handler . args)
|
||||
(let ((port (error-port)))
|
||||
(format port "~a: ~s: " (substitute "%progname%") (car args))
|
||||
(apply format port (cdr args))
|
||||
(newline port)
|
||||
(exit 1)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Procedures to print an error message and quit and to print warnings.
|
||||
|
||||
(define (quit msg . args)
|
||||
(let ((port (error-port)))
|
||||
(display (substitute "%progname%:%filepos% ") port)
|
||||
(apply format port msg args)
|
||||
(newline port))
|
||||
(exit 1))
|
||||
|
||||
(define (warn msg . args)
|
||||
(let ((port (error-port)))
|
||||
(display (substitute "%progname%:%filepos% warning: ") port)
|
||||
(apply format port msg args)
|
||||
(newline port)
|
||||
"")) ; return "" to assist use in event functions
|
||||
|
||||
(define (surprise msg)
|
||||
(warn (concat msg " may not work as expected")))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Miscellaneous utilities.
|
||||
|
||||
(define-macro (++ var) `(set! ,var (1+ ,var)))
|
||||
(define-macro (-- var) `(set! ,var (1- ,var)))
|
||||
|
||||
(define (identity x) x)
|
||||
|
||||
|
||||
(define (copy-apply reader . procedures)
|
||||
(define (apply-all val procs)
|
||||
(if (null? procs)
|
||||
val
|
||||
((car procs) (apply-all val (cdr procs)))))
|
||||
(let loop ((x (reader)))
|
||||
(cond ((eof-object? x) "")
|
||||
(else
|
||||
(apply-all x procedures)
|
||||
(loop (reader))))))
|
||||
|
||||
|
||||
(define-macro (list-push! list elem)
|
||||
`(set! ,list (cons ,elem ,list)))
|
||||
|
||||
(define-macro (list-pop! list)
|
||||
`(set! ,list (cdr ,list)))
|
||||
|
||||
(define-macro (list-clear! list)
|
||||
`(set! ,list '()))
|
||||
|
||||
|
||||
(define (skip-lines stop)
|
||||
(let ((x (read-line-expand)))
|
||||
(cond ((eof-object? x)
|
||||
(warn "end-of-stream while skipping input"))
|
||||
((not (string=? x stop))
|
||||
(skip-lines stop)))))
|
||||
|
||||
|
||||
;;; Assist setting of options in initialization file:
|
||||
|
||||
(define-macro (eval-if-mode mode . body)
|
||||
(if (and (pair? mode)
|
||||
(= (length mode) 2)
|
||||
(symbol? (car mode))
|
||||
(symbol? (cadr mode)))
|
||||
(let ((tmac (car mode)) (format (cadr mode)))
|
||||
`(cond
|
||||
((and (or (eq? ',tmac '*)
|
||||
(eq? ',tmac (string->symbol (substitute "m%macros%"))))
|
||||
(or (eq? ',format '*)
|
||||
(eq? ',format (string->symbol (substitute "%format%")))))
|
||||
,@body)))
|
||||
(error 'eval-if-mode "badly formed mode argument: `~a'" mode)))
|
||||
|
||||
|
||||
;;; Macro to define a function and a predicate to manage requests that
|
||||
;;; come in pairs, such as .fi/.nf.
|
||||
|
||||
(define-macro (define-pair func inside enter leave)
|
||||
`(begin
|
||||
(define ,inside #f)
|
||||
(define (,func on)
|
||||
(begin1
|
||||
(if on
|
||||
(if ,inside "" ,enter)
|
||||
(if ,inside ,leave ""))
|
||||
(set! ,inside on)))))
|
||||
|
||||
|
||||
;;; Like define-pair, but for nested pairs.
|
||||
|
||||
(define-macro (define-nested-pair func level enter leave)
|
||||
`(begin
|
||||
(define ,level 0)
|
||||
(define (,func op)
|
||||
(case op
|
||||
(0 (begin1 (repeat-string ,level ,leave) (set! ,level 0)))
|
||||
(+ (++ ,level) ,enter)
|
||||
(- (if (zero? ,level)
|
||||
""
|
||||
(-- ,level) ,leave))))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Options.
|
||||
|
||||
(define option-types (make-table 10))
|
||||
(define option-table (make-table 100))
|
||||
|
||||
(define (define-option-type name check1 msg1 convert check2 msg2)
|
||||
(table-store! option-types name (list check1 msg1 convert check2 msg2)))
|
||||
|
||||
(define (define-option name type initial)
|
||||
(if (not (table-lookup option-types type))
|
||||
(quit "bad type `~a' for define-option" type))
|
||||
(table-store! option-table name (cons initial type)))
|
||||
|
||||
(define (option-setter as-event?)
|
||||
(lambda (name value)
|
||||
(let* ((opt (table-lookup option-table name))
|
||||
(t (if opt (table-lookup option-types (cdr opt)) #f))
|
||||
(err (lambda (msg) (quit "option `~a' requires ~a as value"
|
||||
name msg))))
|
||||
(if opt
|
||||
(let ((val value))
|
||||
(if as-event?
|
||||
(begin
|
||||
(if (not ((car t) val)) (err (cadr t)))
|
||||
(set! val ((caddr t) (car opt) val))))
|
||||
(if (not ((cadddr t) val)) (err (car (cddddr t))))
|
||||
(set-car! opt val))
|
||||
(quit "undefined option: `~a'" name)))))
|
||||
|
||||
(defevent 'option 0 (option-setter #t))
|
||||
(define set-option! (option-setter #f))
|
||||
|
||||
(define (option name)
|
||||
(let ((opt (table-lookup option-table name)))
|
||||
(if opt (car opt) (quit "undefined option: `~a'" name))))
|
||||
|
||||
(define-option-type 'integer
|
||||
string? ""
|
||||
(lambda (old new) (string->number new))
|
||||
integer? "an integer")
|
||||
|
||||
(define-option-type 'boolean
|
||||
(lambda (x) (member x '("0" "1"))) "0 or 1"
|
||||
(lambda (old new) (string=? new "1"))
|
||||
boolean? "a boolean")
|
||||
|
||||
(define-option-type 'character
|
||||
(lambda (x) (= (string-length x) 1)) "a character"
|
||||
(lambda (old new) (string-ref new 0))
|
||||
char? "a character")
|
||||
|
||||
(define-option-type 'string
|
||||
string? ""
|
||||
(lambda (old new) new)
|
||||
string? "a string")
|
||||
|
||||
(define-option-type 'dynstring
|
||||
string? ""
|
||||
string-compose
|
||||
string? "a string")
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Utilities for working with streams.
|
||||
|
||||
(define (with-i/o name proc opener setter!)
|
||||
(let* ((new (opener name)) (old (setter! new)) (result (proc)))
|
||||
(setter! old)
|
||||
(close-stream new)
|
||||
result))
|
||||
|
||||
(define-macro (with-output-to-stream name . body)
|
||||
`(with-i/o ,name (lambda () ,@body) open-output-stream set-output-stream!))
|
||||
|
||||
(define-macro (with-output-appended-to-stream name . body)
|
||||
`(with-i/o ,name (lambda () ,@body) append-output-stream set-output-stream!))
|
||||
|
||||
(define-macro (with-input-from-stream name . body)
|
||||
`(with-i/o ,name (lambda () ,@body) open-input-stream set-input-stream!))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Basic troff requests that are not output format specific.
|
||||
|
||||
(defrequest 'tm
|
||||
(lambda (tm arg)
|
||||
(display arg (error-port))
|
||||
(newline (error-port))))
|
||||
|
||||
(define-option 'include-files 'boolean #t)
|
||||
|
||||
(defrequest 'so
|
||||
(lambda (so fn)
|
||||
(cond
|
||||
((eqv? fn "")
|
||||
(warn "missing filename for .so"))
|
||||
((option 'include-files)
|
||||
(with-input-from-stream fn
|
||||
(copy-apply read-line-expand parse-line)))
|
||||
(else ""))))
|
||||
|
||||
(defrequest 'ec
|
||||
(lambda (ec c)
|
||||
(cond
|
||||
((eqv? c "")
|
||||
(set-escape! #\\))
|
||||
((= (string-length c) 1)
|
||||
(set-escape! (string-ref c 0)))
|
||||
(else
|
||||
(warn "non-character argument for .ec")
|
||||
(set-escape! #\\)))))
|
||||
|
||||
(defrequest 'rm
|
||||
(lambda (rm . names)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(defrequest x #f)
|
||||
(defstring x #f))
|
||||
names) ""))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Inline Scheme code execution; transparent output.
|
||||
|
||||
(define \##-env (the-environment))
|
||||
(define (\##-eval expr) (eval expr \##-env))
|
||||
|
||||
(defrequest 'ig
|
||||
(lambda (ig delim)
|
||||
(define (copy-exec stop what)
|
||||
(let loop ((s (read-line)))
|
||||
(cond ((eof-object? s)
|
||||
(warn "end-of-stream during ~a" what))
|
||||
((not (string=? s stop))
|
||||
(emit s)
|
||||
(loop (read-line))))))
|
||||
(cond
|
||||
((string=? delim "##")
|
||||
(with-output-to-stream '[##]
|
||||
(copy-exec ".##\n" "inline Scheme execution"))
|
||||
(let ((p (open-input-string (stream->string '[##]))))
|
||||
(copy-apply (lambda () (read p)) \##-eval)))
|
||||
((string=? delim ">>")
|
||||
(copy-exec ".>>\n" "transparent output"))
|
||||
(else
|
||||
(skip-lines (concat #\. (if (eqv? delim "") #\. delim) #\newline))))
|
||||
""))
|
||||
|
||||
(defrequest '\##
|
||||
(lambda (\## sexpr)
|
||||
(let ((p (open-input-string sexpr)))
|
||||
(copy-apply (lambda () (read p)) \##-eval))))
|
||||
|
||||
(defrequest '>>
|
||||
(lambda (>> code) (emit code #\newline)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; User-defined macros.
|
||||
|
||||
(define arg-stack '())
|
||||
|
||||
(defescape '$
|
||||
(lambda ($ n)
|
||||
(let ((i (string->number n)))
|
||||
(cond
|
||||
((not i)
|
||||
(cond
|
||||
((string=? n "*")
|
||||
(if (null? arg-stack) "" (apply spread (cdar arg-stack))))
|
||||
((string=? n "@")
|
||||
(let loop ((a (if (null? arg-stack) '() (cdar arg-stack))))
|
||||
(cond ((null? a)
|
||||
"")
|
||||
((null? (cdr a))
|
||||
(concat #\" (car a) #\"))
|
||||
(else
|
||||
(concat #\" (car a) #\" #\space (loop (cdr a)))))))
|
||||
(else
|
||||
(warn "invalid $ argument `~a'" n))))
|
||||
((or (null? arg-stack) (>= i (length (car arg-stack))))
|
||||
"")
|
||||
(else (list-ref (car arg-stack) i))))))
|
||||
|
||||
(defnumreg '.$
|
||||
(lambda _
|
||||
(number->string (if (null? arg-stack) 0 (1- (length (car arg-stack)))))))
|
||||
|
||||
(define (macro-buffer-name s) (concat "[." s "]"))
|
||||
|
||||
(define (expand-macro . args)
|
||||
(list-push! arg-stack args)
|
||||
(with-input-from-stream (macro-buffer-name (car args))
|
||||
(copy-apply read-line-expand parse-line parse-copy-mode))
|
||||
(list-pop! arg-stack) "")
|
||||
|
||||
(define (copy-macro-body)
|
||||
(let* ((s (read-line-expand))
|
||||
(t (if (eof-object? s) #f (parse-copy-mode s))))
|
||||
(cond ((not t)
|
||||
(warn "end-of-stream during macro definition"))
|
||||
((not (string=? t "..\n"))
|
||||
(emit t)
|
||||
(copy-macro-body)))))
|
||||
|
||||
(defrequest 'de
|
||||
(lambda (de name)
|
||||
(cond ((eqv? name "")
|
||||
(warn "missing name for .de"))
|
||||
(else
|
||||
(with-output-to-stream (macro-buffer-name name)
|
||||
(copy-macro-body))
|
||||
(defmacro name expand-macro) ""))))
|
||||
|
||||
(defrequest 'am
|
||||
(lambda (am name)
|
||||
(cond ((eqv? name "")
|
||||
(warn "missing name for .am"))
|
||||
(else
|
||||
(with-output-appended-to-stream (macro-buffer-name name)
|
||||
(copy-macro-body))
|
||||
(defmacro name expand-macro) ""))))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; if, if-else, else.
|
||||
|
||||
(defescape #\{ "")
|
||||
(defescape #\} "")
|
||||
(defrequest "\\}" "") ; do not complain about .\}
|
||||
|
||||
(define-option 'if-true 'dynstring "to")
|
||||
(define-option 'if-false 'dynstring "ne")
|
||||
|
||||
(define if-stack '())
|
||||
|
||||
(define (if-request request condition rest)
|
||||
(let* ((doit? #f)
|
||||
(c (string-prune-left condition "!" condition))
|
||||
(len (string-length c))
|
||||
(neg? (not (eq? c condition))))
|
||||
(cond
|
||||
((and (= len 1) (char-alphabetic? (string-ref c 0)))
|
||||
(cond
|
||||
((substring? c (option 'if-true))
|
||||
(set! doit? #t))
|
||||
((substring? c (option 'if-false)))
|
||||
(else (warn "unknown if-condition `~a'" c))))
|
||||
((and (> len 0) (char-expression-delimiter? (string-ref c 0)))
|
||||
(let ((x (parse-expression c #f #\u)))
|
||||
(if x (set! doit? (not (zero? x))))))
|
||||
(else
|
||||
(let ((pair (parse-pair c)))
|
||||
(if pair
|
||||
(set! doit? (string=? (car pair) (cdr pair)))
|
||||
(warn "if-condition `~a' not understood" c)))))
|
||||
(cond
|
||||
((eq? neg? doit?)
|
||||
(unread-line (concat rest #\newline))
|
||||
(skip-group))
|
||||
(else
|
||||
(unread-line (hack-if-argument rest))))
|
||||
(if (string=? request "ie")
|
||||
(list-push! if-stack (not (eq? neg? doit?))))
|
||||
""))
|
||||
|
||||
;; Some people like to write .if requests such as
|
||||
;; .if t \{\
|
||||
;; .foo
|
||||
;; This causes the string "\{.foo" to be passed to .if, as the first line
|
||||
;; is a continuation line. So let's strip the initial \{. What a hack.
|
||||
|
||||
(define (hack-if-argument s)
|
||||
(string-prune-left s "\\{" s))
|
||||
|
||||
(defrequest 'if if-request)
|
||||
(defrequest 'ie if-request)
|
||||
|
||||
(defrequest 'el
|
||||
(lambda (_ rest)
|
||||
(cond
|
||||
((null? if-stack)
|
||||
(warn ".el without matching .ie request"))
|
||||
((car if-stack)
|
||||
(unread-line (concat rest #\newline))
|
||||
(skip-group)
|
||||
(list-pop! if-stack))
|
||||
(else
|
||||
(unread-line (hack-if-argument rest))
|
||||
(list-pop! if-stack)))
|
||||
""))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Number registers.
|
||||
|
||||
(define numreg-table (make-table 65536))
|
||||
|
||||
(defrequest 'nr
|
||||
(lambda (nr name val incr)
|
||||
(cond
|
||||
((eqv? name "")
|
||||
(warn "missing name for .nr"))
|
||||
((eqv? val "")
|
||||
(warn "missing value for .nr"))
|
||||
(else
|
||||
(let* ((old (table-lookup numreg-table name))
|
||||
(v (parse val))
|
||||
(n (parse-expression v #f #\u))
|
||||
(add? (string-prune-left v "+" #f))
|
||||
(i (if (eqv? incr "")
|
||||
#f
|
||||
(parse-expression (parse incr) #f #\u))))
|
||||
(cond
|
||||
((not n) "")
|
||||
(old
|
||||
(set-car! old (if (or add? (negative? n)) (+ (car old) n) n))
|
||||
(if i
|
||||
(set-cdr! old i)))
|
||||
(else
|
||||
(table-store! numreg-table name (cons n (if i i 0))))))))
|
||||
""))
|
||||
|
||||
(defescape 'n
|
||||
(lambda (_ name . sign)
|
||||
(let ((val (table-lookup numreg-table name)))
|
||||
(cond
|
||||
(val
|
||||
(if (not (null? sign))
|
||||
(case (car sign)
|
||||
(#\+ (set-car! val (+ (car val) (cdr val))))
|
||||
(#\- (set-car! val (- (car val) (cdr val))))))
|
||||
(number->string (car val)))
|
||||
(else (warn "undefined number register: `~a'" name) "0")))))
|
||||
|
||||
(defrequest 'rr
|
||||
(lambda (rr . names)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(defnumreg x #f)
|
||||
(table-remove! numreg-table x))
|
||||
names) ""))
|
||||
|
||||
|
||||
;;; Predefined number registers
|
||||
|
||||
(defnumreg 'dw
|
||||
(lambda _
|
||||
(number->string (1+ (string->number (substitute "%weekdaynum%"))))))
|
||||
|
||||
(defnumreg 'dy (lambda _ (substitute "%day%")))
|
||||
(defnumreg 'mo (lambda _ (substitute "%month%")))
|
||||
(defnumreg 'yr (lambda _ (substring (substitute "%year%") 2 4)))
|
||||
(defnumreg '.C (lambda _ (if (troff-compatible?) #\1 #\0)))
|
||||
(defnumreg '% #\0)
|
||||
(defnumreg '.z "")
|
||||
(defnumreg '.U #\1)
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Strings. Note that user-defined strings are re-scanned (strings
|
||||
;;; defined via `defstring' aren't, because they may contain anything).
|
||||
|
||||
(defrequest 'ds
|
||||
(lambda (ds name val)
|
||||
(if (eqv? name "")
|
||||
(warn "missing name for .ds")
|
||||
(let ((v (string-prune-left val "\"" val)))
|
||||
(defstring name (lambda _ (parse-expand v)))))
|
||||
""))
|
||||
|
||||
(defrequest 'as
|
||||
(lambda (as name val)
|
||||
(if (eqv? name "")
|
||||
(warn "missing name for .as")
|
||||
(let* ((f (stringdef name))
|
||||
(s (if f (if (string? f) f (f)) ""))
|
||||
(new (concat s (string-prune-left val "\"" val))))
|
||||
(defstring name (lambda _ (parse-expand new)))))
|
||||
""))
|
||||
|
||||
(defescape '*
|
||||
(lambda (_ name)
|
||||
(warn "undefined string: `~a'" name)))
|
||||
|
||||
|
||||
|
||||
;;; --------------------------------------------------------------------------
|
||||
;;; Now we are done with the definitions.
|
||||
;;;
|
||||
;;; Load the output-format-specific Scheme code and the macro-package-
|
||||
;;; specific Scheme code.
|
||||
|
||||
(load (substitute "%directory%/scm/%format%/common.scm"))
|
||||
|
||||
(load (substitute "%directory%/scm/%format%/m%macros%.scm"))
|
||||
|
||||
(set! garbage-collect-notify? #f)
|
||||
|
||||
(append! load-path (list (substitute "%directory%/scm/misc")))
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
# $Revision: 1.12 $
|
||||
|
||||
### You need a C compiler that compiles ANSI C code.
|
||||
CC = gcc
|
||||
CFLAGS = -Wall -pedantic -O
|
||||
|
||||
### If you need additional linker flags add them here.
|
||||
LDFLAGS =
|
||||
|
||||
### The directory where the Elk installation resides on your system.
|
||||
ELKDIR = /usr/elk
|
||||
|
||||
### Additional libraries. You may want to insert the output of the
|
||||
### shell-script $(ELKDIR)/lib/ldflags here.
|
||||
LIBS = -lm
|
||||
|
||||
### The makedepend program (it's usually installed with the X11 binaries).
|
||||
MAKEDEP = makedepend
|
||||
|
||||
### The directory under which you will install the Scheme files.
|
||||
DIR = /usr/local/lib/unroff
|
||||
|
||||
### The default output format.
|
||||
FORMAT = html
|
||||
|
||||
|
||||
|
||||
|
||||
### End of configurable variables.
|
||||
### -------------------------------------------------------------------------
|
||||
|
||||
SHELL = /bin/sh
|
||||
INCLUDE = -I$(ELKDIR)/include
|
||||
ELK = $(ELKDIR)/lib/module.o
|
||||
DEFS = -DDEFAULT_DIR=\"$(DIR)\" -DDEFAULT_FORMAT=\"$(FORMAT)\"
|
||||
CTAGS = ctags -t -w
|
||||
|
||||
SOURCES = \
|
||||
args.c\
|
||||
buffer.c\
|
||||
error.c\
|
||||
event.c\
|
||||
expr.c\
|
||||
gcroot.c\
|
||||
insert.c\
|
||||
malloc.c\
|
||||
parse.c\
|
||||
prim.c\
|
||||
scmtable.c\
|
||||
stream.c\
|
||||
subst.c\
|
||||
table.c\
|
||||
unroff.c
|
||||
|
||||
OBJECTS = \
|
||||
args.o\
|
||||
buffer.o\
|
||||
error.o\
|
||||
event.o\
|
||||
expr.o\
|
||||
gcroot.o\
|
||||
insert.o\
|
||||
malloc.o\
|
||||
parse.o\
|
||||
prim.o\
|
||||
scmtable.o\
|
||||
stream.o\
|
||||
subst.o\
|
||||
table.o\
|
||||
unroff.o\
|
||||
$(ELK)
|
||||
|
||||
ALL = unroff
|
||||
|
||||
all: $(ALL)
|
||||
|
||||
.c.o:
|
||||
$(CC) $(CFLAGS) $(INCLUDE) $(DEFS) -c $<
|
||||
|
||||
clean:
|
||||
rm -f *.o $(ALL)
|
||||
|
||||
tags ctags: $(SOURCES)
|
||||
$(CTAGS) $(SOURCES)
|
||||
|
||||
unroff: $(OBJECTS)
|
||||
$(CC) $(LDFLAGS) -o $@ $(OBJECTS) $(LIBS)
|
||||
|
||||
depend: Makefile $(SOURCES)
|
||||
$(MAKEDEP) $(INCLUDE) $(SOURCES)
|
||||
|
||||
|
||||
# DO NOT DELETE THIS LINE -- make depend depends on it.
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
/* $Revision: 1.5 $
|
||||
*/
|
||||
|
||||
/* Functions that maintain a properly GC-linked list of Scheme
|
||||
* arguments. The parser collects arguments to an event procedure
|
||||
* using args_add(); the code that eventually calls the event
|
||||
* procedure calls args_get() to obtain a list of arguments that
|
||||
* can directly be passed to Funcall().
|
||||
*
|
||||
* args_clear() -- clears the list
|
||||
* args_add(obj) -- appends an object to the list
|
||||
* args_get() -- returns the list
|
||||
* args_num() -- returns the current length of the list
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static Object args, last, rest;
|
||||
static int num;
|
||||
|
||||
void args_clear(void) {
|
||||
if (Nullp(last)) {
|
||||
if (!Nullp(rest))
|
||||
args = rest;
|
||||
} else
|
||||
P_Setcdr(last, rest);
|
||||
last = Null;
|
||||
num = 0;
|
||||
}
|
||||
|
||||
void args_add(Object x) {
|
||||
Object tmp;
|
||||
GC_Node;
|
||||
|
||||
if (Nullp(last)) {
|
||||
last = args;
|
||||
} else {
|
||||
if (Nullp(Cdr(last))) {
|
||||
GC_Link(x);
|
||||
tmp = Cons(False, Null);
|
||||
GC_Unlink;
|
||||
Cdr(last) = tmp;
|
||||
}
|
||||
last = Cdr(last);
|
||||
}
|
||||
Car(last) = x;
|
||||
rest = Cdr(last);
|
||||
num++;
|
||||
}
|
||||
|
||||
|
||||
Object args_get(void) {
|
||||
if (Nullp(last)) {
|
||||
rest = args;
|
||||
return Null;
|
||||
}
|
||||
rest = Cdr(last);
|
||||
P_Setcdr(last, Null);
|
||||
return args;
|
||||
}
|
||||
|
||||
int args_num(void) {
|
||||
return num;
|
||||
}
|
||||
|
||||
void init_args(void) {
|
||||
rest = Cons(False, Null);
|
||||
args = last = Null;
|
||||
Global_GC_Link(args);
|
||||
Global_GC_Link(last);
|
||||
Global_GC_Link(rest);
|
||||
}
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
/* $Revision: 1.2 $
|
||||
*/
|
||||
|
||||
void args_clear(void);
|
||||
void args_add(Object);
|
||||
Object args_get(void);
|
||||
int args_num(void);
|
||||
void init_args(void);
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
/* $Revision: 1.7 $
|
||||
*/
|
||||
|
||||
/* `Buffer' is a dynamically growing, general-purpose buffer data
|
||||
* structure.
|
||||
*
|
||||
* buffer_new(size) -- returns new buffer with initial size `size'
|
||||
* or some default size if argument is zero
|
||||
* buffer_delete(b) -- marks a buffer as unused
|
||||
* buffer_clear(b) -- empties a buffer
|
||||
* buffer_puts(b,data,len) -- appends data to a buffer, growing it if
|
||||
* necessary
|
||||
* buffer_putc(b,c) -- appends a character to a buffer
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static int sizeinc_linear(Buffer *);
|
||||
|
||||
static Buffer *first_free;
|
||||
|
||||
Buffer *buffer_new(int size) {
|
||||
Buffer *p;
|
||||
|
||||
if (size == 0)
|
||||
size = 512;
|
||||
if (first_free) { /* reuse a buffer if there is one */
|
||||
p = first_free;
|
||||
first_free = p->next;
|
||||
if (p->max < size) {
|
||||
free(p->data);
|
||||
p->data = safe_malloc(p->max = size);
|
||||
}
|
||||
} else {
|
||||
p = safe_malloc(sizeof *p);
|
||||
p->data = safe_malloc(size);
|
||||
p->increment = p->max = size;
|
||||
p->sizeinc_func = sizeinc_linear;
|
||||
}
|
||||
buffer_clear(p);
|
||||
return p;
|
||||
}
|
||||
|
||||
void buffer_delete(Buffer *p) {
|
||||
assert(p->size >= 0);
|
||||
p->size = -1;
|
||||
p->next = first_free;
|
||||
first_free = p;
|
||||
}
|
||||
|
||||
void buffer_grow(Buffer *p) {
|
||||
p->max = p->sizeinc_func(p);
|
||||
p->data = safe_realloc(p->data, p->max);
|
||||
}
|
||||
|
||||
void buffer_puts(Buffer *p, char *s, int size) {
|
||||
assert(size >= 0);
|
||||
while (p->size + size > p->max)
|
||||
buffer_grow(p);
|
||||
if (size == 0)
|
||||
return;
|
||||
memcpy(p->data+p->size, s, size);
|
||||
p->size += size;
|
||||
}
|
||||
|
||||
static int sizeinc_linear(Buffer *p) {
|
||||
return p->max + p->increment;
|
||||
}
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
/* $Revision: 1.4 $
|
||||
*/
|
||||
|
||||
typedef struct _buffer {
|
||||
char *data;
|
||||
int increment;
|
||||
int size;
|
||||
int max;
|
||||
int (*sizeinc_func)(struct _buffer *);
|
||||
struct _buffer *next;
|
||||
} Buffer;
|
||||
|
||||
Buffer *buffer_new(int);
|
||||
void buffer_delete(Buffer *);
|
||||
void buffer_grow(Buffer *);
|
||||
void buffer_puts(Buffer *, char *, int);
|
||||
|
||||
#define buffer_need_grow(p) ((p)->size == (p)->max)
|
||||
#define buffer_clear(p) ((p)->size = 0)
|
||||
|
||||
#define buffer_putc(p, c) {\
|
||||
if (buffer_need_grow(p))\
|
||||
buffer_grow(p);\
|
||||
(p)->data[(p)->size++] = (c);\
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
/* $Revision: 1.9 $
|
||||
*/
|
||||
|
||||
/* Environment variable specifing library directory:
|
||||
*/
|
||||
#define DEFAULT_DIR_ENV "UNROFF_DIR"
|
||||
|
||||
|
||||
/* Environment variable specifing default output format:
|
||||
*/
|
||||
#define DEFAULT_FORMAT_ENV "UNROFF_FORMAT"
|
||||
|
||||
|
||||
/* User-supplied initialization file loaded from home directory:
|
||||
*/
|
||||
#define RC_FILE ".unroff"
|
||||
|
||||
|
||||
/* File to load if option -t is given:
|
||||
*/
|
||||
#define TEST_TOPLEVEL "toplevel.scm"
|
||||
|
||||
|
||||
#define MAJOR_VERSION 1
|
||||
#define MINOR_VERSION 0
|
||||
|
||||
|
||||
/* Hack: __GNUC_MINOR__ was introduced together with __attribute__ */
|
||||
#ifdef __GNUC_MINOR__
|
||||
# define NORETURN __attribute__ ((noreturn))
|
||||
#else
|
||||
# define NORETURN
|
||||
#endif
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
*** 1.59 1994/01/24 16:03:30
|
||||
--- src/main.c 1995/02/01 17:06:20
|
||||
***************
|
||||
*** 90,95 ****
|
||||
--- 90,98 ----
|
||||
struct stat st;
|
||||
extern int errno;
|
||||
char foo;
|
||||
+ #ifdef NOMAIN
|
||||
+ # define foo (av[0][0])
|
||||
+ #endif
|
||||
|
||||
#ifdef CAN_DUMP
|
||||
bzero (unused, 1); /* see comment above */
|
||||
***************
|
||||
*** 207,213 ****
|
||||
* the load-path, so that -p can be used.
|
||||
*/
|
||||
Error_Tag = "scheme-init";
|
||||
! initfile = Safe_Malloc (strlen (SCM_DIR) + 1 + sizeof (INITFILE));
|
||||
sprintf (initfile, "%s/%s", SCM_DIR, INITFILE);
|
||||
if (stat (initfile, &st) == -1 && errno == ENOENT)
|
||||
file = Make_String (INITFILE, sizeof(INITFILE)-1);
|
||||
--- 210,216 ----
|
||||
* the load-path, so that -p can be used.
|
||||
*/
|
||||
Error_Tag = "scheme-init";
|
||||
! initfile = Safe_Malloc (strlen (SCM_DIR) + 1 + sizeof (INITFILE) + 1);
|
||||
sprintf (initfile, "%s/%s", SCM_DIR, INITFILE);
|
||||
if (stat (initfile, &st) == -1 && errno == ENOENT)
|
||||
file = Make_String (INITFILE, sizeof(INITFILE)-1);
|
||||
***************
|
||||
*** 220,227 ****
|
||||
|
||||
Error_Tag = "top-level";
|
||||
#ifdef NOMAIN
|
||||
! if ((loadfile = toplevel) == 0)
|
||||
return;
|
||||
#endif
|
||||
if (loadfile == 0)
|
||||
loadfile = "toplevel.scm";
|
||||
--- 223,233 ----
|
||||
|
||||
Error_Tag = "top-level";
|
||||
#ifdef NOMAIN
|
||||
! if ((loadfile = toplevel) == 0) {
|
||||
! Interpreter_Initialized = 1;
|
||||
! GC_Debug = debug;
|
||||
return;
|
||||
+ }
|
||||
#endif
|
||||
if (loadfile == 0)
|
||||
loadfile = "toplevel.scm";
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
/* $Revision: 1.12 $
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static char *progname = "(whoami?)";
|
||||
|
||||
void set_progname(char *s) {
|
||||
char *p;
|
||||
|
||||
progname = (p = strrchr(s, '/')) ? p+1 : s;
|
||||
}
|
||||
|
||||
char *get_progname(void) {
|
||||
return progname;
|
||||
}
|
||||
|
||||
void warn(char *fmt, ...) {
|
||||
va_list args;
|
||||
|
||||
fprintf(stderr, "%s: ", progname);
|
||||
if (istream_is_open())
|
||||
fprintf(stderr, "%s:%lu: ", curr_istream_target(), curr_istream_lno());
|
||||
fprintf(stderr, "warning: ");
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, ".\n");
|
||||
}
|
||||
|
||||
void fatal_error(char *fmt, ...) {
|
||||
va_list args;
|
||||
|
||||
fprintf(stderr, "%s: ", progname);
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, ".\n");
|
||||
exit(1);
|
||||
}
|
||||
|
||||
static char *strerr(void) {
|
||||
extern int sys_nerr;
|
||||
extern char *sys_errlist[];
|
||||
|
||||
return errno > 0 && errno < sys_nerr ?
|
||||
sys_errlist[errno] : "unknown error";
|
||||
}
|
||||
|
||||
void read_error(char *s) {
|
||||
fatal_error("reading %s: %s", s, strerr());
|
||||
}
|
||||
|
||||
void write_error(char *s) {
|
||||
fatal_error("writing %s: %s", s, strerr());
|
||||
}
|
||||
|
||||
void open_error(char *fn) {
|
||||
fatal_error("%s: %s", fn, strerr());
|
||||
}
|
||||
|
||||
char *printable_string(char *s, int len) {
|
||||
static Buffer *bp;
|
||||
char c[4];
|
||||
|
||||
if (!bp)
|
||||
bp = buffer_new(0);
|
||||
buffer_clear(bp);
|
||||
for ( ; len > 0; len--, s++) {
|
||||
if (isprint(UCHAR(*s)) || *s == ' ') {
|
||||
buffer_putc(bp, *s);
|
||||
} else {
|
||||
buffer_putc(bp, '\\');
|
||||
switch (*s) {
|
||||
case '\n':
|
||||
buffer_putc(bp, 'n'); break;
|
||||
case '\t':
|
||||
buffer_putc(bp, 't'); break;
|
||||
case '\b':
|
||||
buffer_putc(bp, 'b'); break;
|
||||
default:
|
||||
sprintf(c, "%03o", *s);
|
||||
buffer_puts(bp, c, 3);
|
||||
}
|
||||
}
|
||||
}
|
||||
buffer_putc(bp, '\0');
|
||||
return bp->data;
|
||||
}
|
||||
|
||||
char *printable_char(char c) {
|
||||
return printable_string(&c, 1);
|
||||
}
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
/* $Revision: 1.7 $
|
||||
*/
|
||||
|
||||
void set_progname(char *);
|
||||
char *get_progname(void);
|
||||
|
||||
void warn(char *, ...);
|
||||
|
||||
void fatal_error(char *, ...) NORETURN;
|
||||
|
||||
void read_error(char *) NORETURN;
|
||||
void write_error(char *) NORETURN;
|
||||
void open_error(char *) NORETURN;
|
||||
|
||||
/* Redefined to add NORETURN
|
||||
*/
|
||||
extern Primitive_Error() NORETURN;
|
||||
|
||||
char *printable_string(char *, int);
|
||||
char *printable_char(char);
|
||||
|
|
@ -0,0 +1,375 @@
|
|||
/* $Revision: 1.15 $
|
||||
*/
|
||||
|
||||
/* Scheme primitives that define and query event procedures, and
|
||||
* functions to lookup and execute events.
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
#define NUM_VEC_EVENTS 6
|
||||
|
||||
static Table *requests, *numregs, *specials, *escapes, *chars, *others;
|
||||
static Table *fallbacks;
|
||||
static Object Key_Equation, Key_Sentence;
|
||||
Object eventsvec;
|
||||
|
||||
static SYMDESCR event_syms[] = {
|
||||
{ "line", EV_LINE },
|
||||
{ "prolog", EV_PROLOG },
|
||||
{ "epilog", EV_EPILOG },
|
||||
{ "option", EV_OPTION },
|
||||
{ "start", EV_START },
|
||||
{ "exit", EV_EXIT },
|
||||
{ 0, 0 }
|
||||
};
|
||||
|
||||
static char *event_names[] = {
|
||||
"line event",
|
||||
"prolog event",
|
||||
"epilog event",
|
||||
"option event",
|
||||
"start event",
|
||||
"exit event",
|
||||
"request",
|
||||
"macro",
|
||||
"string",
|
||||
"number register",
|
||||
"special character",
|
||||
"inline equation",
|
||||
"sentence event",
|
||||
"escape sequence",
|
||||
"character event",
|
||||
};
|
||||
|
||||
static Object make_event_object(Object x) {
|
||||
switch (TYPE(x)) {
|
||||
case T_Null:
|
||||
case T_Compound:
|
||||
case T_String:
|
||||
case T_Character:
|
||||
case T_Symbol:
|
||||
return x;
|
||||
case T_Primitive:
|
||||
Primitive_Error("event function must be a compound procedure");
|
||||
default:
|
||||
if (EQ(x, False))
|
||||
return x;
|
||||
Primitive_Error("invalid event value argument");
|
||||
}
|
||||
}
|
||||
|
||||
static Object store_event(Table *tp, char *key, int size, Object obj,
|
||||
char flags) {
|
||||
Elem *oldp;
|
||||
Object ret = False;
|
||||
|
||||
if ((oldp = table_lookup(tp, key, size)) != 0)
|
||||
ret = get_object(oldp->obj);
|
||||
if (!Nullp(obj))
|
||||
if (EQ(obj, False))
|
||||
table_remove(tp, key, size);
|
||||
else
|
||||
table_store(tp, key, size, obj, (unsigned long)flags);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object def_indexed(Table *tp, Object key, Object obj, char flags,
|
||||
char *code) {
|
||||
if (TYPE(key) == T_Symbol)
|
||||
key = SYMBOL(key)->name;
|
||||
else if (TYPE(key) != T_String)
|
||||
Wrong_Type_Combination(key, "string or symbol");
|
||||
if (STRING(key)->size == 0) {
|
||||
if (*code != 'r' && *code != 'p')
|
||||
Primitive_Error("event key must be of non-zero length");
|
||||
return store_event(fallbacks, code, 1, make_event_object(obj), flags);
|
||||
}
|
||||
return store_event(tp, STRING(key)->data, STRING(key)->size,
|
||||
make_event_object(obj), flags);
|
||||
}
|
||||
|
||||
static Object p_defrequest(Object key, Object obj) {
|
||||
return def_indexed(requests, key, obj, 0, "r");
|
||||
}
|
||||
|
||||
static Object p_defmacro(Object key, Object obj) {
|
||||
return def_indexed(requests, key, obj, RQ_MACRO, "m");
|
||||
}
|
||||
|
||||
static Object p_defstring(Object key, Object obj) {
|
||||
return def_indexed(requests, key, obj, RQ_STRING, "s");
|
||||
}
|
||||
|
||||
static Object p_defnumreg(Object key, Object obj) {
|
||||
return def_indexed(numregs, key, obj, 0, "n");
|
||||
}
|
||||
|
||||
static Object p_defspecial(Object key, Object obj) {
|
||||
return def_indexed(specials, key, obj, 0, "p");
|
||||
}
|
||||
|
||||
static Object p_defequation(Object obj) {
|
||||
return def_indexed(others, Key_Equation, obj, 0, 0);
|
||||
}
|
||||
|
||||
static Object p_defsentence(Object obj) {
|
||||
return def_indexed(others, Key_Sentence, obj, 0, 0);
|
||||
}
|
||||
|
||||
static Object p_requestdef(Object key) {
|
||||
return def_indexed(requests, key, Null, 0, "r");
|
||||
}
|
||||
|
||||
static Object p_macrodef(Object key) {
|
||||
return def_indexed(requests, key, Null, 0, "m");
|
||||
}
|
||||
|
||||
static Object p_stringdef(Object key) {
|
||||
return def_indexed(requests, key, Null, 0, "s");
|
||||
}
|
||||
|
||||
static Object p_numregdef(Object key) {
|
||||
return def_indexed(numregs, key, Null, 0, "n");
|
||||
}
|
||||
|
||||
static Object p_specialdef(Object key) {
|
||||
return def_indexed(specials, key, Null, 0, "p");
|
||||
}
|
||||
|
||||
static Object p_equationdef(void) {
|
||||
return def_indexed(others, Key_Equation, Null, 0, 0);
|
||||
}
|
||||
|
||||
static Object p_sentencedef(void) {
|
||||
return def_indexed(others, Key_Sentence, Null, 0, 0);
|
||||
}
|
||||
|
||||
static Object def_char_event(Table *tp, Object key, Object obj) {
|
||||
char c;
|
||||
|
||||
switch (TYPE(key)) {
|
||||
case T_Character:
|
||||
c = CHAR(key); break;
|
||||
case T_Symbol:
|
||||
key = SYMBOL(key)->name;
|
||||
/* fall through */
|
||||
case T_String:
|
||||
if (tp == escapes && STRING(key)->size == 0)
|
||||
return store_event(fallbacks, "e", 1, make_event_object(obj), 0);
|
||||
if (STRING(key)->size != 1)
|
||||
goto err;
|
||||
c = STRING(key)->data[0];
|
||||
break;
|
||||
default: err:
|
||||
Primitive_Error("cannot coerce argument to character");
|
||||
}
|
||||
return store_event(tp, &c, 1, make_event_object(obj), 0);
|
||||
}
|
||||
|
||||
Object p_defescape(Object key, Object obj) {
|
||||
return def_char_event(escapes, key, obj);
|
||||
}
|
||||
|
||||
Object p_defchar(Object key, Object obj) {
|
||||
return def_char_event(chars, key, obj);
|
||||
}
|
||||
|
||||
Object p_escapedef(Object key) {
|
||||
return def_char_event(escapes, key, Null);
|
||||
}
|
||||
|
||||
Object p_chardef(Object key) {
|
||||
return def_char_event(chars, key, Null);
|
||||
}
|
||||
|
||||
Elem *event_lookup(Event e, char *key, int size) {
|
||||
Elem *p;
|
||||
|
||||
if (key && size == 0) {
|
||||
switch(e) {
|
||||
case EV_REQUEST:
|
||||
return table_lookup(fallbacks, "r", 1); /* not yet */
|
||||
case EV_MACRO:
|
||||
return table_lookup(fallbacks, "m", 1); /* not yet */
|
||||
case EV_SPECIAL:
|
||||
return table_lookup(fallbacks, "p", 1);
|
||||
case EV_ESCAPE:
|
||||
return table_lookup(fallbacks, "e", 1);
|
||||
default:
|
||||
assert(0);
|
||||
}
|
||||
} else {
|
||||
switch (e) {
|
||||
case EV_REQUEST:
|
||||
return ((p = table_lookup(requests, key, size)) &&
|
||||
!(p->flags & RQ_MACRO)) ? p : 0;
|
||||
case EV_MACRO:
|
||||
return ((p = table_lookup(requests, key, size)) &&
|
||||
(p->flags & RQ_MACRO)) ? p : 0;
|
||||
case EV_STRING:
|
||||
return table_lookup(requests, key, size);
|
||||
case EV_NUMREG:
|
||||
return table_lookup(numregs, key, size);
|
||||
case EV_SPECIAL:
|
||||
return table_lookup(specials, key, size);
|
||||
case EV_ESCAPE:
|
||||
return table_lookup(escapes, key, size);
|
||||
case EV_CHAR:
|
||||
assert(size == 1);
|
||||
return table_lookup(chars, key, size);
|
||||
case EV_EQUATION:
|
||||
return table_lookup(others, "e", 1);
|
||||
case EV_SENTENCE:
|
||||
return table_lookup(others, "s", 1);
|
||||
case EV_LINE:
|
||||
case EV_PROLOG:
|
||||
case EV_EPILOG:
|
||||
case EV_OPTION:
|
||||
case EV_START:
|
||||
case EV_EXIT:
|
||||
default:
|
||||
assert(0);
|
||||
}
|
||||
}
|
||||
return 0; /* shut up gcc -W */
|
||||
}
|
||||
|
||||
static int check_num_args(Object fun, int num, char *evnam) {
|
||||
char *s = 0;
|
||||
struct S_Compound *comp = COMPOUND(fun);
|
||||
|
||||
if (num < comp->min_args)
|
||||
s = "few";
|
||||
else if (comp->max_args >= 0 && num > comp->max_args)
|
||||
s = "many";
|
||||
if (s) warn("too %s arguments for %s function", s, evnam);
|
||||
return !s;
|
||||
}
|
||||
|
||||
char *event_exec(Event e, char *key, int size, int *size_ret, int complain) {
|
||||
Elem *p = event_lookup(e, key, size);
|
||||
Object ret;
|
||||
char *name = event_names[e];
|
||||
static char c;
|
||||
|
||||
if (p) {
|
||||
if ((e == EV_REQUEST || e == EV_MACRO) && (p->flags & RQ_STRING)) {
|
||||
warn("cannot execute string as request or macro");
|
||||
return 0;
|
||||
}
|
||||
if (e == EV_STRING && !(p->flags & RQ_STRING)) {
|
||||
warn("cannot execute request or macro as string");
|
||||
return 0;
|
||||
}
|
||||
ret = get_object(p->obj);
|
||||
if (TYPE(ret) == T_Compound) {
|
||||
if (!check_num_args(ret, args_num(), name))
|
||||
return 0;
|
||||
ret = Funcall(ret, args_get(), 0);
|
||||
}
|
||||
assert(size_ret != 0);
|
||||
switch (TYPE(ret)) {
|
||||
case T_Character:
|
||||
c = CHAR(ret);
|
||||
*size_ret = 1;
|
||||
return &c;
|
||||
case T_Symbol:
|
||||
ret = SYMBOL(ret)->name; /* fall through */
|
||||
case T_String:
|
||||
*size_ret = STRING(ret)->size;
|
||||
return STRING(ret)->data;
|
||||
default:
|
||||
warn("cannot coerce result of %s function to string", name);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
if (complain)
|
||||
warn("no event value for %s `%s'", name, printable_string(key, size));
|
||||
return 0;
|
||||
}
|
||||
|
||||
char *event_exec_fallback(Event e, char *key, int size, int *size_ret) {
|
||||
if (!event_lookup(e, key, size) && event_lookup(e, "", 0))
|
||||
return event_exec(e, "", 0, size_ret, 1);
|
||||
else
|
||||
return event_exec(e, key, size, size_ret, 1);
|
||||
}
|
||||
|
||||
static Object store_vec_event(int e, Object pri, Object obj) {
|
||||
Object ret, v = VECTOR(eventsvec)->data[e];
|
||||
int p = Get_Integer(pri);
|
||||
|
||||
if (p < 0 || p > 99)
|
||||
Range_Error(pri);
|
||||
ret = VECTOR(v)->data[p];
|
||||
if (!Nullp(obj))
|
||||
VECTOR(v)->data[p] = obj;
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_defevent(Object event, Object pri, Object obj) {
|
||||
char e = Symbols_To_Bits(event, 0, event_syms);
|
||||
|
||||
if (Truep(obj) && TYPE(obj) != T_Compound)
|
||||
Wrong_Type_Combination(obj, "compound procedure or #f");
|
||||
return store_vec_event(e, pri, obj);
|
||||
}
|
||||
|
||||
static Object p_eventdef(Object event, Object pri) {
|
||||
char e = Symbols_To_Bits(event, 0, event_syms);
|
||||
|
||||
return store_vec_event(e, pri, Null);
|
||||
}
|
||||
|
||||
void events_vec_exec(Event e) {
|
||||
Object func, v;
|
||||
int i;
|
||||
|
||||
for (i = 0; i < 100; i++) {
|
||||
v = VECTOR(eventsvec)->data[e];
|
||||
func = VECTOR(v)->data[i];
|
||||
if (Truep(func) && check_num_args(func, args_num(), event_names[e]))
|
||||
(void)Funcall(func, args_get(), 0);
|
||||
}
|
||||
}
|
||||
|
||||
void init_event(void) {
|
||||
int i;
|
||||
|
||||
requests = table_new(256*256);
|
||||
numregs = table_new(256*256);
|
||||
specials = table_new(256*256);
|
||||
escapes = table_new(256);
|
||||
chars = table_new(256);
|
||||
others = table_new(10);
|
||||
fallbacks = table_new(256);
|
||||
Key_Equation = Make_String("e", 1);
|
||||
Global_GC_Link(Key_Equation);
|
||||
Key_Sentence = Make_String("s", 1);
|
||||
Global_GC_Link(Key_Sentence);
|
||||
eventsvec = Make_Vector(NUM_VEC_EVENTS, Null);
|
||||
Global_GC_Link(eventsvec);
|
||||
for (i = 0; i < NUM_VEC_EVENTS; i++)
|
||||
VECTOR(eventsvec)->data[i] = Make_Vector(100, False);
|
||||
Define_Primitive(p_defrequest, "defrequest", 2, 2, EVAL);
|
||||
Define_Primitive(p_defmacro, "defmacro", 2, 2, EVAL);
|
||||
Define_Primitive(p_defstring, "defstring", 2, 2, EVAL);
|
||||
Define_Primitive(p_defnumreg, "defnumreg", 2, 2, EVAL);
|
||||
Define_Primitive(p_defspecial, "defspecial", 2, 2, EVAL);
|
||||
Define_Primitive(p_defequation, "defequation", 1, 1, EVAL);
|
||||
Define_Primitive(p_defsentence, "defsentence", 1, 1, EVAL);
|
||||
Define_Primitive(p_defescape, "defescape", 2, 2, EVAL);
|
||||
Define_Primitive(p_defchar, "defchar", 2, 2, EVAL);
|
||||
Define_Primitive(p_defevent, "defevent", 3, 3, EVAL);
|
||||
Define_Primitive(p_requestdef, "requestdef", 1, 1, EVAL);
|
||||
Define_Primitive(p_macrodef, "macrodef", 1, 1, EVAL);
|
||||
Define_Primitive(p_stringdef, "stringdef", 1, 1, EVAL);
|
||||
Define_Primitive(p_numregdef, "numregdef", 1, 1, EVAL);
|
||||
Define_Primitive(p_specialdef, "specialdef", 1, 1, EVAL);
|
||||
Define_Primitive(p_equationdef, "equationdef", 0, 0, EVAL);
|
||||
Define_Primitive(p_sentencedef, "sentencedef", 0, 0, EVAL);
|
||||
Define_Primitive(p_escapedef, "escapedef", 1, 1, EVAL);
|
||||
Define_Primitive(p_chardef, "chardef", 1, 1, EVAL);
|
||||
Define_Primitive(p_eventdef, "eventdef", 2, 2, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
/* $Revision: 1.12 $
|
||||
*/
|
||||
|
||||
/* Events:
|
||||
*/
|
||||
typedef enum _event {
|
||||
EV_LINE, /* args: char|#f ret: */
|
||||
EV_PROLOG, /* args: pathname basename ret: */
|
||||
EV_EPILOG, /* args: pathname basename ret: */
|
||||
EV_OPTION, /* args: name value ret: */
|
||||
EV_START, /* args: ret: */
|
||||
EV_EXIT, /* args: ret: */
|
||||
EV_REQUEST, /* args: name args ret: stringable */
|
||||
EV_MACRO, /* args: name args ret: stringable */
|
||||
EV_STRING, /* args: name ret: stringable */
|
||||
EV_NUMREG, /* args: name [sign] ret: stringable */
|
||||
EV_SPECIAL, /* args: name ret: stringable */
|
||||
EV_EQUATION, /* args: string ret: stringable */
|
||||
EV_SENTENCE, /* args: char ret: stringable */
|
||||
EV_ESCAPE, /* args: char [arg [sign]] ret: stringable */
|
||||
EV_CHAR /* args: char ret: stringable */
|
||||
} Event;
|
||||
|
||||
/* Flags stored in `requests' table
|
||||
*/
|
||||
#define RQ_STRING 1
|
||||
#define RQ_MACRO 2
|
||||
|
||||
void init_event(void);
|
||||
Elem *event_lookup(Event, char *, int);
|
||||
char *event_exec(Event, char *, int, int *, int);
|
||||
char *event_exec_fallback(Event, char *, int, int *);
|
||||
void events_vec_exec(Event);
|
||||
|
|
@ -0,0 +1,235 @@
|
|||
/* $Revision: 1.5 $
|
||||
*/
|
||||
|
||||
/* Scheme primitives that deal with troff numeric expressions.
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
#define SCALE_INDICATORS "icPmnpuv"
|
||||
|
||||
enum operator {
|
||||
ADD, SUB, DIV, MUL, MOD, LT, GT, LE, GE, EQ, AND, OR, OOPS
|
||||
};
|
||||
|
||||
static int scale_factor[128];
|
||||
static int scale_divisor[128];
|
||||
|
||||
static Object p_set_scaling(Object scale, Object x, Object y) {
|
||||
int d, c;
|
||||
|
||||
Check_Type(scale, T_Character);
|
||||
c = CHAR(scale);
|
||||
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
|
||||
Primitive_Error("invalid scale indicator ~s", scale);
|
||||
scale_factor[c] = Get_Integer(x);
|
||||
if ((d = Get_Integer(y)) == 0)
|
||||
Range_Error(y);
|
||||
scale_divisor[c] = d;
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_get_scaling(Object scale) {
|
||||
int c;
|
||||
Object ret = Null;
|
||||
GC_Node;
|
||||
|
||||
Check_Type(scale, T_Character);
|
||||
c = CHAR(scale);
|
||||
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
|
||||
Primitive_Error("invalid scale indicator ~s", scale);
|
||||
GC_Link(ret);
|
||||
ret = Cons(Make_Integer(scale_factor[c]), Null);
|
||||
Cdr(ret) = Make_Integer(scale_divisor[c]);
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
static enum operator get_operator(char **p) {
|
||||
enum operator op;
|
||||
|
||||
switch (**p) {
|
||||
case '+':
|
||||
op = ADD; break;
|
||||
case '-':
|
||||
op = SUB; break;
|
||||
case '/':
|
||||
op = DIV; break;
|
||||
case '*':
|
||||
op = MUL; break;
|
||||
case '%':
|
||||
op = MOD; break;
|
||||
case '<':
|
||||
if ((*p)[1] == '=') {
|
||||
(*p)++;
|
||||
op = LE;
|
||||
} else
|
||||
op = LT;
|
||||
break;
|
||||
case '>':
|
||||
if ((*p)[1] == '=') {
|
||||
(*p)++;
|
||||
op = GE;
|
||||
} else
|
||||
op = GT;
|
||||
break;
|
||||
case '&':
|
||||
op = AND; break;
|
||||
case ':':
|
||||
op = OR; break;
|
||||
case '=':
|
||||
if ((*p)[1] == '=')
|
||||
(*p)++;
|
||||
op = EQ;
|
||||
break;
|
||||
default:
|
||||
return OOPS;
|
||||
}
|
||||
(*p)++;
|
||||
return op;
|
||||
}
|
||||
|
||||
static double parse_expr(char **, int, int);
|
||||
|
||||
static double get_operand(char **p, int scale, int rest) {
|
||||
double d;
|
||||
char *ep;
|
||||
|
||||
if (**p == '(') {
|
||||
(*p)++;
|
||||
d = parse_expr(p, scale, rest);
|
||||
if (*p) {
|
||||
if (**p != ')') *p = 0;
|
||||
else (*p)++;
|
||||
}
|
||||
return d;
|
||||
}
|
||||
d = strtod(*p, &ep);
|
||||
if (ep == *p) {
|
||||
*p = 0;
|
||||
return 0;
|
||||
}
|
||||
*p = ep;
|
||||
if (**p && strchr(SCALE_INDICATORS, **p)) {
|
||||
scale = **p;
|
||||
(*p)++;
|
||||
}
|
||||
return d * scale_factor[scale] / scale_divisor[scale];
|
||||
}
|
||||
|
||||
static double parse_expr(char **p, int scale, int rest) {
|
||||
double acc, d;
|
||||
enum operator op;
|
||||
|
||||
acc = get_operand(p, scale, rest);
|
||||
if (*p == 0)
|
||||
return 0;
|
||||
while (**p && **p != ')') {
|
||||
if ((op = get_operator(p)) == OOPS) {
|
||||
if (rest)
|
||||
break;
|
||||
err: *p = 0;
|
||||
return 0;
|
||||
}
|
||||
d = get_operand(p, scale, rest);
|
||||
if (*p == 0)
|
||||
return 0;
|
||||
switch (op) {
|
||||
case ADD:
|
||||
acc += d; break;
|
||||
case SUB:
|
||||
acc -= d; break;
|
||||
case DIV:
|
||||
if (d == 0.0) {
|
||||
warn("division by zero"); goto err;
|
||||
}
|
||||
acc /= d; break;
|
||||
case MUL:
|
||||
acc *= d; break;
|
||||
case MOD:
|
||||
acc = fmod(acc, d);
|
||||
if (isnan(acc)) {
|
||||
warn("division by zero"); goto err;
|
||||
}
|
||||
break;
|
||||
case LT:
|
||||
acc = acc < d; break;
|
||||
case GT:
|
||||
acc = acc > d; break;
|
||||
case LE:
|
||||
acc = acc <= d; break;
|
||||
case GE:
|
||||
acc = acc >= d; break;
|
||||
case EQ:
|
||||
acc = acc == d; break;
|
||||
case AND:
|
||||
acc = acc > 0 && d > 0; break;
|
||||
case OR:
|
||||
acc = acc > 0 || d > 0; break;
|
||||
case OOPS:
|
||||
assert(0);
|
||||
}
|
||||
}
|
||||
if (!finite(acc)) {
|
||||
warn("expression evaluates to infinity"); goto err;
|
||||
}
|
||||
return acc;
|
||||
}
|
||||
|
||||
static Object parse_expression(Object str, Object fail, Object scale,
|
||||
int rest) {
|
||||
int c;
|
||||
char *e, *s;
|
||||
double d;
|
||||
Object ret;
|
||||
|
||||
Check_Type(scale, T_Character);
|
||||
c = CHAR(scale);
|
||||
if (c == 0 || strchr(SCALE_INDICATORS, c) == 0)
|
||||
Primitive_Error("invalid scale indicator ~s", scale);
|
||||
e = s = Get_String(str);
|
||||
d = parse_expr(&s, c, rest);
|
||||
if (s == 0 || (*s && !rest)) {
|
||||
warn("invalid expression: `%s'", e);
|
||||
return fail;
|
||||
}
|
||||
ret = P_Inexact_To_Exact(Make_Flonum(d));
|
||||
if (rest) {
|
||||
Object x;
|
||||
GC_Node;
|
||||
|
||||
GC_Link(ret);
|
||||
ret = Cons(ret, Null);
|
||||
x = Make_String(s, strlen(s));
|
||||
Cdr(ret) = x;
|
||||
GC_Unlink;
|
||||
}
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_parse_expression(Object str, Object fail, Object scale) {
|
||||
return parse_expression(str, fail, scale, 0);
|
||||
}
|
||||
|
||||
static Object p_parse_expression_rest(Object str, Object fail, Object scale) {
|
||||
return parse_expression(str, fail, scale, 1);
|
||||
}
|
||||
|
||||
static Object p_char_expression_delimiter(Object c) {
|
||||
Check_Type(c, T_Character);
|
||||
return strchr("0123456789()+-*/%<>=:&.", CHAR(c)) ? True : False;
|
||||
}
|
||||
|
||||
void init_expr(void) {
|
||||
char *p;
|
||||
|
||||
for (p = SCALE_INDICATORS; *p; p++)
|
||||
scale_factor[(int)*p] = scale_divisor[(int)*p] = 1;
|
||||
Define_Primitive(p_set_scaling, "set-scaling!", 3, 3, EVAL);
|
||||
Define_Primitive(p_get_scaling, "get-scaling", 1, 1, EVAL);
|
||||
Define_Primitive(p_parse_expression, "parse-expression", 3, 3, EVAL);
|
||||
Define_Primitive(p_parse_expression_rest,
|
||||
"parse-expression-rest", 3, 3, EVAL);
|
||||
Define_Primitive(p_char_expression_delimiter,
|
||||
"char-expression-delimiter?", 1, 1, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
void init_expr(void);
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
/* $Revision: 1.5 $
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
/* Functions to register Scheme objects in a vector that has been added
|
||||
* to the GC root set to avoid having to deal with weak pointers.
|
||||
* Code using these functions works with indexes into the vector.
|
||||
*
|
||||
* register_object(obj) -- registers an object and returns index
|
||||
* deregister_object(inx) -- deregisters object specified by index
|
||||
* get_object(inx) -- returns object specified by index
|
||||
*/
|
||||
|
||||
static int max_objects = 32; /* initial size */
|
||||
static int num_objects;
|
||||
static Object objects;
|
||||
static int inx;
|
||||
|
||||
int register_object(Object x) {
|
||||
Object v;
|
||||
int n;
|
||||
GC_Node;
|
||||
|
||||
if (num_objects == max_objects) {
|
||||
max_objects *= 2;
|
||||
GC_Link(x);
|
||||
v = Make_Vector(max_objects, Null);
|
||||
GC_Unlink;
|
||||
memcpy(VECTOR(v)->data, VECTOR(objects)->data,
|
||||
num_objects * sizeof(Object));
|
||||
objects = v;
|
||||
inx = num_objects;
|
||||
}
|
||||
for (n = 0; !Nullp(VECTOR(objects)->data[inx]);
|
||||
inx++, inx %= max_objects) {
|
||||
n++;
|
||||
assert(n < max_objects);
|
||||
}
|
||||
VECTOR(objects)->data[inx] = x;
|
||||
num_objects++;
|
||||
return inx;
|
||||
}
|
||||
|
||||
void deregister_object(int i) {
|
||||
VECTOR(objects)->data[i] = Null;
|
||||
--num_objects;
|
||||
assert(num_objects >= 0);
|
||||
}
|
||||
|
||||
Object get_object(int i) {
|
||||
return VECTOR(objects)->data[i];
|
||||
}
|
||||
|
||||
void init_gcroot(void) {
|
||||
objects = Make_Vector(max_objects, Null);
|
||||
Global_GC_Link(objects);
|
||||
}
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
int register_object(Object);
|
||||
void deregister_object(int);
|
||||
Object get_object(int);
|
||||
void init_gcroot(void);
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
/* $Revision: 1.6 $
|
||||
*/
|
||||
|
||||
/* The implementation of the Scheme primitive `file-insertions'.
|
||||
*/
|
||||
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <fcntl.h>
|
||||
#include <unistd.h>
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static int cmp(const void *p1, const void *p2) {
|
||||
struct S_String *s1, *s2;
|
||||
Object o1, o2;
|
||||
int tmp;
|
||||
|
||||
o1 = *(Object *)p1, s1 = STRING(Car(o1));
|
||||
o2 = *(Object *)p2, s2 = STRING(Car(o2));
|
||||
if ((tmp = memcmp(s1->data, s2->data,
|
||||
s1->size < s2->size ? s1->size : s2->size)) == 0)
|
||||
if (s1->size == s2->size)
|
||||
return Get_Integer(Car(Cdr(o1))) - Get_Integer(Car(Cdr(o2)));
|
||||
else
|
||||
return s1->size - s2->size;
|
||||
return tmp;
|
||||
}
|
||||
|
||||
#define Finish_File {\
|
||||
if (fromfn) {\
|
||||
copy_rest(from, to, fromfn, tofn);\
|
||||
close(from);\
|
||||
close(to);\
|
||||
if (rename(tofn, fromfn) == -1) {\
|
||||
Saved_Errno = errno;\
|
||||
Primitive_Error("cannot rename ~s to ~s: ~E", tofn, fromfn);\
|
||||
}\
|
||||
free(tofn);\
|
||||
}\
|
||||
}
|
||||
|
||||
static void copy(int from, int to, char *fromfn, char *tofn,
|
||||
int len, int off) {
|
||||
char buf[8192];
|
||||
int n;
|
||||
|
||||
while (len > 0) {
|
||||
if ((n = read(from, buf, len > 8192 ? 8192 : len)) == -1)
|
||||
read_error(fromfn);
|
||||
if (n == 0)
|
||||
fatal_error("file `%s' too short for insertion at offset %d",
|
||||
fromfn, off);
|
||||
if (write(to, buf, n) != n)
|
||||
write_error(tofn);
|
||||
len -= n;
|
||||
}
|
||||
}
|
||||
|
||||
static void copy_rest(int from, int to, char *fromfn, char *tofn) {
|
||||
char buf[8192];
|
||||
int n;
|
||||
|
||||
while ((n = read(from, buf, 8192)) > 0)
|
||||
if (write(to, buf, n) != n)
|
||||
write_error(tofn);
|
||||
if (n == -1)
|
||||
read_error(fromfn);
|
||||
}
|
||||
|
||||
static Object p_file_insertions(Object spec) {
|
||||
Object v, x;
|
||||
int i, t, from = 0, to = 0; /* make gcc -Wuninitialized happy */
|
||||
char *currfn, *fromfn, *tofn = 0; /* ditto */
|
||||
struct stat st;
|
||||
int off = 0, nextoff; /* ditto for `off' */
|
||||
struct S_String *ins;
|
||||
|
||||
v = P_List_To_Vector(spec);
|
||||
for (i = VECTOR(v)->size; --i >= 0; ) {
|
||||
x = VECTOR(v)->data[i];
|
||||
Check_List(x);
|
||||
if (Fast_Length(x) < 3 || TYPE(Car(x)) != T_String ||
|
||||
((t = TYPE(Car(Cdr(x)))) != T_Fixnum && t != T_Bignum) ||
|
||||
TYPE(Car(Cdr(Cdr(x)))) != T_String)
|
||||
Primitive_Error("invalid file insertion specification");
|
||||
}
|
||||
qsort(VECTOR(v)->data, VECTOR(v)->size, sizeof(Object), cmp);
|
||||
for (fromfn = 0, i = 0; i < VECTOR(v)->size; i++) {
|
||||
x = VECTOR(v)->data[i];
|
||||
currfn = Get_String(Car(x));
|
||||
if (!fromfn || strcmp(fromfn, currfn) != 0) {
|
||||
Finish_File;
|
||||
fromfn = currfn;
|
||||
if ((from = open(fromfn, O_RDONLY)) == -1)
|
||||
open_error(fromfn);
|
||||
(void)fstat(from, &st);
|
||||
if (st.st_nlink > 1) {
|
||||
warn("links to `%s' exist; insertion skipped", fromfn);
|
||||
close(from);
|
||||
fromfn = 0;
|
||||
continue;
|
||||
}
|
||||
tofn = safe_malloc(strlen(fromfn) + 1 + 4);
|
||||
sprintf(tofn, "%s.new", fromfn);
|
||||
if ((to = open(tofn, O_WRONLY|O_CREAT|O_TRUNC, st.st_mode)) == -1)
|
||||
open_error(tofn);
|
||||
off = 0;
|
||||
}
|
||||
x = Cdr(x);
|
||||
nextoff = Get_Integer(Car(x));
|
||||
if (nextoff < 0)
|
||||
Primitive_Error("invalid insertion offset ~a", Car(x));
|
||||
x = Cdr(x);
|
||||
ins = STRING(Car(x));
|
||||
copy(from, to, fromfn, tofn, nextoff-off, nextoff);
|
||||
if (write(to, ins->data, ins->size) != ins->size)
|
||||
write_error(tofn);
|
||||
off = nextoff;
|
||||
}
|
||||
Finish_File;
|
||||
return Void;
|
||||
}
|
||||
|
||||
void init_insert(void) {
|
||||
Define_Primitive(p_file_insertions, "file-insertions", 1, 1, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
void init_insert(void);
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static void (*err_handler)(char *, size_t);
|
||||
static void default_err_handler(char *, size_t);
|
||||
|
||||
void *safe_malloc(size_t n) {
|
||||
void *p;
|
||||
|
||||
if ((p = malloc(n)) == 0) {
|
||||
(err_handler ? err_handler : default_err_handler)("malloc", n);
|
||||
exit(1);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
void *safe_realloc(void *old, size_t n) {
|
||||
void *p;
|
||||
|
||||
if ((p = realloc(old, n)) == 0) {
|
||||
(err_handler ? err_handler : default_err_handler)("realloc", n);
|
||||
exit(1);
|
||||
}
|
||||
return p;
|
||||
}
|
||||
|
||||
void set_alloc_failure(void (*func)(char *, size_t)) {
|
||||
err_handler = func;
|
||||
}
|
||||
|
||||
static void default_err_handler(char *what, size_t n) {
|
||||
fatal_error("cannot %s %lu bytes--virtual memory exhausted",
|
||||
what, (unsigned long)n);
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
void *safe_malloc(size_t);
|
||||
void *safe_realloc(void *, size_t);
|
||||
|
||||
void set_alloc_failure(void (*)(char *, size_t));
|
||||
|
|
@ -0,0 +1,526 @@
|
|||
/* $Revision: 1.21 $
|
||||
*/
|
||||
|
||||
/* The troff parser. Most of the troff-specific code is in this file
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
extern int compatible;
|
||||
|
||||
char escape = '\\';
|
||||
char eqn_delim1, eqn_delim2;
|
||||
static char control = '.';
|
||||
static char control_nobreak = '\'';
|
||||
static unsigned char argspec[256];
|
||||
static char *sentence_end = ".?!";
|
||||
|
||||
|
||||
/* Styles of escape char arguments:
|
||||
*/
|
||||
#define ARG_QUOTED 2 /* \h'xxx', \h|xxx|, ... */
|
||||
#define ARG_SYMBOL 4 /* \fx \f(xx \f[xxx] */
|
||||
#define ARG_SIZE 6 /* \sx \s(xx \s[xxx] \sdd */
|
||||
#define ARG_CHAR 8 /* \zx \z\x \z\(xx \z\[xxx] */
|
||||
#define ARG_LINE 16 /* \" */
|
||||
#define ARG_SIGN 1 /* optional sign: \s */
|
||||
|
||||
|
||||
/* parse_char() return values:
|
||||
*/
|
||||
#define TOK_CHAR 1
|
||||
#define TOK_ESC 2
|
||||
|
||||
|
||||
#define skip(c) {\
|
||||
for ( ; p < ep && *p != c; p++)\
|
||||
;\
|
||||
if (p == ep) {\
|
||||
warn("missing closing `%s' delimiter", printable_char(c)); return 0;\
|
||||
}\
|
||||
}
|
||||
|
||||
#define check_name(c) if (c) {\
|
||||
warn("missing escape name"); return 0;\
|
||||
}
|
||||
|
||||
#define check_arg(c) if (c) {\
|
||||
warn("missing escape sequence argument"); return 0;\
|
||||
}
|
||||
|
||||
#define check_empty(c) if (c) {\
|
||||
warn("empty `[xxx]' sequence"); return 0;\
|
||||
}
|
||||
|
||||
#define is_request(p) \
|
||||
((p)->size > 0 && ((p)->data[0] == control ||\
|
||||
(p)->data[0] == control_nobreak ||\
|
||||
(p)->data[0] == '.'))
|
||||
|
||||
|
||||
/* Deals with \" \* \n. Returns 0 on error, 1 otherwise.
|
||||
*/
|
||||
int parse_expand(Buffer *ip, Buffer *op) {
|
||||
char sign, *p, *ep, *q, *s, *ret;
|
||||
int len, size_ret, nl, ev, fallback;
|
||||
Object str;
|
||||
|
||||
buffer_clear(op);
|
||||
for (p = ip->data, ep = p + ip->size; p < ep; ) {
|
||||
if (*p == escape && ++p < ep) {
|
||||
switch (*p) {
|
||||
case '"':
|
||||
len = ep-p-1;
|
||||
nl = p[len] == '\n';
|
||||
args_clear();
|
||||
args_add(Make_Char('"'));
|
||||
args_add(Make_String(p+1, len));
|
||||
ret = event_exec(EV_ESCAPE, "\"", 1, &size_ret, 1);
|
||||
if (ret)
|
||||
buffer_puts(op, ret, size_ret);
|
||||
else if (nl)
|
||||
buffer_putc(op, '\n');
|
||||
p = ep;
|
||||
break;
|
||||
case 'n':
|
||||
case '*':
|
||||
s = p++;
|
||||
check_name(p == ep);
|
||||
if (*s == 'n' && (*p == '+' || *p == '-')) {
|
||||
sign = *p++;
|
||||
} else sign = 0;
|
||||
check_name(p == ep);
|
||||
switch (*p) {
|
||||
case '(':
|
||||
if ((q = ++p) > ep-2) {
|
||||
warn("escape name truncated"); return 0;
|
||||
}
|
||||
len = 2;
|
||||
p += 2;
|
||||
break;
|
||||
case '[':
|
||||
if (!compatible) {
|
||||
q = ++p;
|
||||
skip(']');
|
||||
check_empty(p == q);
|
||||
len = p++ - q;
|
||||
break;
|
||||
}
|
||||
default:
|
||||
check_name((q = p++) == ep);
|
||||
len = 1;
|
||||
break;
|
||||
}
|
||||
str = Make_String(q, len);
|
||||
ev = *s == 'n' ? EV_NUMREG : EV_STRING;
|
||||
fallback = event_lookup(EV_ESCAPE, s, 1) &&
|
||||
!event_lookup(ev, q, len);
|
||||
args_clear();
|
||||
if (fallback)
|
||||
args_add(Make_Char(*s));
|
||||
args_add(str);
|
||||
if (sign)
|
||||
args_add(Make_Char(sign));
|
||||
if (fallback)
|
||||
ret = event_exec(EV_ESCAPE, s, 1, &size_ret, 1);
|
||||
else
|
||||
ret = event_exec(ev, q, len, &size_ret, 1);
|
||||
if (ret)
|
||||
buffer_puts(op, ret, size_ret);
|
||||
else
|
||||
buffer_puts(op, s-1, p-s+1);
|
||||
break;
|
||||
default:
|
||||
buffer_putc(op, escape);
|
||||
buffer_putc(op, *p);
|
||||
p++;
|
||||
break;
|
||||
}
|
||||
} else if (isspace(UCHAR(*p))) { /* kill space before comment */
|
||||
for (s = p+1; s < ep-1 && isspace(UCHAR(*s)); s++)
|
||||
;
|
||||
if (s < ep-1 && *s == escape && s[1] == '"')
|
||||
p = s;
|
||||
else buffer_putc(op, *p++);
|
||||
} else buffer_putc(op, *p++);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int parse_char(char **pp, char *ep, Buffer *op,
|
||||
int doescape, int doexec, int copymode) {
|
||||
char sign, *p, *s, *ret;
|
||||
char *q = 0; /* make gcc -Wuninitialized happy */
|
||||
int size_ret, tok = 0, len = 0, nl = 0; /* ditto */
|
||||
unsigned char spec;
|
||||
|
||||
p = *pp;
|
||||
if (*p == escape && doescape && p < ep-1) {
|
||||
if (copymode) {
|
||||
if (p[1] != '$') {
|
||||
if (doexec && p[1] != '.' && p[1] != '\\')
|
||||
buffer_putc(op, *p);
|
||||
if (doexec)
|
||||
buffer_putc(op, p[1]);
|
||||
*pp = p+2;
|
||||
return TOK_CHAR;
|
||||
}
|
||||
}
|
||||
switch (*++p) {
|
||||
case '(':
|
||||
if (++p > ep-2) {
|
||||
warn("special character truncated"); return 0;
|
||||
}
|
||||
if (doexec) {
|
||||
args_clear();
|
||||
args_add(Make_String(p, 2));
|
||||
if ((ret = event_exec_fallback(EV_SPECIAL, p, 2,
|
||||
&size_ret)) == 0)
|
||||
buffer_puts(op, p-2, 4);
|
||||
else
|
||||
buffer_puts(op, ret, size_ret);
|
||||
}
|
||||
*pp = p+2;
|
||||
return TOK_CHAR;
|
||||
case '[':
|
||||
if (!compatible) {
|
||||
q = ++p;
|
||||
skip(']');
|
||||
check_empty(p == q);
|
||||
if (doexec) {
|
||||
args_clear();
|
||||
args_add(Make_String(q, p-q));
|
||||
if ((ret = event_exec_fallback(EV_SPECIAL, q, p-q,
|
||||
&size_ret)) == 0)
|
||||
buffer_puts(op, q-2, p-q+3);
|
||||
else
|
||||
buffer_puts(op, ret, size_ret);
|
||||
}
|
||||
*pp = p+1;
|
||||
return TOK_CHAR;
|
||||
}
|
||||
default:
|
||||
spec = argspec[(unsigned char)*p];
|
||||
s = p++;
|
||||
if (spec & ARG_SIGN && p < ep && (*p == '+' || *p == '-')) {
|
||||
sign = *p++;
|
||||
} else sign = 0;
|
||||
switch (spec &= ~ARG_SIGN) {
|
||||
case ARG_SYMBOL:
|
||||
case ARG_SIZE:
|
||||
check_arg(p == ep);
|
||||
switch (*p) {
|
||||
case '(':
|
||||
if ((q = ++p) > ep-2) {
|
||||
warn("escape sequence argument truncated");
|
||||
return 0;
|
||||
}
|
||||
len = 2;
|
||||
p += 2;
|
||||
break;
|
||||
case '[':
|
||||
if (!compatible) {
|
||||
q = ++p;
|
||||
skip(']');
|
||||
check_empty(p == q);
|
||||
len = p++ - q;
|
||||
break;
|
||||
}
|
||||
default:
|
||||
check_arg((q = p++) == ep);
|
||||
len = 1;
|
||||
if (spec == ARG_SIZE && q < ep-1 && *q > '0' && *q < '4'
|
||||
&& isdigit(UCHAR(*p))) {
|
||||
len++, p++;
|
||||
}
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case ARG_CHAR:
|
||||
check_arg((q = p) == ep);
|
||||
if (parse_char(&p, ep, op, doescape, 0, copymode) == 0)
|
||||
return 0;
|
||||
len = p - q;
|
||||
break;
|
||||
case ARG_LINE:
|
||||
q = p;
|
||||
p = ep;
|
||||
len = ep - q;
|
||||
nl = ep[-1] == '\n';
|
||||
break;
|
||||
case ARG_QUOTED:
|
||||
if ((q = p++) >= ep) {
|
||||
warn("missing opening delimiter"); return 0;
|
||||
}
|
||||
if (p == ep) {
|
||||
undelim: warn("missing closing `%s' delimiter", printable_char(*q));
|
||||
return 0;
|
||||
}
|
||||
|
||||
while ((tok = parse_char(&p, ep, op, doescape, 0, copymode))
|
||||
!= 0) {
|
||||
if (tok == TOK_CHAR && p[-1] == *q)
|
||||
break;
|
||||
if (p == ep)
|
||||
goto undelim;
|
||||
}
|
||||
if (tok == 0)
|
||||
return 0;
|
||||
len = p - ++q - 1;
|
||||
break;
|
||||
}
|
||||
if (doexec) {
|
||||
args_clear();
|
||||
args_add(Make_Char(*s));
|
||||
if (spec) {
|
||||
args_add(Make_String(q, len));
|
||||
if (sign)
|
||||
args_add(Make_Char(sign));
|
||||
}
|
||||
ret = event_exec_fallback(EV_ESCAPE, s, 1, &size_ret);
|
||||
if (ret)
|
||||
buffer_puts(op, ret, size_ret);
|
||||
else if (spec & ARG_LINE) {
|
||||
if (nl) buffer_putc(op, '\n');
|
||||
} else
|
||||
buffer_puts(op, s-1, p-s+1);
|
||||
}
|
||||
*pp = p;
|
||||
return TOK_ESC;
|
||||
}
|
||||
} else if (doexec && doescape && !copymode &&
|
||||
eqn_delim1 && *p == eqn_delim1) {
|
||||
s = ++p;
|
||||
for ( ; p < ep && *p != eqn_delim2; p++)
|
||||
;
|
||||
if (p == ep) {
|
||||
warn("non-terminated inline equation");
|
||||
return 0;
|
||||
}
|
||||
args_clear();
|
||||
args_add(Make_String(s, p-s));
|
||||
ret = event_exec(EV_EQUATION, 0, 0, &size_ret, 0);
|
||||
if (ret)
|
||||
buffer_puts(op, ret, size_ret);
|
||||
else
|
||||
buffer_puts(op, s-1, p-s+2);
|
||||
*pp = p+1;
|
||||
return TOK_ESC;
|
||||
} else if (doexec && !copymode && event_lookup(EV_CHAR, p, 1)) {
|
||||
args_clear();
|
||||
args_add(Make_Char(*p));
|
||||
ret = event_exec(EV_CHAR, p, 1, &size_ret, 0);
|
||||
if (ret)
|
||||
buffer_puts(op, ret, size_ret);
|
||||
else
|
||||
buffer_putc(op, *p);
|
||||
*pp = p+1;
|
||||
return TOK_CHAR;
|
||||
} else {
|
||||
if (doexec)
|
||||
buffer_putc(op, *p);
|
||||
*pp = p+1;
|
||||
return TOK_CHAR;
|
||||
}
|
||||
}
|
||||
|
||||
/* Deals with \( \[ \x and chardefs. Returns 0 on error, 1 otherwise.
|
||||
*/
|
||||
int parse_escape(Buffer *ip, Buffer *op, int doescape, int copymode) {
|
||||
char *p, *ep;
|
||||
|
||||
buffer_clear(op);
|
||||
p = ip->data;
|
||||
ep = p + ip->size;
|
||||
while (p < ep && parse_char(&p, ep, op, doescape, 1, copymode) != 0)
|
||||
;
|
||||
return p != 0;
|
||||
}
|
||||
|
||||
static int parse_request(Buffer *ip, Buffer *op) {
|
||||
char *p, *q, *t, *ep, *ret, *start;
|
||||
int reqlen, quote, len, size_ret;
|
||||
int num, macro, minargs = 0, maxargs = 0;
|
||||
Elem *event;
|
||||
Object obj;
|
||||
|
||||
assert(ip->size > 0);
|
||||
p = ip->data+1;
|
||||
ep = ip->data+ip->size;
|
||||
for ( ; p < ep && (*p == ' ' || *p == '\t'); p++)
|
||||
;
|
||||
|
||||
start = p;
|
||||
for ( ; p < ep && !isspace(UCHAR(*p)); p++)
|
||||
if (compatible && p == start+2)
|
||||
break;
|
||||
if ((reqlen = p - start) == 0) /* just a period */
|
||||
return 0;
|
||||
|
||||
if ((event = event_lookup(EV_MACRO, start, reqlen)) != 0) {
|
||||
macro = 1;
|
||||
} else if ((event = event_lookup(EV_REQUEST, start, reqlen)) != 0) {
|
||||
macro = 0;
|
||||
obj = get_object(event->obj);
|
||||
/*
|
||||
* The following three lines prevent what I believe is an optimizer
|
||||
* bug under OSF/1. `obj' is invalid unless it is passed to an
|
||||
* (arbitrary) function before entering the if-statement.
|
||||
*/
|
||||
#ifdef __osf__
|
||||
(void)P_Not(obj); /* any function... */
|
||||
#endif
|
||||
if (TYPE(obj) == T_Compound) {
|
||||
if ((maxargs = COMPOUND(obj)->max_args - 1) < 0)
|
||||
maxargs = INT_MAX;
|
||||
minargs = COMPOUND(obj)->min_args;
|
||||
}
|
||||
} else {
|
||||
warn("no event value for request or macro `%s'",
|
||||
printable_string(start, reqlen));
|
||||
return 0;
|
||||
}
|
||||
|
||||
args_clear();
|
||||
args_add(Make_String(start, reqlen));
|
||||
for (num = 1; ; num++) {
|
||||
for ( ; p < ep && isspace(UCHAR(*p)); p++)
|
||||
;
|
||||
if (p >= ep)
|
||||
break;
|
||||
if (macro && *p == '"') {
|
||||
quote = 1;
|
||||
p++;
|
||||
} else quote = 0;
|
||||
q = t = p;
|
||||
while (1) {
|
||||
if (p == ep || *p == '\n') {
|
||||
/* If quote==1, a closing delimiter is missing. This is
|
||||
* not regarded as an error in troff.
|
||||
*/
|
||||
break;
|
||||
}
|
||||
if (!quote && isspace(UCHAR(*p)) && (macro || num < maxargs))
|
||||
break;
|
||||
if (quote && *p == '"') {
|
||||
if (p < ep-1 && p[1] == '"') /* turn "" into " */
|
||||
p++;
|
||||
else
|
||||
break;
|
||||
}
|
||||
if (*p == escape && p < ep-1) {
|
||||
if (p[1] != '\\')
|
||||
*t++ = *p;
|
||||
p++;
|
||||
}
|
||||
*t++ = *p++;
|
||||
}
|
||||
p++;
|
||||
len = t-q;
|
||||
args_add(Make_String(q, len));
|
||||
}
|
||||
if (!macro)
|
||||
while (num++ < minargs)
|
||||
args_add(Make_String("", 0));
|
||||
ret = event_exec(macro ? EV_MACRO : EV_REQUEST, start, reqlen,
|
||||
&size_ret, 1);
|
||||
if (ret) {
|
||||
buffer_clear(op);
|
||||
buffer_puts(op, ret, size_ret);
|
||||
}
|
||||
return ret != 0;
|
||||
}
|
||||
|
||||
static int is_sentence_end(Buffer *bp) {
|
||||
int len = bp->size;
|
||||
|
||||
return len > 1 && bp->data[len-1] == '\n' &&
|
||||
strchr(sentence_end, bp->data[len-2]);
|
||||
}
|
||||
|
||||
static void exec_sentence_end(Buffer *bp) {
|
||||
int size_ret;
|
||||
char *ret;
|
||||
|
||||
args_clear();
|
||||
args_add(Make_Char(bp->data[bp->size-2]));
|
||||
if ((ret = event_exec(EV_SENTENCE, 0, 0, &size_ret, 0)) != 0) {
|
||||
bp->size -= 2;
|
||||
buffer_puts(bp, ret, size_ret);
|
||||
}
|
||||
}
|
||||
|
||||
static void exec_line(Buffer *bp) {
|
||||
args_clear();
|
||||
if (bp->size > 0)
|
||||
args_add(Make_Char(bp->data[bp->size-1]));
|
||||
else
|
||||
args_add(False);
|
||||
events_vec_exec(EV_LINE);
|
||||
}
|
||||
|
||||
void parse_line(Buffer *ip, Buffer *op) {
|
||||
int do_sentence_end;
|
||||
|
||||
if (is_request(ip)) {
|
||||
if (!parse_request(ip, op))
|
||||
return;
|
||||
if (op->size == 0) /* it's not considered an input line */
|
||||
return;
|
||||
do_sentence_end = 1;
|
||||
} else {
|
||||
do_sentence_end = is_sentence_end(ip);
|
||||
if (!parse_escape(ip, op, 1, 0))
|
||||
return;
|
||||
}
|
||||
if (do_sentence_end && is_sentence_end(op))
|
||||
exec_sentence_end(op);
|
||||
safe_write(op->data, op->size);
|
||||
exec_line(op);
|
||||
}
|
||||
|
||||
void parse_input(void) {
|
||||
int eof_seen;
|
||||
Buffer *b1, *b2;
|
||||
|
||||
b1 = buffer_new(0);
|
||||
b2 = buffer_new(0);
|
||||
do {
|
||||
buffer_clear(b1);
|
||||
if ((eof_seen = safe_readline(b1)) && b1->size == 0)
|
||||
break;
|
||||
if (parse_expand(b1, b2))
|
||||
parse_line(b2, b1);
|
||||
} while (!eof_seen);
|
||||
buffer_delete(b1);
|
||||
buffer_delete(b2);
|
||||
}
|
||||
|
||||
void init_parse(void) {
|
||||
argspec['b'] = ARG_QUOTED;
|
||||
argspec['c'] = ARG_CHAR;
|
||||
argspec['f'] = ARG_SYMBOL;
|
||||
argspec['h'] = ARG_QUOTED;
|
||||
argspec['k'] = ARG_SYMBOL;
|
||||
argspec['l'] = ARG_QUOTED;
|
||||
argspec['n'] = ARG_SYMBOL|ARG_SIGN;
|
||||
argspec['o'] = ARG_QUOTED;
|
||||
argspec['s'] = ARG_SIZE|ARG_SIGN;
|
||||
argspec['v'] = ARG_QUOTED;
|
||||
argspec['w'] = ARG_QUOTED;
|
||||
argspec['x'] = ARG_QUOTED;
|
||||
argspec['z'] = ARG_CHAR;
|
||||
argspec['*'] = ARG_SYMBOL;
|
||||
argspec['$'] = ARG_SYMBOL;
|
||||
argspec['"'] = ARG_LINE;
|
||||
if (!compatible) {
|
||||
argspec['A'] = ARG_QUOTED;
|
||||
argspec['C'] = ARG_QUOTED;
|
||||
argspec['L'] = ARG_QUOTED;
|
||||
argspec['N'] = ARG_QUOTED;
|
||||
argspec['R'] = ARG_QUOTED;
|
||||
argspec['V'] = ARG_SYMBOL;
|
||||
argspec['Y'] = ARG_SYMBOL;
|
||||
argspec['Z'] = ARG_QUOTED;
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
/* $Revision: 1.8 $
|
||||
*/
|
||||
|
||||
extern char escape;
|
||||
extern char eqn_delim1, eqn_delim2;
|
||||
|
||||
int parse_expand(Buffer *, Buffer *);
|
||||
int parse_escape(Buffer *, Buffer *, int, int);
|
||||
void parse_line(Buffer *, Buffer *);
|
||||
void parse_input(void);
|
||||
void init_parse(void);
|
||||
|
|
@ -0,0 +1,382 @@
|
|||
/* $Revision: 1.19 $
|
||||
*/
|
||||
|
||||
/* The implementation of those Scheme primitives that do not deal with
|
||||
* events, tables, streams, expressions, substitutions, and file
|
||||
* insertions.
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
static Object error_port;
|
||||
|
||||
static Object p_error_port(void) {
|
||||
return error_port;
|
||||
}
|
||||
|
||||
static Object p_read_line_expand(void) {
|
||||
Buffer *ip, *op;
|
||||
Object ret;
|
||||
|
||||
ip = buffer_new(0);
|
||||
op = buffer_new(0);
|
||||
if (safe_readline(ip) && ip->size == 0) {
|
||||
ret = Eof;
|
||||
} else {
|
||||
(void)parse_expand(ip, op);
|
||||
ret = Make_String(op->data, op->size);
|
||||
}
|
||||
buffer_delete(ip);
|
||||
buffer_delete(op);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_read_line(void) {
|
||||
Buffer *ip;
|
||||
Object ret;
|
||||
|
||||
ip = buffer_new(0);
|
||||
if (safe_readline(ip) && ip->size == 0) {
|
||||
ret = Eof;
|
||||
} else
|
||||
ret = Make_String(ip->data, ip->size);
|
||||
buffer_delete(ip);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object primitive_parse(int ac, Object *av, int what) {
|
||||
Buffer *ip, *op;
|
||||
Object ret;
|
||||
|
||||
ip = buffer_new(0);
|
||||
op = buffer_new(0);
|
||||
while (ac-- > 0) {
|
||||
Object x = *av++;
|
||||
switch (TYPE(x)) {
|
||||
case T_Character:
|
||||
buffer_putc(ip, CHAR(x));
|
||||
break;
|
||||
case T_Symbol:
|
||||
x = SYMBOL(x)->name; /* fall through */
|
||||
case T_String:
|
||||
buffer_puts(ip, STRING(x)->data, STRING(x)->size);
|
||||
break;
|
||||
default:
|
||||
Primitive_Error("cannot coerce argument to string");
|
||||
}
|
||||
}
|
||||
switch (what) {
|
||||
case 'c': parse_escape(ip, op, 1, 1); break;
|
||||
case 'p': parse_escape(ip, op, 1, 0); break;
|
||||
case 't': parse_escape(ip, op, 0, 0); break;
|
||||
case 'l': parse_line(ip, op); break;
|
||||
case 'e': parse_expand(ip, op); break;
|
||||
}
|
||||
ret = what == 'l' ? Void : Make_String(op->data, op->size);
|
||||
buffer_delete(ip);
|
||||
buffer_delete(op);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_parse(int ac, Object *av) {
|
||||
return primitive_parse(ac, av, 'p');
|
||||
}
|
||||
|
||||
static Object p_translate(int ac, Object *av) {
|
||||
return primitive_parse(ac, av, 't');
|
||||
}
|
||||
|
||||
static Object p_parse_line(int ac, Object *av) {
|
||||
return primitive_parse(ac, av, 'l');
|
||||
}
|
||||
|
||||
static Object p_parse_copy_mode(int ac, Object *av) {
|
||||
return primitive_parse(ac, av, 'c');
|
||||
}
|
||||
|
||||
static Object p_parse_expand(int ac, Object *av) {
|
||||
return primitive_parse(ac, av, 'e');
|
||||
}
|
||||
|
||||
static Object concat(int ac, Object *av, int spread) {
|
||||
Buffer *op;
|
||||
Object ret;
|
||||
|
||||
op = buffer_new(0);
|
||||
while (ac-- > 0) {
|
||||
Object x = *av++;
|
||||
switch (TYPE(x)) {
|
||||
case T_Character:
|
||||
buffer_putc(op, CHAR(x));
|
||||
break;
|
||||
case T_Symbol:
|
||||
x = SYMBOL(x)->name; /* fall through */
|
||||
case T_String:
|
||||
buffer_puts(op, STRING(x)->data, STRING(x)->size);
|
||||
break;
|
||||
default:
|
||||
Primitive_Error("cannot coerce argument to string");
|
||||
}
|
||||
if (spread && ac > 0)
|
||||
buffer_putc(op, ' ')
|
||||
}
|
||||
ret = Make_String(op->data, op->size);
|
||||
buffer_delete(op);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_concat(int ac, Object *av) {
|
||||
return concat(ac, av, 0);
|
||||
}
|
||||
|
||||
static Object p_spread(int ac, Object *av) {
|
||||
return concat(ac, av, 1);
|
||||
}
|
||||
|
||||
static Object p_emit(int ac, Object *av) {
|
||||
while (ac-- > 0) {
|
||||
Object x = *av++;
|
||||
switch (TYPE(x)) {
|
||||
case T_Character:
|
||||
safe_write_char(CHAR(x));
|
||||
break;
|
||||
case T_Symbol:
|
||||
x = SYMBOL(x)->name; /* fall through */
|
||||
case T_String:
|
||||
safe_write(STRING(x)->data, STRING(x)->size);
|
||||
break;
|
||||
default:
|
||||
Primitive_Error("cannot coerce argument to string");
|
||||
}
|
||||
}
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_shell_command(Object cmd) {
|
||||
return Make_Integer(system(Get_Strsym(cmd)));
|
||||
}
|
||||
|
||||
static Object p_remove_file(Object fn) {
|
||||
char *s = Get_Strsym(fn);
|
||||
|
||||
if (remove(s)) warn("cannot remove file `%s'", s);
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_parse_pair(Object x) {
|
||||
char *p, *ep, *s1, *s2, delim;
|
||||
Object str, ret;
|
||||
GC_Node3;
|
||||
|
||||
str = ret = False;
|
||||
GC_Link3(x, str, ret);
|
||||
Check_Type(x, T_String);
|
||||
p = STRING(x)->data;
|
||||
ep = p + STRING(x)->size;
|
||||
if (p <= ep-3) {
|
||||
delim = *p++;
|
||||
for (s1 = p; p < ep && *p != delim; p++)
|
||||
;
|
||||
if (p < ep) {
|
||||
for (s2 = ++p; p < ep && *p != delim; p++)
|
||||
;
|
||||
if (p == ep-1) {
|
||||
str = Make_String(s1, s2-s1-1);
|
||||
ret = Cons(str, Null);
|
||||
str = Make_String(s2, p-s2);
|
||||
Cdr(ret) = str;
|
||||
}
|
||||
}
|
||||
}
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_parse_triple(Object x) {
|
||||
char *p, *ep, *s1, *s2, *s3, delim;
|
||||
Object str, ret;
|
||||
GC_Node3;
|
||||
|
||||
str = ret = False;
|
||||
GC_Link3(x, str, ret);
|
||||
Check_Type(x, T_String);
|
||||
p = STRING(x)->data;
|
||||
ep = p + STRING(x)->size;
|
||||
if (p <= ep-4) {
|
||||
delim = *p++;
|
||||
for (s1 = p; p < ep && *p != delim; p++)
|
||||
;
|
||||
if (p < ep) {
|
||||
for (s2 = ++p; p < ep && *p != delim; p++)
|
||||
;
|
||||
if (p < ep) {
|
||||
for (s3 = ++p; p < ep && *p != delim; p++)
|
||||
;
|
||||
if (p == ep-1) {
|
||||
str = Make_String(s3, p-s3);
|
||||
ret = Cons(Null, str);
|
||||
str = Make_String(s2, s3-s2-1);
|
||||
Car(ret) = str;
|
||||
ret = Cons(Null, ret);
|
||||
str = Make_String(s1, s2-s1-1);
|
||||
Car(ret) = str;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_skip_group(void) {
|
||||
Buffer *ip;
|
||||
int level = 0;
|
||||
char *p, *ep;
|
||||
|
||||
ip = buffer_new(0);
|
||||
do {
|
||||
if (safe_readline(ip) && ip->size == 0) {
|
||||
warn("end-of-scream while skipping requests");
|
||||
break;
|
||||
}
|
||||
for (p = ip->data, ep = p + ip->size; p < ep-2; p++)
|
||||
if (*p == escape)
|
||||
if (*++p == '{') level++;
|
||||
else if (*p == '}') level--;
|
||||
buffer_clear(ip);
|
||||
} while (level > 0);
|
||||
buffer_delete(ip);
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_set_escape(Object c) {
|
||||
Check_Type(c, T_Character);
|
||||
escape = CHAR(c);
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_troff_compatible(void) {
|
||||
extern int compatible;
|
||||
return compatible ? True : False;
|
||||
}
|
||||
|
||||
static Object p_string_prune_left(Object str, Object pref, Object fail) {
|
||||
int l1, l2;
|
||||
|
||||
Check_Type(str, T_String);
|
||||
Check_Type(pref, T_String);
|
||||
l1 = STRING(str)->size, l2 = STRING(pref)->size;
|
||||
if (l2 <= l1 && memcmp(STRING(str)->data, STRING(pref)->data, l2) == 0)
|
||||
return Make_String(STRING(str)->data+l2, l1-l2);
|
||||
return fail;
|
||||
}
|
||||
|
||||
static Object p_string_prune_right(Object str, Object suff, Object fail) {
|
||||
int l1, l2, l;
|
||||
|
||||
Check_Type(str, T_String);
|
||||
Check_Type(suff, T_String);
|
||||
l1 = STRING(str)->size, l2 = STRING(suff)->size, l = l1-l2;
|
||||
if (l >= 0 && memcmp(STRING(str)->data+l, STRING(suff)->data, l2) == 0)
|
||||
return Make_String(STRING(str)->data, l);
|
||||
return fail;
|
||||
}
|
||||
|
||||
static Object p_string_compose(Object old, Object new) {
|
||||
Buffer *bp;
|
||||
struct S_String *s, *t;
|
||||
int i;
|
||||
Object ret;
|
||||
|
||||
bp = buffer_new(0);
|
||||
Check_Type(old, T_String);
|
||||
Check_Type(new, T_String);
|
||||
s = STRING(old), t = STRING(new);
|
||||
if (t->size > 0) {
|
||||
switch (t->data[0]) {
|
||||
case '+':
|
||||
buffer_puts(bp, s->data, s->size);
|
||||
buffer_puts(bp, t->data+1, t->size-1);
|
||||
break;
|
||||
case '-':
|
||||
for (i = 0; i < s->size; i++)
|
||||
if (!memchr(t->data, s->data[i], t->size))
|
||||
buffer_putc(bp, s->data[i]);
|
||||
break;
|
||||
default:
|
||||
buffer_puts(bp, t->data, t->size);
|
||||
}
|
||||
}
|
||||
ret = Make_String(bp->data, bp->size);
|
||||
buffer_delete(bp);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_repeat_string(Object num, Object str) {
|
||||
Buffer *bp;
|
||||
Object ret;
|
||||
int n;
|
||||
|
||||
Check_Type(str, T_String);
|
||||
bp = buffer_new(0);
|
||||
for (n = Get_Integer(num); n > 0; n--)
|
||||
buffer_puts(bp, STRING(str)->data, STRING(str)->size);
|
||||
ret = Make_String(bp->data, bp->size);
|
||||
buffer_delete(bp);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_filter_eqn_line(Object str) {
|
||||
char *p, *q, *ep;
|
||||
|
||||
Check_Type(str, T_String);
|
||||
p = STRING(str)->data, ep = p + STRING(str)->size;
|
||||
for ( ; p < ep && isspace(UCHAR(*p)); p++)
|
||||
;
|
||||
if (p == ep)
|
||||
return False;
|
||||
for (q = p; p < ep && !isspace(UCHAR(*p)); p++)
|
||||
;
|
||||
if (p == ep)
|
||||
return True;
|
||||
if (p-q == 5 && strncmp(q, "delim", 5) == 0) {
|
||||
p++;
|
||||
if (ep-p == 3 && strncmp(p, "off", 3) == 0)
|
||||
eqn_delim1 = 0;
|
||||
else if (ep-p >= 2)
|
||||
eqn_delim1 = *p, eqn_delim2 = p[1];
|
||||
return False;
|
||||
}
|
||||
return p-q == 6 && strncmp(q, "define", 6) == 0 ? False : True;
|
||||
}
|
||||
|
||||
void init_prim(void) {
|
||||
error_port = Make_Port (0, stderr, Make_String ("stderr", 6));
|
||||
if (setvbuf(stderr, 0, _IOLBF, BUFSIZ) != 0)
|
||||
fatal_error("cannot set stderr line buffered");
|
||||
Global_GC_Link(error_port);
|
||||
Define_Primitive(p_error_port, "error-port", 0, 0, EVAL);
|
||||
Define_Primitive(p_read_line, "read-line", 0, 0, EVAL);
|
||||
Define_Primitive(p_read_line_expand, "read-line-expand", 0, 0, EVAL);
|
||||
Define_Primitive(p_parse, "parse", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_parse_copy_mode, "parse-copy-mode", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_parse_line, "parse-line", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_parse_expand, "parse-expand", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_translate, "translate", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_concat, "concat", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_spread, "spread", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_emit, "emit", 0, MANY, VARARGS);
|
||||
Define_Primitive(p_substitute, "substitute", 1, MANY, VARARGS);
|
||||
Define_Primitive(p_shell_command, "shell-command", 1, 1, EVAL);
|
||||
Define_Primitive(p_remove_file, "remove-file", 1, 1, EVAL);
|
||||
Define_Primitive(p_parse_pair, "parse-pair", 1, 1, EVAL);
|
||||
Define_Primitive(p_parse_triple, "parse-triple", 1, 1, EVAL);
|
||||
Define_Primitive(p_skip_group, "skip-group", 0, 0, EVAL);
|
||||
Define_Primitive(p_set_escape, "set-escape!", 1, 1, EVAL);
|
||||
Define_Primitive(p_troff_compatible, "troff-compatible?", 0, 0, EVAL);
|
||||
Define_Primitive(p_string_prune_left, "string-prune-left", 3, 3, EVAL);
|
||||
Define_Primitive(p_string_prune_right,"string-prune-right", 3, 3, EVAL);
|
||||
Define_Primitive(p_string_compose, "string-compose", 2, 2, EVAL);
|
||||
Define_Primitive(p_repeat_string, "repeat-string", 2, 2, EVAL);
|
||||
Define_Primitive(p_filter_eqn_line, "filter-eqn-line", 1, 1, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
void init_prim(void);
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
/* $Revision: 1.3 $
|
||||
*/
|
||||
|
||||
/* The implementation of the Scheme type `table' and the primitives
|
||||
* that work on tables. This file is basically an additional layer
|
||||
* on top of the code in table.c.
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
#define TABLE(x) ((struct s_table *)POINTER(x))
|
||||
|
||||
struct s_table {
|
||||
Object tag;
|
||||
Table *t;
|
||||
};
|
||||
|
||||
static int T_Table;
|
||||
|
||||
static Object p_tablep(Object x) {
|
||||
return TYPE(x) == T_Table ? True : False;
|
||||
}
|
||||
|
||||
static int table_equal(Object t1, Object t2) {
|
||||
return EQ(t1, t2);
|
||||
}
|
||||
|
||||
static int table_print(Object x, Object port, int raw, int depth,
|
||||
int length) {
|
||||
Printf(port, "#[table %lu]", TABLE(x)->t);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static Object terminate_table(Object x) {
|
||||
table_delete(TABLE(x)->t);
|
||||
return Void;
|
||||
}
|
||||
|
||||
static Object p_make_table(Object size) {
|
||||
Object t;
|
||||
int s;
|
||||
|
||||
if ((s = Get_Integer(size)) <= 0)
|
||||
Range_Error(size);
|
||||
t = Alloc_Object(sizeof(struct s_table), T_Table, 0);
|
||||
TABLE(t)->tag = Null;
|
||||
TABLE(t)->t = table_new(s);
|
||||
Register_Object(t, (GENERIC)0, terminate_table, 0);
|
||||
return t;
|
||||
}
|
||||
|
||||
static Object table_op(int op, Object t, Object key, Object val) {
|
||||
Elem *p;
|
||||
Object ret = Void;
|
||||
char *data;
|
||||
int size;
|
||||
Table *tp;
|
||||
|
||||
Check_Type(t, T_Table);
|
||||
tp = TABLE(t)->t;
|
||||
if (TYPE(key) == T_Symbol)
|
||||
key = SYMBOL(key)->name;
|
||||
else if (TYPE(key) != T_String)
|
||||
Wrong_Type_Combination(key, "string or symbol");
|
||||
data = STRING(key)->data;
|
||||
size = STRING(key)->size;
|
||||
if (size == 0)
|
||||
Primitive_Error("key must be of non-zero length");
|
||||
switch(op) {
|
||||
case 's':
|
||||
table_store(tp, data, size, val, 0);
|
||||
break;
|
||||
case 'r':
|
||||
table_remove(tp, data, size);
|
||||
break;
|
||||
case 'l':
|
||||
if ((p = table_lookup(tp, data, size)) == 0)
|
||||
ret = False;
|
||||
else
|
||||
ret = get_object(p->obj);
|
||||
}
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_table_store(Object t, Object key, Object val) {
|
||||
return table_op('s', t, key, val);
|
||||
}
|
||||
|
||||
static Object p_table_remove(Object t, Object key) {
|
||||
return table_op('r', t, key, Null);
|
||||
}
|
||||
|
||||
static Object p_table_lookup(Object t, Object key) {
|
||||
return table_op('l', t, key, Null);
|
||||
}
|
||||
|
||||
void init_scmtable(void) {
|
||||
T_Table = Define_Type(0, "table", NOFUNC, sizeof(struct s_table),
|
||||
table_equal, table_equal, table_print, NOFUNC);
|
||||
Define_Primitive(p_tablep, "table?", 1, 1, EVAL);
|
||||
Define_Primitive(p_make_table, "make-table", 1, 1, EVAL);
|
||||
Define_Primitive(p_table_store, "table-store!", 3, 3, EVAL);
|
||||
Define_Primitive(p_table_remove, "table-remove!", 2, 2, EVAL);
|
||||
Define_Primitive(p_table_lookup, "table-lookup", 2, 2, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
/* $Revision: 1.1 $
|
||||
*/
|
||||
|
||||
void init_scmtable(void);
|
||||
|
|
@ -0,0 +1,440 @@
|
|||
/* $Revision: 1.14 $
|
||||
*/
|
||||
|
||||
/* The implementation of the Scheme type `stream' and the primitives
|
||||
* that work on streams. Additional functions exported by this module:
|
||||
*
|
||||
* istream_is_open() -- true if current input stream != #f
|
||||
* ostream_is_open() -- true if current output stream != #f
|
||||
* curr_istream_target() -- returns target of current input stream
|
||||
* curr_istream_lno() -- returns current istream's input line number
|
||||
* safe_readline(buffer) -- reads line from current istream into buffer;
|
||||
* signals error if istream is not open
|
||||
* safe_write_char(c) -- sends character to current ostream or to
|
||||
* stdout if ostream is #f
|
||||
* safe_write(data,len) -- same, but writes several characters
|
||||
*/
|
||||
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
typedef struct _stream {
|
||||
Object tag;
|
||||
char open;
|
||||
char type;
|
||||
char direction;
|
||||
char *target;
|
||||
FILE *fp;
|
||||
Buffer *bp;
|
||||
int bs;
|
||||
unsigned long lno;
|
||||
unsigned long pos;
|
||||
Buffer *unread;
|
||||
int (*readline)(struct _stream *, Buffer *);
|
||||
void (*write)(struct _stream *, char *, int);
|
||||
void (*close)(struct _stream *);
|
||||
} Stream;
|
||||
|
||||
static Object buffers;
|
||||
static Object istream, ostream;
|
||||
|
||||
#define STREAM(x) ((Stream *)POINTER(x))
|
||||
|
||||
static int T_Stream;
|
||||
|
||||
static Object p_streamp(Object x) {
|
||||
return TYPE(x) == T_Stream ? True : False;
|
||||
}
|
||||
|
||||
static int stream_equal(Object s1, Object s2) {
|
||||
return EQ(s1, s2);
|
||||
}
|
||||
|
||||
static int stream_print(Object x, Object port, int raw, int depth,
|
||||
int length) {
|
||||
Stream *p = STREAM(x);
|
||||
|
||||
if (p->open || p->type == 'b')
|
||||
Printf(port, "#[stream %s]", p->target);
|
||||
else
|
||||
Printf(port, "#[stream %lu]", POINTER(x));
|
||||
return 0;
|
||||
}
|
||||
|
||||
static Object terminate_stream(Object x) {
|
||||
Stream *p = STREAM(x);
|
||||
|
||||
if (p->open && !(p->type == 'b' && p->direction == 'o')) {
|
||||
free(p->target);
|
||||
buffer_delete(p->unread);
|
||||
if (p->type != 'b')
|
||||
p->close(p);
|
||||
}
|
||||
p->open = 0;
|
||||
return Void;
|
||||
}
|
||||
|
||||
int istream_is_open(void) {
|
||||
return Truep(istream);
|
||||
}
|
||||
|
||||
char *curr_istream_target(void) {
|
||||
assert(Truep(istream));
|
||||
assert(STREAM(istream)->open);
|
||||
return STREAM(istream)->target;
|
||||
}
|
||||
|
||||
unsigned long curr_istream_lno(void) {
|
||||
return STREAM(istream)->lno;
|
||||
}
|
||||
|
||||
static int stream_is_active(Object str) {
|
||||
return EQ(istream, str) || EQ(ostream, str);
|
||||
}
|
||||
|
||||
int safe_readline(Buffer *bp) {
|
||||
Stream *str;
|
||||
|
||||
if (!Truep(istream))
|
||||
Primitive_Error("no input stream defined");
|
||||
str = STREAM(istream);
|
||||
if (str->unread->size > 0) {
|
||||
buffer_puts(bp, str->unread->data, str->unread->size);
|
||||
if (bp->data[bp->size-1] != '\n')
|
||||
buffer_putc(bp, '\n');
|
||||
buffer_clear(str->unread);
|
||||
return 0;
|
||||
}
|
||||
return str->readline(str, bp);
|
||||
}
|
||||
|
||||
void safe_write_char(char c) {
|
||||
if (Truep(ostream)) {
|
||||
STREAM(ostream)->pos++;
|
||||
STREAM(ostream)->write(STREAM(ostream), &c, 1);
|
||||
} else if (putc(c, stdout) == EOF)
|
||||
write_error("stdout");
|
||||
}
|
||||
|
||||
void safe_write(char *data, int len) {
|
||||
if (len == 0)
|
||||
return;
|
||||
if (Truep(ostream)) {
|
||||
STREAM(ostream)->pos += len;
|
||||
STREAM(ostream)->write(STREAM(ostream), data, len);
|
||||
} else if (fwrite(data, len, 1, stdout) == 0)
|
||||
write_error("stdout");
|
||||
}
|
||||
|
||||
#define is_continuation(p) \
|
||||
((p)->size > oldsize && (p)->data[(p)->size-1] == escape &&\
|
||||
!((p)->size > oldsize+1 && (p)->data[(p)->size-2] == escape))
|
||||
|
||||
static int readline_buffer(Stream *self, Buffer *bp) {
|
||||
int oldsize;
|
||||
int c;
|
||||
Buffer *sp = self->bp;
|
||||
|
||||
assert(self->bs <= sp->size);
|
||||
if (self->bs == sp->size)
|
||||
return 1;
|
||||
oldsize = bp->size;
|
||||
while (self->bs < sp->size) {
|
||||
if ((c = sp->data[self->bs++]) == '\n') {
|
||||
self->lno++;
|
||||
if (is_continuation(bp)) {
|
||||
bp->size--;
|
||||
} else {
|
||||
buffer_putc(bp, c);
|
||||
return 0;
|
||||
}
|
||||
} else buffer_putc(bp, c);
|
||||
}
|
||||
if (bp->size > oldsize) {
|
||||
buffer_putc(bp, '\n');
|
||||
self->lno++;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int readline_file(Stream *self, Buffer *bp) {
|
||||
int oldsize;
|
||||
int c;
|
||||
|
||||
if (feof(self->fp))
|
||||
return 1;
|
||||
oldsize = bp->size;
|
||||
while ((c = getc(self->fp)) != EOF) {
|
||||
if (c == '\n') {
|
||||
self->lno++;
|
||||
if (is_continuation(bp)) {
|
||||
bp->size--;
|
||||
} else {
|
||||
buffer_putc(bp, c);
|
||||
return 0;
|
||||
}
|
||||
} else buffer_putc(bp, c);
|
||||
}
|
||||
if (ferror(self->fp))
|
||||
read_error(self->target);
|
||||
if (bp->size > oldsize) {
|
||||
buffer_putc(bp, '\n');
|
||||
self->lno++;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static void write_buffer(Stream *self, char *data, int len) {
|
||||
buffer_puts(self->bp, data, len);
|
||||
}
|
||||
|
||||
static void write_file(Stream *self, char *data, int len) {
|
||||
if (fwrite(data, len, 1, self->fp) == 0)
|
||||
write_error(self->target);
|
||||
}
|
||||
|
||||
static void close_file(Stream *self) {
|
||||
(void)fclose(self->fp);
|
||||
}
|
||||
|
||||
static void close_pipe(Stream *self) {
|
||||
(void)pclose(self->fp);
|
||||
}
|
||||
|
||||
static Object find_buffer(char *s) {
|
||||
Object p;
|
||||
|
||||
for (p = buffers; !Nullp(p); p = Cdr(p)) {
|
||||
if (strcmp(STREAM(Car(p))->target, s) == 0)
|
||||
return Car(p);
|
||||
}
|
||||
return Null;
|
||||
}
|
||||
|
||||
static int target_is_buffer(char *s) {
|
||||
int len = strlen(s);
|
||||
|
||||
return len > 1 && s[0] == '[' && s[len-1] == ']';
|
||||
}
|
||||
|
||||
static Object open_stream(Object target, char direction, int append) {
|
||||
char *t = Get_Strsym(target), *mode;
|
||||
Stream *p;
|
||||
Object ret = Null, b = Null;
|
||||
GC_Node3;
|
||||
|
||||
GC_Link3(target, ret, b);
|
||||
if (target_is_buffer(t)) {
|
||||
b = find_buffer(t);
|
||||
if (!Nullp(b)) {
|
||||
p = STREAM(b);
|
||||
assert(p->type == 'b');
|
||||
assert(p->direction == 'o');
|
||||
if (p->open)
|
||||
Primitive_Error("stream ~s is already open", b);
|
||||
if (direction == 'o') {
|
||||
p->open = 1;
|
||||
p->lno = p->bs = 0;
|
||||
if (!append) {
|
||||
p->pos = 0;
|
||||
buffer_clear(p->bp);
|
||||
}
|
||||
GC_Unlink;
|
||||
return b;
|
||||
}
|
||||
}
|
||||
}
|
||||
ret = Alloc_Object(sizeof(Stream), T_Stream, 0);
|
||||
p = STREAM(ret);
|
||||
p->tag = Null;
|
||||
p->open = 1;
|
||||
p->direction = direction;
|
||||
p->lno = p->pos = 0;
|
||||
p->unread = buffer_new(0);
|
||||
p->target = safe_malloc(strlen(t) + 1);
|
||||
strcpy(p->target, t);
|
||||
if (target_is_buffer(t)) {
|
||||
p->readline = readline_buffer;
|
||||
p->write = write_buffer; /* no close function */
|
||||
p->type = 'b';
|
||||
p->bp = buffer_new(0);
|
||||
if (direction == 'o') {
|
||||
buffers = Cons(ret, buffers);
|
||||
} else {
|
||||
p->bs = 0;
|
||||
if (!Nullp(b))
|
||||
buffer_puts(p->bp, STREAM(b)->bp->data, STREAM(b)->bp->size);
|
||||
}
|
||||
} else {
|
||||
mode = direction == 'i' ? "r" : append ? "a" : "w";
|
||||
p->readline = readline_file;
|
||||
p->write = write_file;
|
||||
if (t[0] == '|') {
|
||||
char *s;
|
||||
if ((p->fp = popen(t+1, mode)) == 0)
|
||||
Primitive_Error("cannot open pipe to ~s", target);
|
||||
if ((s = strchr(p->target, ' ')) != 0)
|
||||
*s = 0;
|
||||
p->close = close_pipe;
|
||||
p->type = 'p';
|
||||
} else {
|
||||
if (direction == 'i' && strcmp(t, "stdin") == 0) {
|
||||
p->fp = stdin;
|
||||
} else if ((p->fp = fopen(t, mode)) == 0) {
|
||||
Saved_Errno = errno;
|
||||
Primitive_Error("cannot open ~s: ~E", target);
|
||||
}
|
||||
p->close = close_file;
|
||||
p->type = 'f';
|
||||
}
|
||||
}
|
||||
Register_Object(ret, (GENERIC)0, terminate_stream, 0);
|
||||
GC_Unlink;
|
||||
return ret;
|
||||
}
|
||||
|
||||
Object p_open_input_stream(Object target) {
|
||||
return open_stream(target, 'i', 0);
|
||||
}
|
||||
|
||||
static Object p_open_output_stream(Object target) {
|
||||
return open_stream(target, 'o', 0);
|
||||
}
|
||||
|
||||
static Object p_append_output_stream(Object target) {
|
||||
return open_stream(target, 'o', 1);
|
||||
}
|
||||
|
||||
Object p_close_stream(Object x) {
|
||||
if (!Truep(x))
|
||||
return Void;
|
||||
Check_Type(x, T_Stream);
|
||||
if (!STREAM(x)->open)
|
||||
return Void;
|
||||
if (stream_is_active(x))
|
||||
Primitive_Error("stream ~s is still in use", x);
|
||||
return terminate_stream(x);
|
||||
}
|
||||
|
||||
static Object set_stream(Object x, Object *which) {
|
||||
Object ret = *which;
|
||||
Stream *p;
|
||||
|
||||
if (Truep(*which) && STREAM(*which)->type != 'b' &&
|
||||
STREAM(*which)->direction == 'o')
|
||||
(void)fflush(STREAM(*which)->fp);
|
||||
if (Truep(x)) {
|
||||
Check_Type(x, T_Stream);
|
||||
p = STREAM(x);
|
||||
if (!p->open)
|
||||
Primitive_Error("stream ~s has been closed", x);
|
||||
if (stream_is_active(x))
|
||||
Primitive_Error("stream ~s is already in use", x);
|
||||
if (which == &istream && p->direction != 'i')
|
||||
Primitive_Error("stream ~s is not an input stream", x);
|
||||
if (which == &ostream && p->direction != 'o')
|
||||
Primitive_Error("stream ~s is not an output stream", x);
|
||||
*which = x;
|
||||
} else {
|
||||
*which = False;
|
||||
}
|
||||
return ret;
|
||||
}
|
||||
|
||||
Object p_set_input_stream(Object x) {
|
||||
return set_stream(x, &istream);
|
||||
}
|
||||
|
||||
static Object p_set_output_stream(Object x) {
|
||||
return set_stream(x, &ostream);
|
||||
}
|
||||
|
||||
static Object p_input_stream(void) {
|
||||
return istream;
|
||||
}
|
||||
|
||||
static Object p_output_stream(void) {
|
||||
return ostream;
|
||||
}
|
||||
|
||||
static Object p_unread_line(Object str) {
|
||||
Check_Type(str, T_String);
|
||||
if (!Truep(istream))
|
||||
Primitive_Error("no input stream defined");
|
||||
buffer_puts(STREAM(istream)->unread, STRING(str)->data,
|
||||
STRING(str)->size);
|
||||
return Void;
|
||||
}
|
||||
|
||||
#define stream_type_pred(what,t)\
|
||||
static Object p_stream_##what(Object x) {\
|
||||
if (Truep(x)) {\
|
||||
Check_Type(x, T_Stream);\
|
||||
return STREAM(x)->type == t ? True : False;\
|
||||
} else return False;\
|
||||
}
|
||||
stream_type_pred(buffer, 'b')
|
||||
stream_type_pred(file, 'f')
|
||||
stream_type_pred(pipe, 'p')
|
||||
|
||||
static Object p_stream_target(Object x) {
|
||||
if (!Truep(x))
|
||||
return Make_String("", 0);
|
||||
Check_Type(x, T_Stream);
|
||||
return Make_String(STREAM(x)->target, strlen(STREAM(x)->target));
|
||||
}
|
||||
|
||||
static Object p_stream_to_string(Object target) {
|
||||
Object str, old, ret;
|
||||
Stream *sp;
|
||||
Buffer *bp;
|
||||
|
||||
str = p_open_input_stream(target);
|
||||
old = p_set_input_stream(str);
|
||||
bp = buffer_new(0);
|
||||
for (sp = STREAM(str); sp->readline(sp, bp) == 0; )
|
||||
;
|
||||
(void)p_set_input_stream(old);
|
||||
(void)p_close_stream(str);
|
||||
ret = Make_String(bp->data, bp->size);
|
||||
buffer_delete(bp);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static Object p_stream_position(Object x) {
|
||||
if (!Truep(x))
|
||||
return Make_Integer(0);
|
||||
Check_Type(x, T_Stream);
|
||||
return Make_Unsigned_Long(STREAM(x)->pos);
|
||||
}
|
||||
|
||||
void init_stream(void) {
|
||||
istream = ostream = False;
|
||||
buffers = Null;
|
||||
Global_GC_Link(istream);
|
||||
Global_GC_Link(ostream);
|
||||
Global_GC_Link(buffers);
|
||||
T_Stream = Define_Type(0, "stream", NOFUNC, sizeof(Stream),
|
||||
stream_equal, stream_equal, stream_print, NOFUNC);
|
||||
Define_Primitive(p_streamp, "stream?", 1, 1, EVAL);
|
||||
Define_Primitive(p_open_input_stream,
|
||||
"open-input-stream", 1, 1, EVAL);
|
||||
Define_Primitive(p_open_output_stream,
|
||||
"open-output-stream", 1, 1, EVAL);
|
||||
Define_Primitive(p_append_output_stream,
|
||||
"append-output-stream", 1, 1, EVAL);
|
||||
Define_Primitive(p_close_stream, "close-stream", 1, 1, EVAL);
|
||||
Define_Primitive(p_set_input_stream,
|
||||
"set-input-stream!", 1, 1, EVAL);
|
||||
Define_Primitive(p_set_output_stream,
|
||||
"set-output-stream!", 1, 1, EVAL);
|
||||
Define_Primitive(p_input_stream, "input-stream", 0, 0, EVAL);
|
||||
Define_Primitive(p_output_stream, "output-stream", 0, 0, EVAL);
|
||||
Define_Primitive(p_unread_line, "unread-line", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_buffer, "stream-buffer?", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_file, "stream-file?", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_pipe, "stream-pipe?", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_target, "stream-target", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_to_string,"stream->string", 1, 1, EVAL);
|
||||
Define_Primitive(p_stream_position, "stream-position", 1, 1, EVAL);
|
||||
}
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
/* $Revision: 1.5 $
|
||||
*/
|
||||
|
||||
int istream_is_open(void);
|
||||
int ostream_is_open(void);
|
||||
char *curr_istream_target(void);
|
||||
unsigned long curr_istream_lno(void);
|
||||
|
||||
int safe_readline(Buffer *);
|
||||
void safe_write_char(char);
|
||||
void safe_write(char *, int);
|
||||
|
||||
Object p_open_input_stream(Object);
|
||||
Object p_close_stream(Object);
|
||||
Object p_set_input_stream(Object);
|
||||
|
||||
void init_stream(void);
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
/* $Revision: 1.9 $
|
||||
*/
|
||||
|
||||
/* The implementation of the Scheme primitive `substitute'
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
Object p_substitute(int ac, Object *av) {
|
||||
Object str = *av;
|
||||
static Buffer *fp;
|
||||
char *p, *ep, *s, *t, *endp;
|
||||
int len;
|
||||
long a;
|
||||
char buf[30];
|
||||
char *fmt;
|
||||
time_t now;
|
||||
extern char *macros, *format, *directory;
|
||||
|
||||
Check_Type(str, T_String);
|
||||
if (!fp)
|
||||
fp = buffer_new(0);
|
||||
buffer_clear(fp);
|
||||
for (p = STRING(str)->data, ep = p + STRING(str)->size; p < ep; p++) {
|
||||
if (*p == '%') {
|
||||
for (s = ++p; p < ep && *p != '%'; p++)
|
||||
;
|
||||
if (p == ep)
|
||||
Primitive_Error("missing `%' delimiter");
|
||||
len = p-s;
|
||||
t = safe_malloc(len+1); /* Make copy to add \0. C sucks... */
|
||||
memcpy(t, s, len);
|
||||
t[len] = 0;
|
||||
fmt = 0;
|
||||
if (len == 0)
|
||||
s = "%";
|
||||
else if (strcmp(t, "macros") == 0)
|
||||
s = macros;
|
||||
else if (strcmp(t, "format") == 0)
|
||||
s = format;
|
||||
else if (strcmp(t, "directory") == 0)
|
||||
s = directory;
|
||||
else if (strcmp(t, "progname") == 0)
|
||||
s = get_progname();
|
||||
else if (strcmp(t, "filepos") == 0) { /* ` file:lno' */
|
||||
if (istream_is_open()) {
|
||||
buffer_putc(fp, ' ');
|
||||
buffer_puts(fp, curr_istream_target(),
|
||||
strlen(curr_istream_target()));
|
||||
sprintf(buf, ":%lu:", curr_istream_lno());
|
||||
s = buf;
|
||||
} else s = "";
|
||||
} else if (strcmp(t, "tmpname") == 0) {
|
||||
s = tmpnam(0);
|
||||
} else if (strcmp(t, "version") == 0) {
|
||||
sprintf(buf, "%d.%d", MAJOR_VERSION, MINOR_VERSION);
|
||||
s = buf;
|
||||
} else if (strcmp(t, "weekday") == 0) {
|
||||
fmt = "%a";
|
||||
} else if (strcmp(t, "weekday+") == 0) {
|
||||
fmt = "%A";
|
||||
} else if (strcmp(t, "weekdaynum")== 0) {
|
||||
fmt = "%w";
|
||||
} else if (strcmp(t, "monthname") == 0) {
|
||||
fmt = "%b";
|
||||
} else if (strcmp(t, "monthname+") == 0) {
|
||||
fmt = "%B";
|
||||
} else if (strcmp(t, "day") == 0) {
|
||||
fmt = "%d";
|
||||
} else if (strcmp(t, "month") == 0) {
|
||||
fmt = "%m";
|
||||
} else if (strcmp(t, "year") == 0) {
|
||||
fmt = "%Y";
|
||||
} else if (strcmp(t, "date") == 0) {
|
||||
fmt = "%x";
|
||||
} else if (strcmp(t, "time") == 0) {
|
||||
fmt = "%X";
|
||||
} else if ((a = strtol(t, &endp, 10)), endp == t+len) {
|
||||
if (a < 1 || a > ac-1)
|
||||
Primitive_Error("no argument for %-specifier");
|
||||
Check_Type(av[a], T_String);
|
||||
buffer_puts(fp, STRING(av[a])->data, STRING(av[a])->size);
|
||||
s = "";
|
||||
} else if ((s = getenv(t)) == 0)
|
||||
s = "";
|
||||
if (fmt) {
|
||||
now = time(0);
|
||||
if (strftime(buf, sizeof buf, fmt, localtime(&now)) == 0)
|
||||
s = "";
|
||||
else s = buf;
|
||||
}
|
||||
free(t);
|
||||
buffer_puts(fp, s, strlen(s));
|
||||
} else
|
||||
buffer_putc(fp, *p);
|
||||
}
|
||||
return Make_String(fp->data, fp->size);
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
/* $Revision: 1.2 $
|
||||
*/
|
||||
|
||||
Object p_substitute(int, Object*);
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
/* $Revision: 1.8 $
|
||||
*/
|
||||
|
||||
/* Simple hash tables.
|
||||
*
|
||||
* table_new(size) -- returns a new hash table
|
||||
* table_delete(t) -- frees a table and its entries
|
||||
* table_store(t,key,keylen,obj,flags)
|
||||
* -- stores Scheme object and flags under key
|
||||
* table_lookup(t,key,keylen) -- returns object stored under key, or 0
|
||||
* table_remove(t,key,keylen) -- removes entry stored under key
|
||||
*/
|
||||
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
Table *table_new(int size) {
|
||||
Table *p;
|
||||
int i;
|
||||
|
||||
assert(size > 0);
|
||||
p = safe_malloc(sizeof *p);
|
||||
p->data = safe_malloc(size * sizeof(Elem *));
|
||||
for (i = 0; i < size; i++)
|
||||
p->data[i] = 0;
|
||||
p->size = size;
|
||||
return p;
|
||||
}
|
||||
|
||||
void table_delete(Table *tp) {
|
||||
int i;
|
||||
Elem *p, *q;
|
||||
|
||||
for (i = 0; i < tp->size; i++)
|
||||
for (p = tp->data[i]; p; p = q) {
|
||||
deregister_object(p->obj);
|
||||
free(p->data);
|
||||
q = p->next;
|
||||
free(p);
|
||||
}
|
||||
free(tp->data);
|
||||
free(tp);
|
||||
}
|
||||
|
||||
/* This function ensures that no collisions can occur in tables of
|
||||
* size 256^N if all keys are of length <= N (for small values of N).
|
||||
*/
|
||||
static unsigned long hash(char *key, int size) {
|
||||
unsigned long i, j;
|
||||
|
||||
assert(size > 0);
|
||||
for (i = j = 0; j < size; j++)
|
||||
i = i * 256 + (unsigned char)key[j];
|
||||
return i;
|
||||
}
|
||||
|
||||
void table_store(Table *tp, char *key, int size, Object obj,
|
||||
unsigned long flags) {
|
||||
int i = hash(key, size) % tp->size;
|
||||
Elem *p;
|
||||
|
||||
for (p = tp->data[i]; p; p = p->next) {
|
||||
if (size == p->size && memcmp(key, p->data, size) == 0) break;
|
||||
}
|
||||
if (p) {
|
||||
deregister_object(p->obj);
|
||||
} else {
|
||||
p = safe_malloc(sizeof *p);
|
||||
p->data = safe_malloc(size);
|
||||
memcpy(p->data, key, size);
|
||||
p->size = size;
|
||||
p->next = tp->data[i];
|
||||
tp->data[i] = p;
|
||||
}
|
||||
p->obj = register_object(obj);
|
||||
p->flags = flags;
|
||||
}
|
||||
|
||||
void table_remove(Table *tp, char *key, int size) {
|
||||
int i = hash(key, size) % tp->size;
|
||||
Elem *p, **pp;
|
||||
|
||||
for (pp = &tp->data[i]; (p = *pp); pp = &p->next )
|
||||
if (size == p->size && memcmp(key, p->data, size) == 0) break;
|
||||
if (p) {
|
||||
*pp = p->next;
|
||||
deregister_object(p->obj);
|
||||
free(p->data);
|
||||
free(p);
|
||||
}
|
||||
}
|
||||
|
||||
Elem *table_lookup(Table *tp, char *key, int size) {
|
||||
int i = hash(key, size) % tp->size;
|
||||
Elem *p;
|
||||
|
||||
for (p = tp->data[i]; p; p = p->next) {
|
||||
if (size == p->size && memcmp(key, p->data, size) == 0) return p;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
/* $Revision: 1.5 $
|
||||
*/
|
||||
|
||||
typedef struct _elem {
|
||||
char *data;
|
||||
int size;
|
||||
int obj;
|
||||
unsigned long flags;
|
||||
struct _elem *next;
|
||||
} Elem;
|
||||
|
||||
typedef struct _table {
|
||||
Elem **data;
|
||||
int size;
|
||||
} Table;
|
||||
|
||||
Table *table_new(int);
|
||||
void table_delete(Table *);
|
||||
void table_store(Table *, char *, int, Object, unsigned long);
|
||||
void table_remove(Table *, char *, int);
|
||||
Elem *table_lookup(Table *, char *, int);
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
.LP
|
||||
Here comes an EQ/EN pair that just serves defining the delimiters
|
||||
for inline equations (we will use the dollar sign for this purpose).
|
||||
No eqn-output should not appear here, and no hypertext reference
|
||||
should be generated if we are creating GIF files.
|
||||
.EQ
|
||||
delim $$
|
||||
.EN
|
||||
.LP
|
||||
Now lets typeset a real equation, again using EQ and EN.
|
||||
The equation should either be displayed as preformatted text or as
|
||||
an inline GIF image:
|
||||
.EQ
|
||||
size 18 { a+b over 2c = 1 }
|
||||
.EN
|
||||
Finally an inline equation such as $size 16 { sqrt a+b }$ which uses the
|
||||
delimiters defined at the start of this document.
|
||||
It should either be typeset in Italics or appear as a GIF image.
|
||||
.LP
|
||||
Now lets test tables.
|
||||
Here is a simple table that uses the \f2box\fP attribute and
|
||||
has two header rows, two columns, and three data rows:
|
||||
.TS
|
||||
box, tab(~);
|
||||
c s
|
||||
c | c
|
||||
n n.
|
||||
Price Development
|
||||
_
|
||||
Year~Price
|
||||
_
|
||||
1992~$1,500
|
||||
1993~2,000
|
||||
1994~12,220
|
||||
.TE
|
||||
.LP
|
||||
The table should either appear as preformatted text or as a GIF
|
||||
image (the latter will probably turn out a bit too small).
|
||||
Finally a PIC drawing:
|
||||
.PS
|
||||
box "foo"
|
||||
arrow
|
||||
box "bar"
|
||||
.PE
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
(define old-in (input-stream))
|
||||
|
||||
(define out (open-output-stream '/tmp/net))
|
||||
(set-output-stream! out)
|
||||
(emit "Hello, ")
|
||||
(set-output-stream! #f)
|
||||
|
||||
(define out2 (open-output-stream '[out2]))
|
||||
(set-output-stream! out2)
|
||||
(close-stream out)
|
||||
|
||||
(define in (open-input-stream '/tmp/net))
|
||||
(set-input-stream! in)
|
||||
(emit (read-line-expand))
|
||||
(emit "world!")
|
||||
(set-input-stream! #f)
|
||||
(close-stream in)
|
||||
|
||||
(set-output-stream! #f)
|
||||
(close-stream out2)
|
||||
|
||||
(define out2 (open-input-stream '[out2]))
|
||||
(defchar #\newline "")
|
||||
(set-input-stream! out2)
|
||||
(emit (parse (read-line-expand)))
|
||||
(emit (read-line-expand))
|
||||
(set-input-stream! old-in)
|
||||
(close-stream out2)
|
||||
|
||||
(shell-command "rm /tmp/net")
|
||||
|
||||
|
||||
(define tt (make-table 1))
|
||||
(define t (make-table 100))
|
||||
(table-store! tt "table" t)
|
||||
(define t (table-lookup tt 'table))
|
||||
|
||||
(table-store! t 'bye '())
|
||||
(table-remove! t 'bye)
|
||||
(table-store! t 'greet "Hello,")
|
||||
(table-store! t (table-lookup t 'greet) " world!\n")
|
||||
|
||||
(if (and (table? t) (not (table-lookup t 'bye)))
|
||||
(begin
|
||||
(display (table-lookup t 'greet))
|
||||
(display (table-lookup t (table-lookup t 'greet)))))
|
||||
|
||||
|
||||
(define-option-type 'hello-type
|
||||
(lambda (x) (member (string-ref x 0) '(#\H #\w)))
|
||||
"oops1!!"
|
||||
(lambda (old new) (string->list new))
|
||||
(lambda (x) (member (car x) '(#\H #\w)))
|
||||
"oops2!!")
|
||||
|
||||
(define-option 'hello 'hello-type "oops3!!")
|
||||
|
||||
((eventdef 'option 0) (string-compose "helxlxo" "-x") "Hello, ")
|
||||
(display (list->string (option 'hello)))
|
||||
(set-option! 'hello (string->list (string-compose "wo" "+rld")))
|
||||
(display (list->string (option 'hello)))
|
||||
(display
|
||||
(string-prune-left (concat (repeat-string 2 "!") #\newline) "!" "oops"))
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
/* $Revision: 1.21 $
|
||||
*/
|
||||
|
||||
#include "unroff.h"
|
||||
|
||||
extern int getopt(int ac, char * const *av, const char *optstring);
|
||||
|
||||
extern char *optarg;
|
||||
extern int optind, opterr;
|
||||
|
||||
char *macros = "";
|
||||
char *format;
|
||||
char *directory;
|
||||
int compatible;
|
||||
|
||||
static int got_filename;
|
||||
static int did_ev_start;
|
||||
static int tflag;
|
||||
|
||||
static void usage(void) {
|
||||
fprintf(stderr, "Usage: %s [options] [file...]\n\n", get_progname());
|
||||
fprintf(stderr, " -mname name of troff macro package (e.g. -ms)\n");
|
||||
fprintf(stderr, " -fformat output format (e.h. -fhtml2)\n");
|
||||
fprintf(stderr, " -C enable nroff/troff compatibility\n");
|
||||
fprintf(stderr, " -hheapsize Scheme heap size in Kbytes\n");
|
||||
fprintf(stderr, " -t enter interactive top-level for testing\n");
|
||||
fprintf(stderr, " option=val any macro-package/format-specific option\n");
|
||||
}
|
||||
|
||||
static char *filename_tail(char *fn) {
|
||||
char *p = strrchr(fn, '/');
|
||||
|
||||
return p && p > fn && p[1] ? p+1 : fn;
|
||||
}
|
||||
|
||||
/* If the file name has the suffix .scm, load it into the interpreter.
|
||||
* Else, open an input stream and assign it to the current input stream.
|
||||
* Call start event procedure if necessary; trigger prolog event.
|
||||
* Start the parser; when finished, trigger epilog event.
|
||||
*/
|
||||
static void do_input_file(char *fn) {
|
||||
Object name, base, old, str;
|
||||
char *p;
|
||||
int len;
|
||||
GC_Node4;
|
||||
|
||||
len = strlen(fn);
|
||||
if (len > 3 && strcmp(fn + len - 4, ".scm") == 0) {
|
||||
name = Make_String(fn, strlen(fn));
|
||||
(void)P_Load(1, &name);
|
||||
return;
|
||||
}
|
||||
if (fn[0] == '-' && fn[1] == 0)
|
||||
fn = "stdin";
|
||||
name = base = old = str = Null;
|
||||
GC_Link4(name, base, old, str);
|
||||
name = Make_String(fn, strlen(fn));
|
||||
p = filename_tail(fn);
|
||||
base = Make_String(p, strlen(p));
|
||||
str = p_open_input_stream(name);
|
||||
old = p_set_input_stream(str);
|
||||
if (!did_ev_start) {
|
||||
args_clear();
|
||||
events_vec_exec(EV_START);
|
||||
did_ev_start = 1;
|
||||
}
|
||||
args_clear();
|
||||
args_add(name);
|
||||
args_add(base);
|
||||
events_vec_exec(EV_PROLOG);
|
||||
parse_input();
|
||||
args_clear();
|
||||
args_add(name);
|
||||
args_add(base);
|
||||
events_vec_exec(EV_EPILOG);
|
||||
(void)p_set_input_stream(old);
|
||||
(void)p_close_stream(str);
|
||||
GC_Unlink;
|
||||
}
|
||||
|
||||
/* Determine whether argument is a file name or an option; trigger
|
||||
* option event in the latter case.
|
||||
*/
|
||||
static void do_argument(char *arg) {
|
||||
char *p;
|
||||
|
||||
if ((p = strchr(arg, '=')) == 0) {
|
||||
got_filename = 1;
|
||||
if (!tflag)
|
||||
do_input_file(arg);
|
||||
} else {
|
||||
if (p == arg)
|
||||
fatal_error("empty option name");
|
||||
args_clear();
|
||||
args_add(Make_String(arg, p++ - arg));
|
||||
args_add(Make_String(p, strlen(arg) - (p - arg)));
|
||||
events_vec_exec(EV_OPTION);
|
||||
}
|
||||
}
|
||||
|
||||
/* Load scm/troff.scm. The rest is loaded from there.
|
||||
*/
|
||||
static void boot_code(void) {
|
||||
char *fn = safe_malloc(strlen(directory) + 30);
|
||||
Object arg;
|
||||
|
||||
sprintf(fn, "%s/scm/troff.scm", directory);
|
||||
arg = Make_String(fn, strlen(fn));
|
||||
(void)P_Load(1, &arg);
|
||||
free(fn);
|
||||
}
|
||||
|
||||
/* Load $(HOME)/.RC_FILE, if it is there.
|
||||
*/
|
||||
static void load_rc_file(void) {
|
||||
FILE *f;
|
||||
char *home, *fn;
|
||||
Object port;
|
||||
GC_Node;
|
||||
|
||||
if ((home = getenv("HOME")) == 0)
|
||||
return;
|
||||
fn = safe_malloc(strlen(home) + 30);
|
||||
sprintf(fn, "%s/%s", home, RC_FILE);
|
||||
if ((f = fopen(fn, "r")) != 0) {
|
||||
port = Make_Port(P_INPUT, f, Make_String(fn, strlen(fn)));
|
||||
GC_Link(port);
|
||||
Load_Source_Port(port);
|
||||
P_Close_Input_Port(port); /* does the fclose() */
|
||||
GC_Unlink;
|
||||
}
|
||||
free(fn);
|
||||
}
|
||||
|
||||
/* Load the interactive Scheme top-level.
|
||||
*/
|
||||
static void test_mode(void) {
|
||||
Object arg;
|
||||
char fn[] = TEST_TOPLEVEL;
|
||||
|
||||
arg = Make_String(fn, strlen(fn));
|
||||
(void)P_Load(1, &arg);
|
||||
}
|
||||
|
||||
int main(int ac, char **av) {
|
||||
char **eav;
|
||||
int eac = 1, c;
|
||||
|
||||
if (ac == 0) {
|
||||
fprintf(stderr, "Oops--no argv[0]?\n"); return 1;
|
||||
}
|
||||
set_progname(av[0]);
|
||||
if ((directory = getenv(DEFAULT_DIR_ENV)) == 0)
|
||||
directory = DEFAULT_DIR;
|
||||
if ((format = getenv(DEFAULT_FORMAT_ENV)) == 0)
|
||||
format = DEFAULT_FORMAT;
|
||||
eav = safe_malloc((ac+1+2) * sizeof(char *)); /* ac + -p xxx + 0-ptr */
|
||||
eav[0] = av[0];
|
||||
opterr = 0;
|
||||
while ((c = getopt(ac, av, "h:gm:f:tC")) != EOF) {
|
||||
switch (c) {
|
||||
case 'g':
|
||||
eav[eac++] = "-g"; break;
|
||||
case 'h':
|
||||
if (strcmp(optarg, "elp") == 0) {
|
||||
usage();
|
||||
return 1;
|
||||
}
|
||||
eav[eac++] = "-h"; eav[eac++] = optarg; break;
|
||||
case 'm':
|
||||
macros = optarg; break;
|
||||
case 'f':
|
||||
format = optarg; break;
|
||||
case 't':
|
||||
tflag = 1; break;
|
||||
case 'C':
|
||||
compatible = 1; break;
|
||||
case '?':
|
||||
usage();
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
/* Set the Elk load-path to $(directory)/elk, so that a minimal,
|
||||
* self-contained Elk runtime environment can be shipped with
|
||||
* binary distributions. Sites with a full Elk can symlink
|
||||
* $(directory)/elk to the real directory.
|
||||
*/
|
||||
eav[eac++] = "-p";
|
||||
eav[eac] = safe_malloc(strlen(directory) * 2 + 30);
|
||||
sprintf(eav[eac++], ".:%s/elk/scm:%s/elk/obj", directory, directory);
|
||||
eav[eac] = 0;
|
||||
Elk_Init(eac, eav, 0, 0);
|
||||
init_args();
|
||||
init_gcroot();
|
||||
init_insert();
|
||||
init_event();
|
||||
init_expr();
|
||||
init_parse();
|
||||
init_prim();
|
||||
init_scmtable();
|
||||
init_stream();
|
||||
#ifdef ELK_MAJOR
|
||||
Set_Error_Tag("load");
|
||||
#else
|
||||
Error_Tag = "load";
|
||||
#endif
|
||||
boot_code();
|
||||
load_rc_file();
|
||||
if (tflag) {
|
||||
while (optind < ac)
|
||||
do_argument(av[optind++]);
|
||||
if (got_filename)
|
||||
warn("filename arguments are ignored when -t is given");
|
||||
test_mode();
|
||||
return 0;
|
||||
}
|
||||
#ifdef ELK_MAJOR
|
||||
Set_Error_Tag("main-loop");
|
||||
#else
|
||||
Error_Tag = "main-loop";
|
||||
#endif
|
||||
while (optind < ac)
|
||||
do_argument(av[optind++]);
|
||||
if (!got_filename)
|
||||
do_input_file("-");
|
||||
if (did_ev_start) {
|
||||
args_clear();
|
||||
events_vec_exec(EV_EXIT);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
/* $Revision: 1.18 $
|
||||
*/
|
||||
|
||||
#include <assert.h>
|
||||
#include <limits.h>
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <stdarg.h>
|
||||
#include <string.h>
|
||||
#include <errno.h>
|
||||
#include <ctype.h>
|
||||
#include <time.h>
|
||||
#include <math.h>
|
||||
|
||||
|
||||
/* Include files that may be required by gcc although they shouldn't:
|
||||
*/
|
||||
#include <memory.h>
|
||||
|
||||
|
||||
/* Prototypes that may be required by cc/gcc although they shouldn't:
|
||||
*/
|
||||
extern time_t time(time_t *);
|
||||
extern size_t strftime(char *, size_t, const char *, const struct tm *);
|
||||
extern long strtol(const char *s, char **endp, int base);
|
||||
extern double strtod(const char *s, char **endp);
|
||||
extern int pclose(FILE *);
|
||||
extern int system(const char *);
|
||||
#ifndef tolower
|
||||
extern int tolower(int);
|
||||
#endif
|
||||
|
||||
/* Prototypes for IEEE FP functions that may be missing:
|
||||
*/
|
||||
#ifndef finite
|
||||
extern int finite(double);
|
||||
#endif
|
||||
|
||||
|
||||
#include "scheme.h"
|
||||
|
||||
/* Prototypes that were missing from "scheme.h" in some Elk releases:
|
||||
*/
|
||||
extern void Elk_Init(int ac, char **av, int call_inits, char *filename);
|
||||
extern void Load_Source_Port(Object);
|
||||
|
||||
|
||||
/* Used for passing a `char' to a function that takes an `int' argument,
|
||||
* such as isspace(). Maybe I should have used `unsigned char' rather
|
||||
* than `char' in the first place...
|
||||
*/
|
||||
#define UCHAR(c) ((unsigned char)(c))
|
||||
|
||||
|
||||
#include "config.h"
|
||||
#include "args.h"
|
||||
#include "buffer.h"
|
||||
#include "table.h"
|
||||
#include "error.h"
|
||||
#include "event.h"
|
||||
#include "expr.h"
|
||||
#include "gcroot.h"
|
||||
#include "insert.h"
|
||||
#include "malloc.h"
|
||||
#include "parse.h"
|
||||
#include "prim.h"
|
||||
#include "scmtable.h"
|
||||
#include "stream.h"
|
||||
#include "subst.h"
|
||||
Loading…
Reference in New Issue