summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/guile/README6
-rwxr-xr-xsrc/guile/skribilo.scm4
-rw-r--r--src/guile/skribilo/debug.scm8
-rw-r--r--src/guile/skribilo/engine.scm5
-rw-r--r--src/guile/skribilo/engine/base.scm4
-rw-r--r--src/guile/skribilo/engine/context.scm6
-rw-r--r--src/guile/skribilo/engine/html.scm25
-rw-r--r--src/guile/skribilo/engine/html4.scm5
-rw-r--r--src/guile/skribilo/engine/latex.scm14
-rw-r--r--src/guile/skribilo/engine/lout.scm2977
-rw-r--r--src/guile/skribilo/lib.scm7
-rw-r--r--src/guile/skribilo/module.scm6
-rw-r--r--src/guile/skribilo/runtime.scm167
-rw-r--r--src/guile/skribilo/skribe/api.scm117
-rw-r--r--src/guile/skribilo/skribe/bib.scm14
-rw-r--r--src/guile/skribilo/skribe/utils.scm31
-rw-r--r--src/guile/skribilo/types.scm2
-rw-r--r--src/guile/skribilo/vars.scm7
-rw-r--r--src/guile/skribilo/verify.scm10
-rw-r--r--src/guile/skribilo/writer.scm5
20 files changed, 3210 insertions, 210 deletions
diff --git a/src/guile/README b/src/guile/README
index 4bd7eff..8b1502c 100644
--- a/src/guile/README
+++ b/src/guile/README
@@ -11,6 +11,12 @@ Here are a few goals.
** Better error handling, automatic back-traces, etc.
+** Add useful markups
+
+- numbered references
+
+- improved footnotes
+
** Add an option to continuously watch a file and re-compile it
* Font-ends (readers)
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index a43ec66..33c2bb4 100755
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -387,7 +387,7 @@ Processes a Skribilo/Skribe source file and produces its output.
skribilo-options))
(engine (string->symbol
(option-ref options 'target "html")))
- (debugging-level (option-ref options 'debug 0))
+ (debugging-level (option-ref options 'debug "0"))
(load-path (option-ref options 'load-path "."))
(bib-path (option-ref options 'bib-path "."))
(preload '())
@@ -455,6 +455,8 @@ Processes a Skribilo/Skribe source file and produces its output.
(with-output-to-file dest-file doskribe)
(doskribe)))))
+ (set! *skribe-dest* dest-file)
+
(if (and dest-file (file-exists? dest-file))
(delete-file dest-file))
diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm
index b880a66..cc0dfb2 100644
--- a/src/guile/skribilo/debug.scm
+++ b/src/guile/skribilo/debug.scm
@@ -27,7 +27,8 @@
(define-module (skribilo debug)
:export (with-debug %with-debug
debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
- no-debug-color))
+ no-debug-color)
+ :use-module (srfi srfi-17))
(define *skribe-debug* 0)
@@ -50,8 +51,9 @@
(define (no-debug-color)
(set! *skribe-debug-color* #f))
-(define (skribe-debug)
- *skribe-debug*)
+(define-public skribe-debug
+ (getter-with-setter (lambda () *skribe-debug*)
+ (lambda (val) (set! *skribe-debug* val))))
;;
;; debug-port
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index 1b39ec6..0353e2d 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -26,11 +26,12 @@
;;;
(define-module (skribilo engine)
+ :use-module (skribilo module)
:use-module (skribilo debug)
-; :use-module (skribilo evaluator)
:use-module (skribilo writer)
:use-module (skribilo types)
:use-module (skribilo lib)
+ :use-module (skribilo vars)
:use-module (oop goops)
:use-module (ice-9 optargs)
@@ -99,7 +100,7 @@
((engine? *skribe-engine*) *skribe-engine*)
(else (find-engine *skribe-engine*)))))
(if (not (engine? e))
- (skribe-error 'engine-format? "No engine" e)
+ (skribe-error 'engine-format? "no engine" e)
(string=? fmt (engine-format e)))))
;;;
diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm
index 53d837d..ed15da4 100644
--- a/src/guile/skribilo/engine/base.scm
+++ b/src/guile/skribilo/engine/base.scm
@@ -152,9 +152,9 @@
(k (markup-option n 'kind))
(f (cond
(s
- (format "?~a@~a " k s))
+ (format #f "?~a@~a " k s))
(else
- (format "?~a " k))))
+ (format #f "?~a " k))))
(msg (list f (markup-body n)))
(n (list "[" (color :fg "red" (bold msg)) "]")))
(skribe-eval n e))))
diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm
index 48a069e..a79e88a 100644
--- a/src/guile/skribilo/engine/context.scm
+++ b/src/guile/skribilo/engine/context.scm
@@ -386,7 +386,7 @@
:format "context"
:delegate (find-engine 'base)
:filter (make-string-replace context-encoding)
- :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m)))
+ :symbol-table (context-symbol-table (lambda (m) (format #f "$~a$" m)))
:custom context-customs)))
;;;; ======================================================================
@@ -647,7 +647,7 @@
(if (not (number? nb))
(skribe-error
'font
- (format "Illegal font size ~s" size)
+ (format #f "Illegal font size ~s" size)
nb)
(+ cs nb))))))
(ne (make-engine (gensym 'context)
@@ -980,7 +980,7 @@
(let ((text (markup-option n :text))
(url (markup-body n)))
(when (pair? url)
- (context-url (format "mailto:~A" (car url))
+ (context-url (format #f "mailto:~A" (car url))
(or text
(car url))
e)))))
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
index c85f18f..3ad7da6 100644
--- a/src/guile/skribilo/engine/html.scm
+++ b/src/guile/skribilo/engine/html.scm
@@ -39,7 +39,7 @@
(begin
(set! table (cons (cons base 1) table))
1))))
- (format "~a-~a.~a" base n suf)))
+ (format #f "~a-~a.~a" base n suf)))
(lambda (node e)
(let ((f (markup-option node filename))
(file (markup-option node :file)))
@@ -517,12 +517,12 @@
((not (pair? cnts))
cnts)
((null? (cdr cnts))
- (format "~a." (car cnts)))
+ (format #f "~a." (car cnts)))
(else
(let loop ((cnts cnts))
(if (null? (cdr cnts))
- (format "~a" (car cnts))
- (format "~a.~a" (car cnts) (loop (cdr cnts))))))))
+ (format #f "~a" (car cnts))
+ (format #f "~a.~a" (car cnts) (loop (cdr cnts))))))))
;*---------------------------------------------------------------------*/
;* html-width ... */
@@ -530,9 +530,9 @@
(define (html-width width)
(cond
((and (integer? width) (exact? width))
- (format "~A" width))
+ (format #f "~A" width))
((real? width)
- (format "~A%" (inexact->exact (round width))))
+ (format #f "~A%" (inexact->exact (round width))))
((string? width)
width)
(else
@@ -688,7 +688,7 @@
(id (markup-ident n)))
(unless (string? id)
(skribe-error '&html-generic-header
- (format "Illegal identifier `~a'" id)
+ (format #f "Illegal identifier `~a'" id)
n))
;; title
(output (new markup
@@ -769,7 +769,7 @@
(display " span.sc { font-variant: small-caps }\n")
(display " span.sf { font-family: sans-serif }\n")
(display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n")
- (when hd (display (format " ~a\n" hd)))
+ (when hd (display (format #f " ~a\n" hd)))
(when (pair? icss)
(for-each (lambda (css)
(let ((p (open-input-file css)))
@@ -984,7 +984,7 @@
(sui-blocks 'subsubsection n e)
(display " )\n"))
(if (string? *skribe-dest*)
- (let ((f (format "~a.sui" (prefix *skribe-dest*))))
+ (let ((f (format #f "~a.sui" (prefix *skribe-dest*))))
(with-output-to-file f sui))
(sui)))
@@ -1117,7 +1117,7 @@
(f (html-file c e)))
(unless (string? id)
(skribe-error 'toc
- (format "Illegal identifier `~a'" id)
+ (format #f "illegal identifier `~a'" id)
c))
(display " <tr>")
;; blank columns
@@ -1129,7 +1129,8 @@
(printf "<td colspan=\"~a\" width=\"100%\">"
(- 4 level))
(printf "<a href=\"~a#~a\">"
- (if (string=? f *skribe-dest*)
+ (if (and *skribe-dest*
+ (string=? f *skribe-dest*))
""
(strip-ref-base (or f *skribe-dest* "")))
(string-canonicalize id))
@@ -1913,7 +1914,7 @@
(markup-class n)
"inbound")))
(printf "<a href=\"~a#~a\" class=\"~a\""
- (if (string=? f *skribe-dest*)
+ (if (and *skribe-dest* (string=? f *skribe-dest*))
""
(strip-ref-base (or f *skribe-dest* "")))
(string-canonicalize id)
diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm
index 614ca99..ddc7c73 100644
--- a/src/guile/skribilo/engine/html4.scm
+++ b/src/guile/skribilo/engine/html4.scm
@@ -123,14 +123,15 @@
((or (unspecified? sz) (not sz))
#f)
((and (number? sz) (or (inexact? sz) (negative? sz)))
- (format "~a%"
+ (format #f "~a%"
(+ 100
(* 20 (inexact->exact (truncate sz))))))
((number? sz)
sz)
(else
(skribe-error 'font
- (format "Illegal font size ~s" sz)
+ (format #f
+ "illegal font size ~s" sz)
n))))))
(display "<span ")
(html-class n)
diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm
index bc20493..8bd0ae3 100644
--- a/src/guile/skribilo/engine/latex.scm
+++ b/src/guile/skribilo/engine/latex.scm
@@ -350,7 +350,7 @@
(index-page-ref #t))
:symbol-table (latex-symbol-table
(lambda (m)
- (format "\\begin{math}~a\\end{math}" m))))))
+ (format #f "\\begin{math}~a\\end{math}" m))))))
;*---------------------------------------------------------------------*/
;* latex-title-engine ... */
@@ -361,7 +361,7 @@
:format "latex-title"
:delegate latex-engine
:filter (make-string-replace latex-encoding)
- :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m)))))
+ :symbol-table (latex-symbol-table (lambda (m) (format #f "$~a$" m)))))
;*---------------------------------------------------------------------*/
;* latex-color? ... */
@@ -453,7 +453,7 @@
"1.,1.,1.")
(else
(let ((ff (exact->inexact #xff)))
- (format "~a,~a,~a"
+ (format #f "~a,~a,~a"
(number->string (/ r ff))
(number->string (/ g ff))
(number->string (/ b ff))))))))
@@ -887,7 +887,7 @@
(if (not (number? nb))
(skribe-error
'font
- (format "Illegal font size ~s" size)
+ (format #f "Illegal font size ~s" size)
nb)
(+ cs nb))))))
(ne (make-engine (gensym 'latex)
@@ -1170,7 +1170,7 @@
(output (new markup
(markup '&latex-table-hline)
(parent n)
- (ident (format "~a-above" id))
+ (ident (format #f "~a-above" id))
(class "table-line-above"))
e))
((above hsides)
@@ -1178,7 +1178,7 @@
(output (new markup
(markup '&latex-table-hline)
(parent n)
- (ident (format "~a-above" id))
+ (ident (format #f "~a-above" id))
(class "table-line-above"))
e))
((vsides)
@@ -1225,7 +1225,7 @@
(output (new markup
(markup '&latex-table-hline)
(parent n)
- (ident (format "~a-below" (markup-ident n)))
+ (ident (format #f "~a-below" (markup-ident n)))
(class "table-hline-below"))
e)))
(output (new markup
diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
new file mode 100644
index 0000000..b675e8a
--- /dev/null
+++ b/src/guile/skribilo/engine/lout.scm
@@ -0,0 +1,2977 @@
+;*=====================================================================*/
+;* Lout Skribe engine */
+;* ------------------------------------------------------------- */
+;* (C) Copyright 2004, 2005 Ludovic Courtès */
+;* */
+;* Taken from `lcourtes@laas.fr--2004-libre/ */
+;* skribe-lout--main--0.2--patch-15' */
+;* Based on `latex.skr', copyright 2003,2004 Manuel Serrano. */
+;*=====================================================================*/
+
+(define-skribe-module (skribilo engine lout))
+
+;* This is the Lout engine, part of Skribilo.
+;*
+;* Skribe is free software; you can redistribute it and/or modify
+;* it under the terms of the GNU General Public License as published by
+;* the Free Software Foundation; either version 2 of the License, or
+;* (at your option) any later version.
+;*
+;* Skribe is distributed in the hope that it will be useful,
+;* but WITHOUT ANY WARRANTY; without even the implied warranty of
+;* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;* GNU General Public License for more details.
+;*
+;* You should have received a copy of the GNU General Public License
+;* along with Skribe; if not, write to the Free Software
+;* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+;*---------------------------------------------------------------------*/
+;* lout-verbatim-encoding ... */
+;*---------------------------------------------------------------------*/
+(define lout-verbatim-encoding
+ '((#\/ "\"/\"")
+ (#\\ "\"\\\\\"")
+ (#\| "\"|\"")
+ (#\& "\"&\"")
+ (#\@ "\"@\"")
+ (#\" "\"\\\"\"")
+ (#\{ "\"{\"")
+ (#\} "\"}\"")
+ (#\$ "\"$\"")
+ (#\# "\"#\"")
+ (#\_ "\"_\"")
+ (#\~ "\"~\"")))
+
+;*---------------------------------------------------------------------*/
+;* lout-encoding ... */
+;*---------------------------------------------------------------------*/
+(define lout-encoding
+ `(,@lout-verbatim-encoding
+ (#\ç "{ @Char ccedilla }")
+ (#\Ç "{ @Char Ccdeilla }")
+ (#\â "{ @Char acircumflex }")
+ (#\Â "{ @Char Acircumflex }")
+ (#\à "{ @Char agrave }")
+ (#\À "{ @Char Agrave }")
+ (#\é "{ @Char eacute }")
+ (#\É "{ @Char Eacute }")
+ (#\è "{ @Char egrave }")
+ (#\È "{ @Char Egrave }")
+ (#\ê "{ @Char ecircumflex }")
+ (#\Ê "{ @Char Ecircumflex }")
+ (#\ù "{ @Char ugrave }")
+ (#\Ù "{ @Char Ugrave }")
+ (#\û "{ @Char ucircumflex }")
+ (#\Û "{ @Char Ucircumflex }")
+ (#\ø "{ @Char oslash }")
+ (#\ô "{ @Char ocircumflex }")
+ (#\Ô "{ @Char Ocircumflex }")
+ (#\ö "{ @Char odieresis }")
+ (#\Ö "{ @Char Odieresis }")
+ (#\î "{ @Char icircumflex }")
+ (#\Î "{ @Char Icircumflex }")
+ (#\ï "{ @Char idieresis }")
+ (#\Ï "{ @Char Idieresis }")
+ (#\] "\"]\"")
+ (#\[ "\"[\"")
+ (#\» "{ @Char guillemotright }")
+ (#\« "{ @Char guillemotleft }")))
+
+
+;; XXX: This is just here for experimental purposes.
+(define lout-french-punctuation-encoding
+ (let ((space (lambda (before after thing)
+ (string-append "{ "
+ (if before
+ (string-append "{ " before " @Wide {} }")
+ "")
+ "\"" thing "\""
+ (if after
+ (string-append "{ " after " @Wide {} }")
+ "")
+ " }"))))
+ `((#\; ,(space "0.5s" #f ";"))
+ (#\? ,(space "0.5s" #f ";"))
+ (#\! ,(space "0.5s" #f ";")))))
+
+(define lout-french-encoding
+ (let ((punctuation (map car lout-french-punctuation-encoding)))
+ (append (let loop ((ch lout-encoding)
+ (purified '()))
+ (if (null? ch)
+ purified
+ (loop (cdr ch)
+ (if (member (car ch) punctuation)
+ purified
+ (cons (car ch) purified)))))
+ lout-french-punctuation-encoding)))
+
+;*---------------------------------------------------------------------*/
+;* lout-symbol-table ... */
+;*---------------------------------------------------------------------*/
+(define (lout-symbol-table math)
+ `(("iexcl" "{ @Char exclamdown }")
+ ("cent" "{ @Char cent }")
+ ("pound" "{ @Char sterling }")
+ ("yen" "{ @Char yen }")
+ ("section" "{ @Char section }")
+ ("mul" "{ @Char multiply }")
+ ("copyright" "{ @Char copyright }")
+ ("lguillemet" "{ @Char guillemotleft }")
+ ("not" "{ @Char logicalnot }")
+ ("degree" "{ @Char degree }")
+ ("plusminus" "{ @Char plusminus }")
+ ("micro" "{ @Char mu }")
+ ("paragraph" "{ @Char paragraph }")
+ ("middot" "{ @Char periodcentered }")
+ ("rguillemet" "{ @Char guillemotright }")
+ ("1/4" "{ @Char onequarter }")
+ ("1/2" "{ @Char onehalf }")
+ ("3/4" "{ @Char threequarters }")
+ ("iquestion" "{ @Char questiondown }")
+ ("Agrave" "{ @Char Agrave }")
+ ("Aacute" "{ @Char Aacute }")
+ ("Acircumflex" "{ @Char Acircumflex }")
+ ("Atilde" "{ @Char Atilde }")
+ ("Amul" "{ @Char Adieresis }") ;;; FIXME: Why `mul' and not `uml'?!
+ ("Aring" "{ @Char Aring }")
+ ("AEligature" "{ @Char oe }")
+ ("Oeligature" "{ @Char OE }") ;;; FIXME: Should be `OEligature'?!
+ ("Ccedilla" "{ @Char Ccedilla }")
+ ("Egrave" "{ @Char Egrave }")
+ ("Eacute" "{ @Char Eacute }")
+ ("Ecircumflex" "{ @Char Ecircumflex }")
+ ("Euml" "{ @Char Edieresis }")
+ ("Igrave" "{ @Char Igrave }")
+ ("Iacute" "{ @Char Iacute }")
+ ("Icircumflex" "{ @Char Icircumflex }")
+ ("Iuml" "{ @Char Idieresis }")
+ ("ETH" "{ @Char Eth }")
+ ("Ntilde" "{ @Char Ntilde }")
+ ("Ograve" "{ @Char Ograve }")
+ ("Oacute" "{ @Char Oacute }")
+ ("Ocircumflex" "{ @Char Ocircumflex }")
+ ("Otilde" "{ @Char Otilde }")
+ ("Ouml" "{ @Char Odieresis }")
+ ("times" "{ @Sym multiply }")
+ ("Oslash" "{ @Char oslash }")
+ ("Ugrave" "{ @Char Ugrave }")
+ ("Uacute" "{ @Char Uacute }")
+ ("Ucircumflex" "{ @Char Ucircumflex }")
+ ("Uuml" "{ @Char Udieresis }")
+ ("Yacute" "{ @Char Yacute }")
+ ("szlig" "{ @Char germandbls }")
+ ("agrave" "{ @Char agrave }")
+ ("aacute" "{ @Char aacute }")
+ ("acircumflex" "{ @Char acircumflex }")
+ ("atilde" "{ @Char atilde }")
+ ("amul" "{ @Char adieresis }")
+ ("aring" "{ @Char aring }")
+ ("aeligature" "{ @Char ae }")
+ ("oeligature" "{ @Char oe }")
+ ("ccedilla" "{ @Char ccedilla }")
+ ("egrave" "{ @Char egrave }")
+ ("eacute" "{ @Char eacute }")
+ ("ecircumflex" "{ @Char ecircumflex }")
+ ("euml" "{ @Char edieresis }")
+ ("igrave" "{ @Char igrave }")
+ ("iacute" "{ @Char iacute }")
+ ("icircumflex" "{ @Char icircumflex }")
+ ("iuml" "{ @Char idieresis }")
+ ("ntilde" "{ @Char ntilde }")
+ ("ograve" "{ @Char ograve }")
+ ("oacute" "{ @Char oacute }")
+ ("ocurcumflex" "{ @Char ocircumflex }") ;; FIXME: `ocIrcumflex'
+ ("otilde" "{ @Char otilde }")
+ ("ouml" "{ @Char odieresis }")
+ ("divide" "{ @Char divide }")
+ ("oslash" "{ @Char oslash }")
+ ("ugrave" "{ @Char ugrave }")
+ ("uacute" "{ @Char uacute }")
+ ("ucircumflex" "{ @Char ucircumflex }")
+ ("uuml" "{ @Char udieresis }")
+ ("yacute" "{ @Char yacute }")
+ ("ymul" "{ @Char ydieresis }") ;; FIXME: `yUMl'
+ ;; Greek
+ ("Alpha" "{ @Sym Alpha }")
+ ("Beta" "{ @Sym Beta }")
+ ("Gamma" "{ @Sym Gamma }")
+ ("Delta" "{ @Sym Delta }")
+ ("Epsilon" "{ @Sym Epsilon }")
+ ("Zeta" "{ @Sym Zeta }")
+ ("Eta" "{ @Sym Eta }")
+ ("Theta" "{ @Sym Theta }")
+ ("Iota" "{ @Sym Iota }")
+ ("Kappa" "{ @Sym Kappa }")
+ ("Lambda" "{ @Sym Lambda }")
+ ("Mu" "{ @Sym Mu }")
+ ("Nu" "{ @Sym Nu }")
+ ("Xi" "{ @Sym Xi }")
+ ("Omicron" "{ @Sym Omicron }")
+ ("Pi" "{ @Sym Pi }")
+ ("Rho" "{ @Sym Rho }")
+ ("Sigma" "{ @Sym Sigma }")
+ ("Tau" "{ @Sym Tau }")
+ ("Upsilon" "{ @Sym Upsilon }")
+ ("Phi" "{ @Sym Phi }")
+ ("Chi" "{ @Sym Chi }")
+ ("Psi" "{ @Sym Psi }")
+ ("Omega" "{ @Sym Omega }")
+ ("alpha" "{ @Sym alpha }")
+ ("beta" "{ @Sym beta }")
+ ("gamma" "{ @Sym gamma }")
+ ("delta" "{ @Sym delta }")
+ ("epsilon" "{ @Sym epsilon }")
+ ("zeta" "{ @Sym zeta }")
+ ("eta" "{ @Sym eta }")
+ ("theta" "{ @Sym theta }")
+ ("iota" "{ @Sym iota }")
+ ("kappa" "{ @Sym kappa }")
+ ("lambda" "{ @Sym lambda }")
+ ("mu" "{ @Sym mu }")
+ ("nu" "{ @Sym nu }")
+ ("xi" "{ @Sym xi }")
+ ("omicron" "{ @Sym omicron }")
+ ("pi" "{ @Sym pi }")
+ ("rho" "{ @Sym rho }")
+ ("sigmaf" "{ @Sym sigmaf }") ;; FIXME!
+ ("sigma" "{ @Sym sigma }")
+ ("tau" "{ @Sym tau }")
+ ("upsilon" "{ @Sym upsilon }")
+ ("phi" "{ @Sym phi }")
+ ("chi" "{ @Sym chi }")
+ ("psi" "{ @Sym psi }")
+ ("omega" "{ @Sym omega }")
+ ("thetasym" "{ @Sym thetasym }")
+ ("piv" "{ @Sym piv }") ;; FIXME!
+ ;; punctuation
+ ("bullet" "{ @Sym bullet }")
+ ("ellipsis" "{ @Sym ellipsis }")
+ ("weierp" "{ @Sym weierstrass }")
+ ("image" "{ @Sym Ifraktur }")
+ ("real" "{ @Sym Rfraktur }")
+ ("tm" "{ @Sym trademarksans }") ;; alt: @Sym trademarkserif
+ ("alef" "{ @Sym aleph }")
+ ("<-" "{ @Sym arrowleft }")
+ ("<--" "{ { 1.6 1 } @Scale { @Sym arrowleft } }") ;; copied from `eqf'
+ ("uparrow" "{ @Sym arrowup }")
+ ("->" "{ @Sym arrowright }")
+ ("-->" "{ { 1.6 1 } @Scale { @Sym arrowright } }")
+ ("downarrow" "{ @Sym arrowdown }")
+ ("<->" "{ @Sym arrowboth }")
+ ("<-->" "{ { 1.6 1 } @Scale { @Sym arrowboth } }")
+ ("<+" "{ @Sym carriagereturn }")
+ ("<=" "{ @Sym arrowdblleft }")
+ ("<==" "{ { 1.6 1 } @Scale { @Sym arrowdblleft } }")
+ ("Uparrow" "{ @Sym arrowdblup }")
+ ("=>" "{ @Sym arrowdblright }")
+ ("==>" "{ { 1.6 1 } @Scale { @Sym arrowdblright } }")
+ ("Downarrow" "{ @Sym arrowdbldown }")
+ ("<=>" "{ @Sym arrowdblboth }")
+ ("<==>" "{ { 1.6 1 } @Scale { @Sym arrowdblboth } }")
+ ;; Mathematical operators (we try to avoid `@Eq' since it
+ ;; requires to `@SysInclude { eq }' -- one solution consists in copying
+ ;; the symbol definition from `eqf')
+ ("forall" "{ { Symbol Base } @Font \"\\042\" }")
+ ("partial" "{ @Sym partialdiff }")
+ ("exists" "{ { Symbol Base } @Font \"\\044\" }")
+ ("emptyset" "{ { Symbol Base } @Font \"\\306\" }")
+ ("infinity" "{ @Sym infinity }")
+ ("nabla" "{ { Symbol Base } @Font \"\\321\" }")
+ ("in" "{ @Sym element }")
+ ("notin" "{ @Sym notelement }")
+ ("ni" "{ 180d @Rotate @Sym element }")
+ ("prod" "{ @Sym product }")
+ ("sum" "{ @Sym summation }")
+ ("asterisk" "{ @Sym asteriskmath }")
+ ("sqrt" "{ @Sym radical }")
+ ("propto" ,(math "propto"))
+ ("angle" "{ @Sym angle }")
+ ("and" ,(math "bwedge"))
+ ("or" ,(math "bvee"))
+ ("cap" ,(math "bcap"))
+ ("cup" ,(math "bcup"))
+ ("integral" ,(math "int"))
+ ("models" ,(math "models"))
+ ("vdash" ,(math "vdash"))
+ ("dashv" ,(math "dashv"))
+ ("sim" "{ @Sym similar }")
+ ("cong" "{ @Sym congruent }")
+ ("approx" "{ @Sym approxequal }")
+ ("neq" "{ @Sym notequal }")
+ ("equiv" "{ @Sym equivalence }")
+ ("le" "{ @Sym lessequal }")
+ ("ge" "{ @Sym greaterequal }")
+ ("subset" "{ @Sym propersubset }")
+ ("supset" "{ @Sym propersuperset }")
+ ("subseteq" "{ @Sym reflexsubset }")
+ ("supseteq" "{ @Sym reflexsuperset }")
+ ("oplus" "{ @Sym circleplus }")
+ ("otimes" "{ @Sym circlemultiply }")
+ ("perp" "{ @Sym perpendicular }")
+ ("mid" "{ @Sym bar }")
+ ("lceil" "{ @Sym bracketlefttp }")
+ ("rceil" "{ @Sym bracketrighttp }")
+ ("lfloor" "{ @Sym bracketleftbt }")
+ ("rfloor" "{ @Sym bracketrightbt }")
+ ("langle" "{ @Sym angleleft }")
+ ("rangle" "{ @Sym angleright }")
+ ;; Misc
+ ("loz" "{ @Lozenge }")
+ ("spades" "{ @Sym spade }")
+ ("clubs" "{ @Sym club }")
+ ("hearts" "{ @Sym heart }")
+ ("diams" "{ @Sym diamond }")
+ ("euro" "{ @Euro }")
+ ;; Lout
+ ("dag" "{ @Dagger }")
+ ("ddag" "{ @DaggerDbl }")
+ ("circ" ,(math "circle"))
+ ("top" ,(math "top"))
+ ("bottom" ,(math "bot"))
+ ("lhd" ,(math "triangleleft"))
+ ("rhd" ,(math "triangleright"))
+ ("parallel" ,(math "dbar"))))
+
+
+;;; Debugging support
+
+(define *lout-debug?* #f)
+
+(define-macro (lout-debug fmt . args)
+ `(if *lout-debug?*
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (printf (string-append ,fmt "~%") ,@args
+ (current-error-port))))
+ #t))
+
+(define (lout-tagify ident)
+ ;; Return an "clean" identifier (a string) based on `ident' (a string),
+ ;; suitable for Lout as an `@Tag' value.
+ (let ((tag-encoding '((#\, "-")
+ (#\( "-")
+ (#\) "-")
+ (#\[ "-")
+ (#\] "-")
+ (#\/ "-")
+ (#\| "-")
+ (#\& "-")
+ (#\@ "-")
+ (#\! "-")
+ (#\? "-")
+ (#\: "-")
+ (#\; "-")))
+ (tag (string-canonicalize ident)))
+ ((make-string-replace tag-encoding) tag)))
+
+
+;; Default values of various customs (procedures)
+
+(define (lout-definitions engine)
+ ;; Return a string containing a set of useful Lout definitions that should
+ ;; be inserted at the beginning of the output document.
+ (let ((leader (engine-custom engine 'toc-leader))
+ (leader-space (engine-custom engine 'toc-leader-space)))
+ (apply string-append
+ `("# @SkribeMark implements Skribe's marks "
+ "(i.e. cross-references)\n"
+ "def @SkribeMark\n"
+ " right @Tag\n"
+ "{\n"
+ " @PageMark @Tag\n"
+ "}\n\n"
+
+ "# @SkribeLeaders is used in `toc'\n"
+ "# (this is mostly copied from the expert's guide)\n"
+ "def @SkribeLeaders { "
+ ,leader " |" ,leader-space " @SkribeLeaders }\n\n"))))
+
+(define (lout-make-doc-cover-sheet doc engine)
+ ;; Create a cover sheet for node `doc' which is a doc-style Lout document.
+ ;; This is the default implementation, i.e. the default value of the
+ ;; `doc-cover-sheet-proc' custom.
+ (let ((title (markup-option doc :title))
+ (author (markup-option doc :author))
+ (date-line (engine-custom engine 'date-line))
+ (cover-sheet? (engine-custom engine 'cover-sheet?))
+ (multi-column? (> 1 (engine-custom engine 'column-number))))
+ (if multi-column?
+ ;; In single-column document, `@FullWidth' yields a blank page.
+ (display "\n@FullWidth {"))
+ (display "\n//3.0fx\n")
+ (display "\n@Center 1.4f @Font @B { ")
+ (if title
+ (output title engine)
+ (display "The Lout Document"))
+ (display " }\n")
+ (display "//1.7fx\n")
+ (if date-line
+ (begin
+ (display "@Center { ")
+ (output date-line engine)
+ (display " }\n//1.4fx\n")))
+ (if author
+ (begin
+ (display "@Center { ")
+ (output author engine)
+ (display " }\n")
+ (display "//4fx\n")))
+ (if multi-column?
+ (display "\n} # @FullWidth\n"))))
+
+(define (lout-split-external-link markup)
+ ;; Shorten `markup', an URL `url-ref' markup, by splitting it into an URL
+ ;; `ref' followed by plain text. This is useful because Lout's
+ ;; @ExternalLink symbols are unbreakable to the embodied text should _not_
+ ;; be too large (otherwise it is scaled down).
+ (let* ((url (markup-option markup :url))
+ (text (or (markup-option markup :text) url)))
+ (lout-debug "lout-split-external-link: text=~a" text)
+ (cond ((pair? text)
+ ;; no need to go recursive here: we'll get called again later
+ `(,(ref :url url :text (car text)) ,@(cdr text)))
+
+ ((string? text)
+ (let ((len (string-length text)))
+ (if (> (- len 8) 2)
+ ;; don't split on a whitespace or it will vanish
+ (let ((split (let loop ((where 10))
+ (if (= 0 where)
+ 10
+ (if (char=? (string-ref text
+ (- where 1))
+ #\space)
+ (loop (- where 1))
+ where)))))
+ `(,(ref :url url :text (substring text 0 split))
+ ,(substring text split len)))
+ (list markup))))
+
+ ((markup? text)
+ (let ((kind (markup-markup text)))
+ (lout-debug "lout-split-external-link: kind=~a" kind)
+ (if (member kind '(bold it underline))
+ ;; get the ornament markup out of the `:text' argument
+ (list (apply (eval kind (interaction-environment))
+ (list (ref :url url
+ :text (markup-body text)))))
+ ;; otherwise, leave it as is
+ (list markup))))
+
+ (else (list markup)))))
+
+(define (lout-make-toc-entry node engine)
+ ;; Default implementation of the `toc-entry-proc' custom that produces the
+ ;; number and title of `node' for use in the table of contents.
+ (let ((num (markup-option node :number))
+ (title (markup-option node :title))
+ (lang (engine-custom engine 'initial-language)))
+ (if num
+ (begin
+ (if (is-markup? node 'chapter) (display "@B { "))
+ (printf "~a. |2s " (lout-structure-number-string node))
+ (output title engine)
+ (if (is-markup? node 'chapter) (display " }")))
+ (if (is-markup? node 'chapter)
+ (output (bold title) engine)
+ (output title engine)))))
+
+(define (lout-bib-refs-sort/number entry1 entry2)
+ ;; Default implementation of the `bib-refs-sort-proc' custom. Compare
+ ;; bibliography entries `entry1' and `entry2' (of type `&bib-entry') for
+ ;; use by `sort' in `bib-ref+'.
+ (let ((ident1 (markup-option entry1 :title))
+ (ident2 (markup-option entry2 :title)))
+ (if (and (markup? ident1) (markup? ident2))
+ (< (markup-option ident1 'number)
+ (markup-option ident2 'number))
+ (begin
+ (fprint (current-error-port) "i1: " ident1 ", " entry1)
+ (fprint (current-error-port) "i2: " ident2 ", " entry2)))))
+
+(define (lout-pdf-bookmark-title node engine)
+ ;; Default implementation of the `pdf-bookmark-title-proc' custom that
+ ;; returns a title (a string) for the PDF bookmark of `node'.
+ (let ((number (lout-structure-number-string node)))
+ (string-append (if (string=? number "") "" (string-append number ". "))
+ (ast->string (markup-option node :title)))))
+
+(define (lout-pdf-bookmark-node? node engine)
+ ;; Default implementation of the `pdf-bookmark-node-pred' custom that
+ ;; returns a boolean.
+ (or (is-markup? node 'chapter)
+ (is-markup? node 'section)
+ (is-markup? node 'subsection)
+ (is-markup? node 'slide)))
+
+
+
+
+;*---------------------------------------------------------------------*/
+;* lout-engine ... */
+;*---------------------------------------------------------------------*/
+(define lout-engine
+ (default-engine-set!
+ (make-engine 'lout
+ :version 0.2
+ :format "lout"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace lout-encoding)
+ :custom `(;; The underlying Lout document type, i.e. one
+ ;; of `doc', `report', `book' or `slides'.
+ (document-type report)
+
+ ;; Document style file include line (a string
+ ;; such as `@Include { doc-style.lout }') or
+ ;; `auto' (symbol) in which case the include
+ ;; file is deduced from `document-type'.
+ (document-include auto)
+
+ (includes "@SysInclude { tbl }\n")
+ (initial-font "Palatino Base 10p")
+ (initial-break
+ ,(string-append "unbreakablefirst "
+ "unbreakablelast "
+ "hyphen adjust 1.2fx"))
+
+ ;; The document's language, used for hyphenation
+ ;; and other things.
+ (initial-language "English")
+
+ ;; Number of columns.
+ (column-number 1)
+
+ ;; First page number.
+ (first-page-number 1)
+
+ ;; Page orientation, `portrait', `landscape',
+ ;; `reverse-portrait' or `reverse-landscape'.
+ (page-orientation portrait)
+
+ ;; For reports, whether to produce a cover
+ ;; sheet. The `doc-cover-sheet-proc' custom may
+ ;; also honor this custom for `doc' documents.
+ (cover-sheet? #t)
+
+ ;; For reports, the date line.
+ (date-line #t)
+
+ ;; For reports, an abstract.
+ (abstract #f)
+
+ ;; For reports, title/name of the abstract. If
+ ;; `#f', the no abstract title will be
+ ;; produced. If `#t', a default name in the
+ ;; current language is chosen.
+ (abstract-title #t)
+
+ ;; Whether to optimize pages.
+ (optimize-pages? #f)
+
+ ;; For docs, the procedure that produces the
+ ;; Lout code for the cover sheet or title.
+ (doc-cover-sheet-proc
+ ,lout-make-doc-cover-sheet)
+
+ ;; Procedure used to sort bibliography
+ ;; references when several are referred to at
+ ;; the same time, as in:
+ ;; (ref :bib '("smith03" "jones98")) .
+ ;; By default they are sorted by number. If
+ ;; `#f' is given, they are left as is.
+ (bib-refs-sort-proc
+ ,lout-bib-refs-sort/number)
+
+ ;; Lout code for paragraph gaps (similar to
+ ;; `@PP' with `@ParaGap' equal to `1.0vx' by
+ ;; default)
+ (paragraph-gap
+ "\n//1.0vx @ParaIndent @Wide &{0i}\n")
+
+ ;; For multi-page tables, it may be
+ ;; useful to set this to `#t'. However,
+ ;; this looks kind of buggy.
+ (use-header-rows? #f)
+
+ ;; Tells whether to use Skribe's footnote
+ ;; numbers or Lout's numbering scheme (the
+ ;; latter may be better, typography-wise).
+ (use-skribe-footnote-numbers? #t)
+
+ ;; A procedure that is passed the engine
+ ;; and produces Lout definitions.
+ (inline-definitions-proc ,lout-definitions)
+
+ ;; A procedure that takes a URL `ref' markup and
+ ;; returns a list containing (maybe) one such
+ ;; `ref' markup. This custom can be used to
+ ;; modified the way URLs are rendered. The
+ ;; default value is a procedure that limits the
+ ;; size of Lout's @ExternalLink symbols since
+ ;; they are unbreakable. In order to completely
+ ;; disable use of @ExternalLinks, just set it to
+ ;; `markup-body'.
+ (transform-url-ref-proc
+ ,lout-split-external-link)
+
+ ;; Leader used in the table of contents entries.
+ (toc-leader ".")
+
+ ;; Inter-leader spacing in the TOC entries.
+ (toc-leader-space "2.5s")
+
+ ;; Procedure that takes a large-scale structure
+ ;; (chapter, section, etc.) and the engine and
+ ;; produces the number and possibly title of
+ ;; this structure for use the TOC.
+ (toc-entry-proc ,lout-make-toc-entry)
+
+ ;; The Lout program name, only useful when using
+ ;; `lout-illustration' on other back-ends.
+ (lout-program-name "lout")
+
+ ;; Title and author information in the PDF
+ ;; document information. If `#t', the
+ ;; document's `:title' and `:author' are used.
+ (pdf-title #t)
+ (pdf-author #t)
+
+ ;; Keywords (a list of string) in the PDF
+ ;; document information.
+ (pdf-keywords #f)
+
+ ;; Extra PDF information, an alist of key-value
+ ;; pairs (string pairs).
+ (pdf-extra-info (("SkribeVersion"
+ ,(skribe-release))))
+
+ ;; Tells whether to produce PDF "docinfo"
+ ;; (meta-information with title, author,
+ ;; keywords, etc.).
+ (make-pdf-docinfo? #t)
+
+ ;; Tells whether a PDF outline
+ ;; (aka. "bookmarks") should be produced.
+ (make-pdf-outline? #t)
+
+ ;; Procedure that takes a node and an engine and
+ ;; return a string representing the title of
+ ;; that node's PDF bookmark.
+ (pdf-bookmark-title-proc ,lout-pdf-bookmark-title)
+
+ ;; Procedure that takes a node and an engine and
+ ;; returns true if that node should have a PDF
+ ;; outline entry.
+ (pdf-bookmark-node-pred ,lout-pdf-bookmark-node?)
+
+ ;; Procedure that takes a node and an engine and
+ ;; returns true if the bookmark for that node
+ ;; should be closed ("folded") when the user
+ ;; opens the PDF document.
+ (pdf-bookmark-closed-pred
+ ,(lambda (n e)
+ (not (is-markup? n 'chapter))))
+
+ ;; color
+ (color? #t)
+
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00"))
+
+ :symbol-table (lout-symbol-table
+ (lambda (m)
+ (format #f "@Eq { ~a }\n" m))))))
+
+
+
+;; User-level implementation of PDF bookmarks.
+;;
+;; Basically, Lout code is produced that produces (via `@Graphic') PostScript
+;; code. That PostScript code is a `pdfmark' command (see Adobe's "pdfmark
+;; Reference Manual") which, when converted to PDF (e.g. with `ps2pdf'),
+;; produces a PDF outline, aka. "bookmarks" (see "PDF Reference, Fifth
+;; Edition", section 8.2.2).
+
+(define (lout-internal-dest-name ident)
+ ;; Return the Lout-generated `pdfmark' named destination for `ident'. This
+ ;; function mimics Lout's `ConvertToPDFName ()', in `z49.c' (Lout's
+ ;; PostScript back-end). In Lout, `ConvertToPDFName ()' produces
+ ;; destination names for the `/Dest' function of the `pdfmark' operator.
+ ;; This implementation is valid as of Lout 3.31 and hopefully it won't
+ ;; change in the future.
+ (string-append "LOUT"
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list ident)))))
+
+(define (lout-pdf-bookmark node children closed? engine)
+ ;; Return the PostScript `pdfmark' operation (a string) that creates a PDF
+ ;; bookmark for node `node'. `children' is the number of children of
+ ;; `node' in the PDF outline. If `closed?' is true, then the bookmark will
+ ;; be close (i.e. its children are hidden).
+ ;;
+ ;; Note: Here, we use a `GoTo' action, while we could instead simply
+ ;; produce a `/Page' attribute without having to use the
+ ;; `lout-internal-dest-name' hack. The point for doing this is that Lout's
+ ;; `@PageOf' operator doesn't return an "actual" page number within the
+ ;; document, but rather a "typographically correct" page number (e.g. `i'
+ ;; for the cover sheet, `1' for the second page, etc.). See
+ ;; http://lists.planix.com/pipermail/lout-users/2005q1/003925.html for
+ ;; details.
+ (let* ((filter-title (make-string-replace `(,@lout-verbatim-encoding
+ (#\newline " "))))
+ (make-bookmark-title (lambda (n e)
+ (filter-title
+ ((engine-custom
+ engine 'pdf-bookmark-title-proc)
+ n e))))
+ (ident (markup-ident node)))
+ (string-append "["
+ (if (= 0 children)
+ ""
+ (string-append "\"/\"Count "
+ (if closed? "-" "")
+ (number->string children) " "))
+ "\"/\"Title \"(\"" (make-bookmark-title node engine)
+ "\")\" "
+ (if (not ident) ""
+ (string-append "\"/\"Action \"/\"GoTo \"/\"Dest \"/\""
+ (lout-internal-dest-name ident) " "))
+ "\"/\"OUT pdfmark\n")))
+
+(define (lout-pdf-outline node engine . children)
+ ;; Return the PDF outline string (in the form of a PostScript `pdfmark'
+ ;; command) for `node' whose child nodes are assumed to be `children',
+ ;; unless `node' is a document.
+ (let* ((choose-node? (lambda (n)
+ ((engine-custom engine 'pdf-bookmark-node-pred)
+ n engine)))
+ (nodes (if (document? node)
+ (filter choose-node? (markup-body node))
+ children)))
+ (apply string-append
+ (map (lambda (node)
+ (let* ((children (filter choose-node? (markup-body node)))
+ (closed? ((engine-custom engine
+ 'pdf-bookmark-closed-pred)
+ node engine))
+ (bm (lout-pdf-bookmark node (length children)
+ closed? engine)))
+ (string-append bm (apply lout-pdf-outline
+ `(,node ,engine ,@children)))))
+ nodes))))
+
+(define (lout-embedded-postscript-code postscript)
+ ;; Return a string embedding PostScript code `postscript' into Lout code.
+ (string-append "\n"
+ "{ @BackEnd @Case {\n"
+ " PostScript @Yield {\n"
+ postscript
+ " }\n"
+ "} } @Graphic { }\n"))
+
+(define (lout-pdf-docinfo doc engine)
+ ;; Produce PostScript code that will produce PDF document information once
+ ;; converted to PDF.
+ (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding
+ (#\newline " "))))
+ (docinfo-field (lambda (key value)
+ (string-append "\"/\"" key " \"(\""
+ (filter-string value)
+ "\")\"\n")))
+ (author (let ((a (engine-custom engine 'pdf-author)))
+ (if (or (string? a) (ast? a))
+ a
+ (markup-option doc :author))))
+ (title (let ((t (engine-custom engine 'pdf-title)))
+ (if (or (string? t) (ast? t))
+ t
+ (markup-option doc :title))))
+ (keywords (engine-custom engine 'pdf-keywords))
+ (extra-fields (engine-custom engine 'pdf-extra-info))
+ (stringify-kw (lambda (kws)
+ (let loop ((kws kws) (s ""))
+ (if (null? kws) s
+ (loop (cdr kws)
+ (string-append s (car kws)
+ (if (pair? (cdr kws))
+ ", " ""))))))))
+ (string-append "[ "
+ (if title
+ (docinfo-field "Title" (ast->string title))
+ "")
+ (if author
+ (docinfo-field "Author"
+ (or (cond ((markup? author)
+ (ast->string
+ (or (markup-option
+ author :name)
+ (markup-option
+ author :affiliation))))
+ ((string? author) author)
+ (else (ast->string author)))
+ ""))
+ "")
+ (if keywords
+ (docinfo-field "Keywords"
+ (cond ((string? keywords)
+ keywords)
+ ((pair? keywords)
+ (stringify-kw keywords))
+ (else "")))
+ "")
+ ;; arbitrary key-value pairs, see sect. 4.7, "Info
+ ;; dictionary" of the `pdfmark' reference.
+ (if (or (not extra-fields) (null? extra-fields))
+ ""
+ (apply string-append
+ (map (lambda (p)
+ (docinfo-field (car p) (cadr p)))
+ extra-fields)))
+ "\"/\"DOCINFO pdfmark\n")))
+
+(define (lout-output-pdf-meta-info doc engine)
+ ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as
+ ;; document meta-information (or "docinfo"). This function makes sure that
+ ;; both are only produced once, and only if the relevant customs ask for
+ ;; them.
+ (if (and doc (engine-custom engine 'make-pdf-outline?)
+ (not (markup-option doc '&pdf-outline-produced?)))
+ (begin
+ (display
+ (lout-embedded-postscript-code (lout-pdf-outline doc engine)))
+ (markup-option-add! doc '&pdf-outline-produced? #t)))
+ (if (and doc (engine-custom engine 'make-pdf-docinfo?)
+ (not (markup-option doc '&pdf-docinfo-produced?)))
+ (begin
+ (display
+ (lout-embedded-postscript-code (lout-pdf-docinfo doc engine)))
+ (markup-option-add! doc '&pdf-docinfo-produced? #t))))
+
+
+
+;*---------------------------------------------------------------------*/
+;* lout ... */
+;*---------------------------------------------------------------------*/
+(define-markup (!lout fmt #!rest opt)
+ (if (engine-format? "lout")
+ (apply ! fmt opt)
+ #f))
+
+;*---------------------------------------------------------------------*/
+;* lout-width ... */
+;*---------------------------------------------------------------------*/
+(define (lout-width width)
+ (cond ((flonum? width) ;; a relative size
+ ;; FIXME: Hack ahead: assuming A4 with a 2.5cm margin
+ ;; on both sides
+ (let* ((orientation (let ((lout (find-engine 'lout)))
+ (or (and lout
+ (engine-custom lout
+ 'page-orientation))
+ 'portrait)))
+ (margins 5)
+ (paper-width (case orientation
+ ((portrait reverse-portrait)
+ (- 21 margins))
+ (else (- 29.7 margins)))))
+ (string-append (number->string (* paper-width
+ (/ (abs width) 100.)))
+ "c")))
+ ((string? width) ;; an engine-dependent width
+ width)
+ (else ;; an absolute "pixel" size
+ (string-append (number->string width) "p"))))
+
+;*---------------------------------------------------------------------*/
+;* lout-font-size ... */
+;*---------------------------------------------------------------------*/
+(define (lout-font-size size)
+ (case size
+ ((4) "3.5f")
+ ((3) "2.0f")
+ ((2) "1.5f")
+ ((1) "1.2f")
+ ((0) "1.0f")
+ ((-1) "0.8f")
+ ((-2) "0.5f")
+ ((-3) "0.3f")
+ ((-4) "0.2f")
+ (else (if (number? size)
+ (if (< size 0) "0.3f" "1.5f")
+ "1.0f"))))
+
+(define (lout-color-specification skribe-color)
+ ;; Return a Lout color name, ie. a string which is either an English color
+ ;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string
+ ;; representing a Skribe color such as "black" or "#ffffff".
+ (let ((b&w? (let ((lout (find-engine 'lout)))
+ (and lout (not (engine-custom lout 'color?)))))
+ (actual-color
+ (if (and (string? skribe-color)
+ (char=? (string-ref skribe-color 0) #\#))
+ (string->number (substring skribe-color 1
+ (string-length skribe-color))
+ 16)
+ skribe-color)))
+ (receive (r g b)
+ (skribe-color->rgb actual-color)
+ (apply format #f
+ (cons "rgb ~a ~a ~a"
+ (map (if b&w?
+ (let ((avg (exact->inexact (/ (+ r g b)
+ (* 256 3)))))
+ (lambda (x) avg))
+ (lambda (x)
+ (exact->inexact (/ x 256))))
+ (list r g b)))))))
+
+;*---------------------------------------------------------------------*/
+;* &~ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&~ :before "~" :action #f)
+
+(define (lout-page-orientation orientation)
+ ;; Return a string representing the Lout page orientation name for symbol
+ ;; `orientation'.
+ (let* ((alist '((portrait . "Portrait")
+ (landscape . "Landscape")
+ (reverse-portrait . "ReversePortrait")
+ (reverse-landscape . "ReverseLandscape")))
+ (which (assoc orientation alist)))
+ (if (not which)
+ (skribe-error 'lout
+ "`page-orientation' should be either `portrait' or `landscape'"
+ orientation)
+ (cdr which))))
+
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :env)
+ :before (lambda (n e) ;; `e' is the engine
+ (let* ((doc-type (let ((d (engine-custom e 'document-type)))
+ (if (string? d)
+ (begin
+ (engine-custom-set! e 'document-type
+ (string->symbol d))
+ (string->symbol d))
+ d)))
+ (doc-style? (eq? doc-type 'doc))
+ (slides? (eq? doc-type 'slides))
+ (doc-include (engine-custom e 'document-include))
+ (includes (engine-custom e 'includes))
+ (font (engine-custom e 'initial-font))
+ (lang (engine-custom e 'initial-language))
+ (break (engine-custom e 'initial-break))
+ (column-number (engine-custom e 'column-number))
+ (first-page-number (engine-custom e 'first-page-number))
+ (page-orientation (engine-custom e 'page-orientation))
+ (title (markup-option n :title)))
+
+ ;; Add this markup option, used by
+ ;; `lout-start-large-scale-structure' et al.
+ (markup-option-add! n '&substructs-started? #f)
+
+ (if (eq? doc-include 'auto)
+ (case doc-type
+ ((report) (display "@SysInclude { report }\n"))
+ ((book) (display "@SysInclude { book }\n"))
+ ((doc) (display "@SysInclude { doc }\n"))
+ ((slides) (display "@SysInclude { slides }\n"))
+ (else (skribe-error
+ 'lout
+ "`document-type' should be one of `book', `report' or `doc'"
+ doc-type)))
+ (printf "# Custom document includes\n~a\n" doc-include))
+
+ (if includes
+ (printf "# Additional user includes\n~a\n" includes)
+ (display "@SysInclude { tbl }\n"))
+
+ ;; Write additional Lout definitions
+ (display (lout-definitions e))
+
+ (case doc-type
+ ((report) (display "@Report\n"))
+ ((book) (display "@Book\n"))
+ ((doc) (display "@Document\n"))
+ ((slides) (display "@OverheadTransparencies\n")))
+
+ (display (string-append " @InitialSpace { tex } "
+ "# avoid having too many spaces\n"))
+
+ ;; The `doc' style doesn't have @Title, @Author and the likes
+ (if (not doc-style?)
+ (begin
+ (display " @Title { ")
+ (if title
+ (output title e)
+ (display "The Lout-Skribe Book"))
+ (display " }\n")
+
+ ;; The author
+ (let* ((author (markup-option n :author)))
+
+ (display " @Author { ")
+ (output author e)
+ (display " }\n")
+
+ ;; Lout reports support `@Institution' while books
+ ;; don't.
+ (if (and (eq? doc-type 'report)
+ (is-markup? author 'author))
+ (let ((institution (markup-option author
+ :affiliation)))
+ (if institution
+ (begin
+ (printf " @Institution { ")
+ (output institution e)
+ (printf " }\n"))))))))
+
+ ;; Lout reports make it possible to choose whether to prepend
+ ;; a cover sheet (books and docs don't). Same for a date
+ ;; line.
+ (if (eq? doc-type 'report)
+ (let ((cover-sheet? (engine-custom e 'cover-sheet?))
+ (date-line (engine-custom e 'date-line))
+ (abstract (engine-custom e 'abstract))
+ (abstract-title (engine-custom e 'abstract-title)))
+ (display (string-append " @CoverSheet { "
+ (if cover-sheet?
+ "Yes" "No")
+ " }\n"))
+ (display " @DateLine { ")
+ (if (string? date-line)
+ (output date-line e)
+ (display (if date-line "Yes" "No")))
+ (display " }\n")
+
+ (if abstract
+ (begin
+ (if (not (eq? abstract-title #t))
+ (begin
+ (display " @AbstractTitle { ")
+ (cond
+ ((not abstract-title) #t)
+ (else (output abstract-title e)))
+ (display " }\n")))
+
+ (display " @Abstract {\n")
+ (output abstract e)
+ (display "\n}\n")))))
+
+ (printf " @OptimizePages { ~a }\n"
+ (if (engine-custom e 'optimize-pages?)
+ "Yes" "No"))
+
+ (printf " @InitialFont { ~a }\n"
+ (cond ((string? font) font)
+ ((symbol? font)
+ (string-append (symbol->string font)
+ " Base 10p"))
+ ((number? font)
+ (string-append "Palatino Base "
+ (number->string font)
+ "p"))
+ (#t
+ (skribe-error
+ 'lout 'initial-font
+ "Should be a Lout font name, a symbol, or a number"))))
+ (printf " @InitialBreak { ~a }\n"
+ (if break break "adjust 1.2fx hyphen"))
+ (if (not slides?)
+ (printf " @ColumnNumber { ~a }\n"
+ (if (number? column-number)
+ column-number 1)))
+ (printf " @FirstPageNumber { ~a }\n"
+ (if (number? first-page-number)
+ first-page-number 1))
+ (printf " @PageOrientation { ~a }\n"
+ (lout-page-orientation page-orientation))
+ (printf " @InitialLanguage { ~a }\n"
+ (if lang lang "English"))
+
+ ;; FIXME: Insert a preface for text preceding the first ch.
+ ;; FIXME: Create an @Introduction for the first chapter
+ ;; if its title is "Introduction" (for books).
+
+ (display "//\n\n")
+
+ (if doc-style?
+ ;; `doc' documents don't have @Title and the likes so
+ ;; we need to implement them "by hand"
+ (let ((make-cover-sheet
+ (engine-custom e 'doc-cover-sheet-proc)))
+ (display "@Text @Begin\n")
+ (if make-cover-sheet
+ (make-cover-sheet n e)
+ (lout-make-doc-cover-sheet n e))))
+
+ (if doc-style?
+ ;; Putting it here will only works with `doc' documents.
+ (lout-output-pdf-meta-info n e))))
+
+ :after (lambda (n e)
+ (let ((doc-type (engine-custom e 'document-type)))
+ (if (eq? doc-type 'doc)
+ (begin
+ (if (markup-option n '&substructs-started?)
+ (display "\n@EndSections\n"))
+ (display "\n@End @Text\n")))
+ (display "\n\n# Lout document ends here.\n"))))
+
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address
+ :phone :photo :align)
+
+ :action (lambda (n e)
+ (let ((doc-type (engine-custom e 'document-type))
+ (name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (photo (markup-option n :photo)))
+
+ (define (row x)
+ (display "\n//1.5fx\n@Center { ")
+ (output x e)
+ (display " }\n"))
+
+ (if email
+ (row (list (if name name "")
+ (! " <@I{")
+ (cond ((string? email) email)
+ ((markup? email)
+ (markup-body email))
+ (#t ""))
+ (! "}> ")))
+ (if name (row name)))
+
+ (if title (row title))
+
+ ;; In reports, the affiliation is passed to `@Institution'.
+ ;; However, books do not have an `@Institution' parameter.
+ (if (and affiliation (not (eq? doc-type 'report)))
+ (row affiliation))
+
+ (if address (row address))
+ (if phone (row phone))
+ (if url (row (it url)))
+ (if photo (row photo)))))
+
+
+(define (lout-toc-entry node depth engine)
+ ;; Produce a TOC entry of depth `depth' (a integer greater than or equal to
+ ;; zero) for `node' using engine `engine'. The Lout code here is mostly
+ ;; copied from Lout's `dsf' (see definition of `@Item').
+ (let ((ident (markup-ident node))
+ (entry-proc (engine-custom engine 'toc-entry-proc)))
+ (if (markup-option node :toc)
+ (begin
+ (display "@LP\n")
+ (if ident
+ ;; create an internal for PDF navigation
+ (printf "{ ~a } @LinkSource { " (lout-tagify ident)))
+
+ (if (> depth 0)
+ (printf "|~as " (number->string (* 6 depth))))
+ (display " @HExpand { ")
+
+ ;; output the number and title of this node
+ (entry-proc node engine)
+
+ (display " &1rt @OneCol { ")
+ (printf " @SkribeLeaders & @PageOf { ~a }"
+ (lout-tagify (markup-ident node)))
+ (display " &0io } }")
+
+ (if ident (display " }"))
+ (display "\n")))))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options '(:class :chapter :section :subsection)
+ :action (lambda (n e)
+ (display "\n# toc\n")
+ (if (markup-option n :chapter)
+ (let ((chapters (filter (lambda (n)
+ (or (is-markup? n 'chapter)
+ (is-markup? n 'slide)))
+ (markup-body (ast-document n)))))
+ (for-each (lambda (c)
+ (let ((sections
+ (search-down (lambda (n)
+ (is-markup? n 'section))
+ c)))
+ (lout-toc-entry c 0 e)
+ (if (markup-option n :section)
+ (for-each
+ (lambda (s)
+ (lout-toc-entry s 1 e)
+ (if (markup-option n :subsection)
+ (let ((subs
+ (search-down
+ (lambda (n)
+ (is-markup?
+ n 'subsection))
+ s)))
+ (for-each
+ (lambda (s)
+ (lout-toc-entry s 2 e))
+ subs))))
+ sections))))
+ chapters)))))
+
+(define lout-book-markup-alist
+ '((chapter . "Chapter")
+ (section . "Section")
+ (subsection . "SubSection")
+ (subsubsection . "SubSubSection")))
+
+(define lout-report-markup-alist
+ '((chapter . "Section")
+ (section . "SubSection")
+ (subsection . "SubSubSection")
+ (subsubsection . #f)))
+
+(define lout-doc-markup-alist lout-report-markup-alist)
+
+(define (lout-structure-markup skribe-markup engine)
+ ;; Return the Lout structure name for `skribe-markup' (eg. "Chapter" for
+ ;; `chapter' markups when `engine''s document type is `book').
+ (let ((doc-type (engine-custom engine 'document-type))
+ (assoc-ref (lambda (alist key)
+ (and-let* ((as (assoc key alist))) (cdr as)))))
+ (case doc-type
+ ((book) (assoc-ref lout-book-markup-alist skribe-markup))
+ ((report) (assoc-ref lout-report-markup-alist skribe-markup))
+ ((doc) (assoc-ref lout-doc-markup-alist skribe-markup))
+ (else
+ (skribe-error 'lout
+ "`document-type' should be one of `book', `report' or `doc'"
+ doc-type)))))
+
+(define (lout-structure-number-string markup)
+ ;; Return a structure number string such as "1.2".
+ (let loop ((struct markup))
+ (if (document? struct)
+ ""
+ (let ((parent-num (loop (ast-parent struct)))
+ (num (markup-option struct :number)))
+ (string-append parent-num
+ (if (string=? "" parent-num) "" ".")
+ (if (number? num) (number->string num) ""))))))
+
+;*---------------------------------------------------------------------*/
+;* lout-block-before ... */
+;*---------------------------------------------------------------------*/
+(define (lout-block-before n e)
+ ;; Produce the Lout code that introduces node `n', a large-scale
+ ;; structure (chapter, section, etc.).
+ (let ((lout-markup (lout-structure-markup (markup-markup n) e))
+ (title (markup-option n :title))
+ (number (markup-option n :number))
+ (ident (markup-ident n)))
+
+ (if (not lout-markup)
+ (begin
+ ;; the fallback method (i.e. when there exists no equivalent
+ ;; Lout markup)
+ (display "\n//1.8vx\n@B { ")
+ (output title e)
+ (display " }\n@SkribeMark { ")
+ (display (lout-tagify ident))
+ (display " }\n//0.8vx\n\n"))
+ (begin
+ (printf "\n@~a\n @Title { " lout-markup)
+ (output title e)
+ (printf " }\n")
+
+ (if (number? number)
+ (printf " @BypassNumber { ~a }\n"
+ (lout-structure-number-string n))
+ (if (not number)
+ ;; this trick hides the section number
+ (printf " @BypassNumber { } # unnumbered\n")))
+
+ (cond ((string? ident)
+ (begin
+ (display " @Tag { ")
+ (display (lout-tagify ident))
+ (display " }\n")))
+ ((symbol? ident)
+ (begin
+ (display " @Tag { ")
+ (display (lout-tagify (symbol->string ident)))
+ (display " }\n")))
+ (#t
+ (skribe-error 'lout
+ "Node identifiers should be strings"
+ ident)))
+
+ (display "\n@Begin\n")))))
+
+(define (lout-block-after n e)
+ ;; Produce the Lout code that terminates node `n', a large-scale
+ ;; structure (chapter, section, etc.).
+ (let ((lout-markup (lout-structure-markup (markup-markup n) e)))
+ (if (not lout-markup)
+ (printf "\n\n//0.3vx\n\n") ;; fallback method
+ (printf "\n\n@End @~a\n\n" lout-markup))))
+
+
+(define (markup-option-set! m opt val)
+ ;; Sets the value of markup option `opt' of markup `m' to `val'.
+ (let ((o (assoc opt (markup-options m))))
+ (if o
+ (begin
+; (set-cdr! o val)
+ (markup-option-add! m opt val) ;; FIXME: the above method fails
+ (if (not (eq? (markup-option m opt) val))
+ (skribe-error 'markup-option-set!
+ "Doesn't work!" (markup-option m opt))))
+ (begin
+ (lout-debug "markup-option-set!: markup ~a doesn't have option ~a"
+ m opt)
+ #f))))
+
+(define (lout-markup-child-type skribe-markup)
+ ;; Return the child markup type of `skribe-markup' (e.g. for `chapter',
+ ;; return `section').
+ (let loop ((structs '(document chapter section subsection subsubsection)))
+ (if (null? structs)
+ #f
+ (if (eq? (car structs) skribe-markup)
+ (cadr structs)
+ (loop (cdr structs))))))
+
+(define (lout-start-large-scale-structure markup engine)
+ ;; Perform the necessary step and produce output as a result of starting
+ ;; large-scale structure `markup' (ie. a chapter, section, subsection,
+ ;; etc.).
+ (let* ((doc-type (engine-custom engine 'document-type))
+ (doc-style? (eq? doc-type 'doc))
+ (parent (ast-parent markup))
+ (markup-type (markup-markup markup))
+ (lout-markup-name (lout-structure-markup markup-type
+ engine)))
+ (lout-debug "start-struct: markup=~a parent=~a"
+ markup parent)
+
+ ;; add an `&substructs-started?' option to the markup
+ (markup-option-add! markup '&substructs-started? #f)
+
+ (if (and lout-markup-name
+ parent (or doc-style? (not (document? parent))))
+ (begin
+ (if (not (markup-option parent '&substructs-started?))
+ ;; produce an `@BeginSubSections' or equivalent; `doc'-style
+ ;; documents need to preprend an `@BeginSections' before the
+ ;; first section while other styles don't.
+ (printf "\n@Begin~as\n" lout-markup-name))
+
+ ;; update the `&substructs-started?' option of the parent
+ (markup-option-set! parent '&substructs-started? #t)
+ (lout-debug "start-struct: updated parent: ~a"
+ (markup-option parent '&substructs-started?))))
+
+ ;; output the `@Section @Title { ... } @Begin' thing
+ (lout-block-before markup engine)))
+
+(define (lout-end-large-scale-structure markup engine)
+ ;; Produce Lout code for ending structure `markup' (a chapter, section,
+ ;; subsection, etc.).
+ (let* ((doc-type (engine-custom engine 'document-type))
+ (doc-style? (eq? doc-type 'doc))
+ (markup-type (markup-markup markup))
+ (lout-markup-name (lout-structure-markup markup-type
+ engine)))
+
+ (if (and lout-markup-name
+ (markup-option markup '&substructs-started?)
+ (or doc-style? (not (document? markup))))
+ (begin
+ ;; produce an `@EndSubSections' or equivalent; `doc'-style
+ ;; documents need to issue an `@EndSections' after the last section
+ ;; while other types of documents don't.
+ (lout-debug "end-struct: closing substructs for ~a" markup)
+ (printf "\n@End~as\n"
+ (lout-structure-markup (lout-markup-child-type markup-type)
+ engine))
+ (markup-option-set! markup '&substructs-started? #f)))
+
+ (lout-block-after markup engine)))
+
+
+;*---------------------------------------------------------------------*/
+;* section ... .. @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (document? (ast-parent n)))
+
+ :before (lambda (n e)
+ (lout-start-large-scale-structure n e)
+
+ ;; `doc' documents produce their PDF outline right after
+ ;; `@Text @Begin'; other types of documents must produce it
+ ;; as part of their first chapter.
+ (lout-output-pdf-meta-info (ast-document n) e))
+
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* section ... . @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'chapter))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'section))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'subsection))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :options '()
+ :validate (lambda (n e)
+ (or (eq? 'doc (engine-custom e 'document-type))
+ (memq (and (markup? (ast-parent n))
+ (markup-markup (ast-parent n)))
+ '(chapter section subsection subsubsection slide))))
+ :before (lambda (n e)
+ (let ((gap (engine-custom e 'paragraph-gap)))
+ (display (if (string? gap) gap "\n@PP\n")))))
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :options '(:number)
+ :before (lambda (n e)
+ (let ((number (markup-option n :number))
+ (use-number?
+ (engine-custom e 'use-skribe-footnote-numbers?)))
+ (if use-number?
+ (printf "{ @FootNote @Label { ~a } { "
+ (if number number ""))
+ (printf "{ @FootNote ~a{ "
+ (if (not number) "@Label { } " "")))))
+ :after (lambda (n e)
+ (display " } }")))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :action (lambda (n e)
+ (display "\n@LP\n")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '()
+ :action "\n@LP\n@FullWidthRule\n@LP\n")
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:fg :bg :width)
+ ;; FIXME: `:bg' not supported
+ ;; FIXME: `:width' is not supported either. Rather use `frame' for that
+ ;; kind of options.
+ :before (lambda (n e)
+ (let* ((w (markup-option n :width))
+ (fg (markup-option n :fg)))
+ (printf "{ ~a } @Color { " (lout-color-specification fg))))
+
+ :after (lambda (n e)
+ (display " }")))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ ;; @Box won't span over several pages so this may cause
+ ;; problems if large frames are used. The workaround here consists
+ ;; in using an @Tbl with one single cell.
+ :options '(:width :border :margin :bg)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (margin (markup-option n :margin))
+ (border (markup-option n :border))
+ (bg (markup-option n :bg)))
+
+ ;; The user manual seems to expect `frame' to imply a
+ ;; linebreak. However, the LaTeX engine doesn't seem to
+ ;; agree.
+ ;(display "\n@LP")
+ (printf (string-append "\n@Tbl # frame\n"
+ " rule { yes }\n"))
+ (if border (printf " rulewidth { ~a }\n"
+ (lout-width border)))
+ (if width (printf " width { ~a }\n"
+ (lout-width width)))
+ (if margin (printf " margin { ~a }\n"
+ (lout-width margin)))
+ (if bg (printf " paint { ~a }\n"
+ (lout-color-specification bg)))
+ (display "{ @Row format { @Cell A } A { "))
+
+; (printf "\n@Box linewidth { ~a } margin { ~a } { "
+; (lout-width (markup-option n :width))
+; (lout-width (markup-option n :margin)))
+ )
+ :after (lambda (n e)
+ (display " } }\n")))
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((face (markup-option n :face))
+ (size (lout-font-size (markup-option n :size))))
+ (printf "\n~a @Font { " size)))
+ :after (lambda (n e)
+ (display " }\n")))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (display "\n@LP")
+ (case (markup-option n :side)
+ ((center)
+ (display "\n@Center { # flush-center\n"))
+ ((left)
+ (display "\n# flush-left\n"))
+ ((right)
+ (display (string-append "\n@Right "
+ "{ rragged hyphen } @Break "
+ "{ # flush-right\n")))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((left)
+ (display ""))
+ (else
+ (display "\n}")))
+ (display " # flush\n")))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ ;; Note: We prepend and append a newline in order to make sure
+ ;; things work as expected.
+ :before "\n@LP\n@Center {"
+ :after "}\n@LP\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre
+ :before "\n@LP lines @Break lout @Space { # pre\n"
+ :after "\n} # pre\n")
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before "\nlines @Break lout @Space {\n"
+ :after "\n} # @Break\n")
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+;; Program lines appear within a `lines @Break' block.
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before (lambda (n e)
+ (let ((symbol (markup-option n :symbol)))
+ (if symbol
+ (begin
+ (display "\n@List style { ")
+ (output symbol e)
+ (display " } # itemize\n"))
+ (display "\n@BulletList # itemize\n"))))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before (lambda (n e)
+ (let ((symbol (markup-option n :symbol)))
+ (if symbol
+ (printf "\n@List style { ~a } # enumerate\n"
+ symbol)
+ (display "\n@NumberedList # enumerate\n"))))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol) ;; `symbol' doesn't make sense here
+ :before "\n@TaggedList # description\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (display "@DropTagItem { ")
+ (for-each (lambda (i)
+ (output i e)
+ (display " "))
+ (if (pair? k) k (list k)))
+ (display " } { ")
+ (output (markup-body item) e)
+ (display " }\n")))
+ (markup-body n)))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :before "\n@LI { "
+ :after " }")
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :before "\n@ID {"
+ :after "\n} # @ID\n")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend))
+ (mc? (markup-option n :multicolumns)))
+ (display "\n@Figure\n")
+ (display " @Tag { ")
+ (display (lout-tagify ident))
+ (display " }\n")
+ (printf " @BypassNumber { ~a }\n" number)
+ (display " @InitialLanguage { ")
+ (display (engine-custom e 'initial-language))
+ (display " }\n")
+
+ (if legend
+ (begin
+ (lout-debug "figure: ~a, \"~a\"" ident legend)
+ (printf " @Caption { ")
+ (output legend e)
+ (printf " }\n")))
+ (printf " @Location { ~a }\n"
+ (if mc? "PageTop" "ColTop"))
+ (printf "{\n")
+ (output (markup-body n) e)))
+ :after (lambda (n e)
+ (display "}\n")))
+
+
+;*---------------------------------------------------------------------*/
+;* lout-table-column-number ... */
+;* ------------------------------------------------------------- */
+;* This function computes how columns are contained by the table. */
+;*---------------------------------------------------------------------*/
+(define (lout-table-column-number t)
+ (define (row-columns row)
+ (let loop ((cells (markup-body row))
+ (nbcols 0))
+ (if (null? cells)
+ nbcols
+ (loop (cdr cells)
+ (+ nbcols (markup-option (car cells) :colspan))))))
+ (let loop ((rows (markup-body t))
+ (nbcols 0))
+ (if (null? rows)
+ nbcols
+ (loop (cdr rows)
+ (max (row-columns (car rows)) nbcols)))))
+
+(define (lout-table-cell-indent align)
+ ;; Return the Lout name (a string) for cell alignment `align' (a symbol).
+ (case align
+ ((center #f #t) "ctr")
+ ((right) "right")
+ ((left) "left")
+ (else (skribe-error 'td align
+ "Unknown alignment type"))))
+
+(define (lout-table-cell-vindent align)
+ ;; Return the Lout name (a string) for cell alignment `align' (a symbol).
+ (case align
+ ((center #f #t) "ctr")
+ ((top) "top")
+ ((bottom) "foot")
+ (else (skribe-error 'td align
+ "Unknown alignment type"))))
+
+(define (lout-table-cell-vspan cell-letter row-vspan)
+ ;; Return the vspan information (an alist) for the cell whose
+ ;; letter is `cell-letter', within the row whose vspan information
+ ;; is given by `row-vspan'. If the given cell doesn't span over
+ ;; rows, then #f is returned.
+ (and-let* ((as (assoc cell-letter row-vspan)))
+ (cdr as)))
+
+(define (lout-table-cell-vspan-start? vspan-alist)
+ ;; For the cell whose vspan information is given by `vspan-alist',
+ ;; return #t if that cell starts spanning vertically.
+ (and vspan-alist
+ (cdr (assoc 'start? vspan-alist))))
+
+(define-macro (char+int c i)
+ `(integer->char (+ ,i (char->integer ,c))))
+
+(define-macro (-- i)
+ `(- ,i 1))
+
+
+(define (lout-table-cell-option-string cell)
+ ;; Return the Lout cell option string for `cell'.
+ (let ((align (markup-option cell :align))
+ (valign (markup-option cell :valign))
+ (width (markup-option cell :width))
+ (bg (markup-option cell :bg)))
+ (string-append (lout-table-cell-rules cell) " "
+ (string-append
+ "indent { "
+ (lout-table-cell-indent align)
+ " } ")
+ (string-append
+ "indentvertical { "
+ (lout-table-cell-vindent valign)
+ " } ")
+ (if (not width) ""
+ (string-append "width { "
+ (lout-width width)
+ " } "))
+ (if (not bg) ""
+ (string-append "paint { "
+ (lout-color-specification bg)
+ " } ")))))
+
+(define (lout-table-cell-format-string cell vspan-alist)
+ ;; Return a Lout cell format string for `cell'. It uses the `&cell-name'
+ ;; markup option of its cell as its Lout cell name and `vspan-alist' as the
+ ;; source of information regarding its vertical spanning (#f means that
+ ;; `cell' is not vertically spanned).
+ (let ((cell-letter (markup-option cell '&cell-name))
+ (cell-options (lout-table-cell-option-string cell))
+ (colspan (if vspan-alist
+ (cdr (assoc 'hspan vspan-alist))
+ (markup-option cell :colspan)))
+ (vspan-start? (and vspan-alist
+ (cdr (assoc 'start? vspan-alist)))))
+ (if (and (not vspan-start?) vspan-alist)
+ "@VSpan"
+ (let* ((cell-fmt (string-append "@Cell " cell-options
+ (string cell-letter))))
+ (string-append
+ (if (> colspan 1)
+ (string-append (if (and vspan-start? vspan-alist)
+ "@StartHVSpan " "@StartHSpan ")
+ cell-fmt
+ (let pool ((cnt (- colspan 1))
+ (span-cells ""))
+ (if (= cnt 0)
+ span-cells
+ (pool (- cnt 1)
+ (string-append span-cells
+ " | @HSpan")))))
+ (string-append (if (and vspan-alist vspan-start?)
+ "@StartVSpan " "")
+ cell-fmt)))))))
+
+
+(define (lout-table-row-format-string row)
+ ;; Return a Lout row format string for row `row'. It uses the `&cell-name'
+ ;; markup option of its cell as its Lout cell name.
+
+ ;; FIXME: This function has become quite ugly
+ (let ((cells (markup-body row))
+ (row-vspan (markup-option row '&vspan-alist)))
+
+ (let loop ((cells cells)
+ (cell-letter #\A)
+ (delim "")
+ (fmt ""))
+ (lout-debug "looping on cell ~a" cell-letter)
+
+ (if (null? cells)
+
+ ;; The final `|' prevents the rightmost column to be
+ ;; expanded to full page width (see sect. 6.11, p. 133).
+ (if row-vspan
+ ;; In the end, there can be vspan columns left so we need to
+ ;; mark them
+ (let final-loop ((cell-letter cell-letter)
+ (fmt fmt))
+ (let* ((cell-vspan (lout-table-cell-vspan cell-letter
+ row-vspan))
+ (hspan (if cell-vspan
+ (cdr (assoc 'hspan cell-vspan))
+ 1)))
+ (lout-debug "final-loop: ~a ~a" cell-letter cell-vspan)
+ (if (not cell-vspan)
+ (string-append fmt " |")
+ (final-loop (integer->char
+ (+ hspan (char->integer cell-letter)))
+ (string-append fmt " | @VSpan |")))))
+
+ (string-append fmt " |"))
+
+ (let* ((cell (car cells))
+ (vspan-alist (lout-table-cell-vspan cell-letter row-vspan))
+ (vspan-start? (lout-table-cell-vspan-start? vspan-alist))
+ (colspan (if vspan-alist
+ (cdr (assoc 'hspan vspan-alist))
+ (markup-option cell :colspan)))
+ (cell-format
+ (lout-table-cell-format-string cell vspan-alist)))
+
+ (loop (if (or (not vspan-alist) vspan-start?)
+ (cdr cells)
+ cells) ;; don't skip pure vspan cells
+
+ ;; next cell name
+ (char+int cell-letter colspan)
+
+ " | " ;; the cell delimiter
+ (string-append fmt delim cell-format)))))))
+
+
+
+;; A row vspan alist describes the cells of a row that span vertically
+;; and it looks like this:
+;;
+;; ((#\A . ((start? . #t) (hspan . 1) (vspan . 3)))
+;; (#\C . ((start? . #f) (hspan . 2) (vspan . 1))))
+;;
+;; which means that cell `A' start spanning vertically over three rows
+;; including this one, while cell `C' is an "empty" cell that continues
+;; the vertical spanning of a cell appearing on some previous row.
+;;
+;; The running "global" (or "table-wide") vspan alist looks the same
+;; except that it doesn't have the `start?' tags.
+
+(define (lout-table-compute-row-vspan-alist row global-vspan-alist)
+ ;; Compute the vspan alist of row `row' based on the current table vspan
+ ;; alist `global-vspan-alist'. As a side effect, this function stores the
+ ;; Lout cell name (a character between #\A and #\Z) as the value of markup
+ ;; option `&cell-name' of each cell.
+ (if (pair? (markup-body row))
+ ;; Mark the first cell as such.
+ (markup-option-add! (car (markup-body row)) '&first-cell? #t))
+
+ (let cell-loop ((cells (markup-body row))
+ (cell-letter #\A)
+ (row-vspan-alist '()))
+ (lout-debug "cell: ~a ~a" cell-letter
+ (if (null? cells) '() (car cells)))
+
+ (if (null? cells)
+
+ ;; In the end, we must retain any vspan cell that occurs after the
+ ;; current cell name (note: we must add a `start?' tag at this point
+ ;; since the global table vspan alist doesn't have that).
+ (let ((additional-cells (filter (lambda (c)
+ (char>=? (car c) cell-letter))
+ global-vspan-alist)))
+ (lout-debug "compute-row-vspan-alist returning: ~a + ~a (~a)"
+ row-vspan-alist additional-cells
+ (length global-vspan-alist))
+ (append row-vspan-alist
+ (map (lambda (c)
+ `(,(car c) . ,(cons '(start? . #f) (cdr c))))
+ additional-cells)))
+
+ (let* ((current-cell-vspan (assoc cell-letter global-vspan-alist))
+ (hspan (if current-cell-vspan
+ (cdr (assoc 'hspan (cdr current-cell-vspan)))
+ (markup-option (car cells) :colspan))))
+
+ (if (null? (cdr cells))
+ ;; Mark the last cell as such
+ (markup-option-add! (car cells) '&last-cell? #t))
+
+ (cell-loop (if current-cell-vspan
+ cells ;; this cell is vspanned, so don't skip it
+ (cdr cells))
+
+ ;; next cell name
+ (char+int cell-letter (or hspan 1))
+
+ (begin ;; updating the row vspan alist
+ (lout-debug "cells: ~a" (length cells))
+ (lout-debug "current-cell-vspan for ~a: ~a"
+ cell-letter current-cell-vspan)
+
+ (if current-cell-vspan
+
+ ;; this cell is currently vspanned, ie. a previous
+ ;; row defined a vspan for it and that it is still
+ ;; spanning on this row
+ (cons `(,cell-letter
+ . ((start? . #f)
+ (hspan . ,(cdr
+ (assoc
+ 'hspan
+ (cdr current-cell-vspan))))))
+ row-vspan-alist)
+
+ ;; this cell is not currently vspanned
+ (let ((vspan (markup-option (car cells) :rowspan)))
+ (lout-debug "vspan-option for ~a: ~a"
+ cell-letter vspan)
+
+ (markup-option-add! (car cells)
+ '&cell-name cell-letter)
+ (if (and vspan (> vspan 1))
+ (cons `(,cell-letter . ((start? . #t)
+ (hspan . ,hspan)
+ (vspan . ,vspan)))
+ row-vspan-alist)
+ row-vspan-alist)))))))))
+
+(define (lout-table-update-table-vspan-alist table-vspan-alist
+ row-vspan-alist)
+ ;; Update `table-vspan-alist' based on `row-vspan-alist', the alist
+ ;; representing vspan cells for the last row that has been read."
+ (lout-debug "update-table-vspan: ~a and ~a"
+ table-vspan-alist row-vspan-alist)
+
+ (let ((new-vspan-cells (filter (lambda (cell)
+ (cdr (assoc 'start? (cdr cell))))
+ row-vspan-alist)))
+
+ ;; Append the list of new vspan cells described in `row-vspan-alist'
+ (let loop ((cells (append table-vspan-alist new-vspan-cells))
+ (result '()))
+ (if (null? cells)
+ (begin
+ (lout-debug "update-table-vspan returning: ~a" result)
+ result)
+ (let* ((cell (car cells))
+ (cell-letter (car cell))
+ (cell-hspan (cdr (assoc 'hspan (cdr cell))))
+ (cell-vspan (-- (cdr (assoc 'vspan (cdr cell))))))
+ (loop (cdr cells)
+ (if (> cell-vspan 0)
+
+ ;; Keep information about this vspanned cell
+ (cons `(,cell-letter . ((hspan . ,cell-hspan)
+ (vspan . ,cell-vspan)))
+ result)
+
+ ;; Vspan for this cell has been done so we can remove
+ ;; it from the running table vspan alist
+ result)))))))
+
+(define (lout-table-mark-vspan! tab)
+ ;; Traverse the rows of table `tab' and add them an `&vspan-alist' option
+ ;; that describes which of its cells are to be vertically spanned.
+ (let loop ((rows (markup-body tab))
+ (global-vspan-alist '()))
+ (if (null? rows)
+
+ ;; At this point, each row holds its own vspan information alist (the
+ ;; `&vspan-alist' option) so we don't care anymore about the running
+ ;; table vspan alist
+ #t
+
+ (let* ((row (car rows))
+ (row-vspan-alist (lout-table-compute-row-vspan-alist
+ row global-vspan-alist)))
+
+ ;; Bind the row-specific vspan information to the row object
+ (markup-option-add! row '&vspan-alist row-vspan-alist)
+
+ (if (null? (cdr rows))
+ ;; Mark the last row as such
+ (markup-option-add! row '&last-row? #t))
+
+ (loop (cdr rows)
+ (lout-table-update-table-vspan-alist global-vspan-alist
+ row-vspan-alist))))))
+
+(define (lout-table-first-row? row)
+ (markup-option row '&first-row?))
+
+(define (lout-table-last-row? row)
+ (markup-option row '&last-row?))
+
+(define (lout-table-first-cell? cell)
+ (markup-option cell '&first-cell?))
+
+(define (lout-table-last-cell? cell)
+ (markup-option cell '&last-cell?))
+
+(define (lout-table-row-rules row)
+ ;; Return a string representing the Lout option string for
+ ;; displaying rules of `row'.
+ (let* ((table (ast-parent row))
+ (frames (markup-option table :frame))
+ (rules (markup-option table :rules))
+ (first? (lout-table-first-row? row))
+ (last? (lout-table-last-row? row)))
+ (string-append (if (and first?
+ (member frames '(above hsides box border)))
+ "ruleabove { yes } " "")
+ (if (and last?
+ (member frames '(below hsides box border)))
+ "rulebelow { yes } " "")
+ ;; rules
+ (case rules
+ ((header)
+ ;; We consider the first row to be a header row.
+ (if first? "rulebelow { yes }" ""))
+ ((rows all)
+ ;; We use redundant rules because coloring
+ ;; might make them disappear otherwise.
+ (string-append (if first? "" "ruleabove { yes } ")
+ (if last? "" "rulebelow { yes }")))
+ (else "")))))
+
+(define (lout-table-cell-rules cell)
+ ;; Return a string representing the Lout option string for
+ ;; displaying rules of `cell'.
+ (let* ((row (ast-parent cell))
+ (table (ast-parent row))
+ (frames (markup-option table :frame))
+ (rules (markup-option table :rules))
+ (first? (lout-table-first-cell? cell))
+ (last? (lout-table-last-cell? cell)))
+ (string-append (if (and first?
+ (member frames '(vsides lhs box border)))
+ "ruleleft { yes } " "")
+ (if (and last?
+ (member frames '(vsides rhs box border)))
+ "ruleright { yes } " "")
+ ;; rules
+ (case rules
+ ((cols all)
+ ;; We use redundant rules because coloring
+ ;; might make them disappear otherwise.
+ (string-append (if last? "" "ruleright { yes } ")
+ (if first? "" "ruleleft { yes }")))
+ (else "")))))
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:frame :rules :border :width :cellpadding)
+ ;; XXX: `:cellstyle' `separate' and `:cellspacing' not supported
+ ;; by Lout's @Tbl.
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (cp (markup-option n :cellpadding))
+ (rows (markup-body n)))
+
+ (define (cell-width row col)
+ (let ((cells (markup-body row))
+ (bg (markup-option row :bg)))
+ (let loop ((cells cells)
+ (c 0))
+ (if (pair? cells)
+ (let* ((ce (car cells))
+ (width (markup-option ce :width))
+ (colspan (markup-option ce :colspan)))
+ (if (= col c)
+ (if (number? width) width 0)
+ (loop (cdr cells) (+ c colspan))))
+ 0))))
+
+ (define (col-width col)
+ (let loop ((rows rows)
+ (width 0))
+ (if (null? rows)
+ (if (= width 0)
+ 0
+ width)
+ (loop (cdr rows)
+ (max width (cell-width (car rows) col))))))
+
+ (if (pair? (markup-body n))
+ ;; Mark the first row as such
+ (markup-option-add! (car (markup-body n))
+ '&first-row? #t))
+
+ ;; Mark each row with vertical spanning information
+ (lout-table-mark-vspan! n)
+
+ (display "\n@Tbl # table\n")
+
+ (if (number? border)
+ (printf " rulewidth { ~a }\n"
+ (lout-width (markup-option n :border))))
+ (if (number? cp)
+ (printf " margin { ~ap }\n"
+ (number->string cp)))
+
+ (display "{\n")))
+
+ :after (lambda (n e)
+ (let ((header-rows (or (markup-option n '&header-rows) 0)))
+ ;; Issue an `@EndHeaderRow' symbol for each `@HeaderRow' symbol
+ ;; previously produced.
+ (let ((cnt header-rows))
+ (if (> cnt 0)
+ (display "\n@EndHeaderRow"))))
+
+ (display "\n} # @Tbl\n")))
+
+;*---------------------------------------------------------------------*/
+;* 'tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '(:bg)
+ :action (lambda (row e)
+ (let* ((bg (markup-option row :bg))
+ (bg-color (if (not bg) ""
+ (string-append
+ "paint { "
+ (lout-color-specification bg) " } ")))
+ (first-row? (markup-option row '&first-row?))
+ (header-row? (any (lambda (n)
+ (eq? (markup-option n 'markup)
+ 'th))
+ (markup-body row)))
+ (fmt (lout-table-row-format-string row))
+ (rules (lout-table-row-rules row)))
+
+ ;; Use `@FirstRow' and `@HeaderFirstRow' for the first
+ ;; row. `@HeaderFirstRow' seems to be buggy though.
+ ;; (see section 6.1, p.119 of the User's Guide).
+
+ (printf "\n@~aRow ~aformat { ~a }"
+ (if first-row? "First" "")
+ bg-color fmt)
+ (display (string-append " " rules))
+ (output (markup-body row) e)
+
+ (if (and header-row? (engine-custom e 'use-header-rows?))
+ ;; `@HeaderRow' symbols are not actually printed
+ ;; (see section 6.11, p. 134 of the User's Guide)
+ ;; FIXME: This all seems buggy on the Lout side.
+ (let* ((tab (ast-parent row))
+ (hrows (and (markup? tab)
+ (or (markup-option tab '&header-rows)
+ 0))))
+ (if (not (is-markup? tab 'table))
+ (skribe-error 'lout
+ "tr's parent not a table!" tab))
+ (markup-option-add! tab '&header-rows (+ hrows 1))
+ (printf "\n@Header~aRow ~aformat { ~a }"
+ "" ; (if first-row? "First" "")
+ bg-color fmt)
+ (display (string-append " " rules))
+
+ ;; the cells must be produced once here
+ (output (markup-body row) e))))))
+
+;*---------------------------------------------------------------------*/
+;* tc */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(markup :width :align :valign :colspan :rowspan :bg)
+ :before (lambda (cell e)
+ (printf "\n ~a { " (markup-option cell '&cell-name)))
+ :after (lambda (cell e)
+ (display " }")))
+
+
+;*---------------------------------------------------------------------*/
+;* image ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("eps"))))))
+ (if url ;; maybe we should run `wget' then? :-)
+ (skribe-error 'lout "Image URLs not supported" url))
+ (if (not (string? img))
+ (skribe-error 'lout "Illegal image" file)
+ (begin
+ (if width
+ (printf "\n~a @Wide" (lout-width width)))
+ (if height
+ (printf "\n~a @High" (lout-width height)))
+ (if zoom
+ (printf "\n~a @Scale" zoom))
+ (printf "\n@IncludeGraphic { \"~a\" }\n" img))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+;; Each ornament is enclosed in braces to allow such things as
+;; "he,(bold "ll")o" to work without adding an extra space.
+(markup-writer 'roman :before "{ @R { " :after " } }")
+(markup-writer 'underline :before "{ @Underline { " :after " } }")
+(markup-writer 'code :before "{ @F { " :after " } }")
+(markup-writer 'var :before "{ @F { " :after " } }")
+(markup-writer 'sc :before "{ @S {" :after " } }")
+(markup-writer 'sf :before "{ { Helvetica Base } @Font { " :after " } }")
+(markup-writer 'sub :before "{ @Sub { " :after " } }")
+(markup-writer 'sup :before "{ @Sup { " :after " } }")
+(markup-writer 'tt :before "{ @F { " :after " } }")
+
+
+;; `(bold (it ...))' and `(it (bold ...))' should both lead to `@BI { ... }'
+;; instead of `@B { @I { ... } }' (which is different).
+;; Unfortunately, it is not possible to use `ast-parent' and
+;; `find1-up' to check whether `it' (resp. `bold') was invoked within
+;; a `bold' (resp. `it') markup, hence the `&italics' and `&bold'
+;; option trick. FIXME: This would be much more efficient if
+;; `ast-parent' would work as expected.
+
+(markup-writer 'it
+ :before (lambda (node engine)
+ (let ((bold-children (search-down (lambda (n)
+ (is-markup? n 'bold))
+ node)))
+ (map (lambda (b)
+ (markup-option-add! b '&italics #t))
+ bold-children)
+ (printf "{ ~a { "
+ (if (markup-option node '&bold)
+ "@BI" "@I"))))
+ :after " } }")
+
+(markup-writer 'emph
+ :before (lambda (n e)
+ (invoke (writer-before (markup-writer-get 'it e))
+ n e))
+ :after (lambda (n e)
+ (invoke (writer-after (markup-writer-get 'it e))
+ n e)))
+
+(markup-writer 'bold
+ :before (lambda (node engine)
+ (let ((it-children (search-down (lambda (n)
+ (or (is-markup? n 'it)
+ (is-markup? n 'emph)))
+ node)))
+ (map (lambda (i)
+ (markup-option-add! i '&bold #t))
+ it-children)
+ (printf "{ ~a { "
+ (if (markup-option node '&italics)
+ "@BI" "@B"))))
+ :after " } }")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "{ @Char guillemotleft }\" \""
+ :after "\" \"{ @Char guillemotright }")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :before " @I { "
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (output (or text (markup-body n)) e)))
+ :after " }")
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :action (lambda (n e)
+ (if (markup-ident n)
+ (begin
+ (display "{ @SkribeMark { ")
+ (display (lout-tagify (markup-ident n)))
+ (display " } }"))
+ (skribe-error 'lout "mark: Node has no identifier" n))))
+
+(define (lout-page-of ident)
+ ;; Return a string for the `@PageOf' statement for `ident'.
+ (let ((tag (lout-tagify ident)))
+ (string-append ", { " tag " } @CrossLink { "
+ "p. @PageOf { " tag " } }")))
+
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection
+ :figure :mark :handle :ident :page)
+ :action (lambda (n e)
+ (let ((url (markup-option n :url))
+ (text (markup-option n :text))
+ (mark (markup-option n :mark))
+ (handle (markup-option n :handle))
+ (chapter (markup-option n :chapter))
+ (section (markup-option n :section))
+ (subsection (markup-option n :subsection))
+ (subsubsection (markup-option n :subsubsection))
+ (show-page-num? (markup-option n :page)))
+
+ ;; A handle to the target is automagically passed
+ ;; as the body of each `ref' instance (see `api.scm').
+ (let* ((target (handle-ast (markup-body n)))
+ (ident (markup-ident target))
+ (title (markup-option target :title))
+ (number (markup-option target :number)))
+ (lout-debug "ref: target=~a ident=~a" target ident)
+ (if text (output text e))
+
+ ;; Marks don't have a number
+ (if (eq? (markup-markup target) 'mark)
+ (printf (lout-page-of ident))
+ (begin
+ ;; Don't output a section/whatever number
+ ;; when text is provided in order to be
+ ;; consistent with the HTML back-end.
+ ;; Sometimes (eg. for user-defined markups),
+ ;; we don't even know how to reference them
+ ;; anyway.
+ (if (not text)
+ (printf " @NumberOf { ~a }"
+ (lout-tagify ident)))
+ (if show-page-num?
+ (printf (lout-page-of ident)))))))))
+
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let ((entry (handle-ast (markup-body n))))
+ (output (markup-option entry :title) e)))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ ;; When several references are passed. Strangely enough, the list of
+ ;; entries passed to this writer (as its body) contains both `bib-ref' and
+ ;; `bib-entry' objects, hence the `canonicalize-entry' function below.
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let* ((entries (markup-body n))
+ (canonicalize-entry (lambda (x)
+ (cond
+ ((is-markup? x 'bib-entry) x)
+ ((is-markup? x 'bib-ref)
+ (handle-ast (markup-body x)))
+ (else
+ (skribe-error
+ 'lout
+ "bib-ref+: invalid entry type"
+ x)))))
+ (help-proc (lambda (proc)
+ (lambda (e1 e2)
+ (proc (canonicalize-entry e1)
+ (canonicalize-entry e2)))))
+ (sort-proc (engine-custom e 'bib-refs-sort-proc)))
+ (let loop ((rs (if sort-proc
+ (sort entries (help-proc sort-proc))
+ entries)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs)))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (let ((url (markup-option n :url))
+ (text (markup-option n :text))
+ (transform (engine-custom e 'transform-url-ref-proc)))
+ (if (or (not transform)
+ (markup-option n '&transformed))
+ (begin
+ (printf "{ \"~a\" @ExternalLink { " url)
+ (if text ;; FIXME: Should be (not (string-index text #\space))
+ (output text e)
+ (let ((filter-url (make-string-replace
+ `((#\/ "\"/\"&-")
+ (#\. ".&-")
+ (#\- "&-")
+ (#\_ "_&-")
+ ,@lout-verbatim-encoding
+ (#\newline "")))))
+ ;; Filter the URL in a way to give Lout hints on
+ ;; where hyphenation should take place.
+ (fprint (current-error-port) "Here!!!" filter-url)
+ (display (filter-url url) e)))
+ (printf " } }"))
+ (begin
+ (markup-option-add! n '&transformed #t)
+ (output (transform n) e))))))
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before "{ @I {" ;; FIXME: Not tested
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (cond
+ ((and (number? o) (number? v))
+ (display (+ o v)))
+ (else
+ (display v)))))
+ :after "} }")
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ ;; Compute the length (in characters) of the longest entry label
+ ;; so that the label width of the list is adjusted.
+ (let loop ((entries (markup-body n))
+ (label-width 0))
+ (if (null? entries)
+ (begin
+ (display "\n# the-bibliography\n@LP\n")
+ ;; usually, the tag with be something like "[7]", hence
+ ;; the `+ 1' below (`[]' is narrower than 2f)
+ (printf "@TaggedList labelwidth { ~af }\n"
+ (+ 1 label-width)))
+ (loop (cdr entries)
+ (let ((entry-length
+ (let liip ((e (car entries)))
+ (cond
+ ((markup? e)
+ (cond ((is-markup? e '&bib-entry)
+ (liip (markup-option e :title)))
+ ((is-markup? e '&bib-entry-ident)
+ (liip (markup-option e 'number)))
+ (else
+ (liip (markup-body e)))))
+ ((string? e)
+ (string-length e))
+ ((number? e)
+ (liip (number->string e)))
+ ((list? e)
+ (apply + (map liip e)))
+ (else 0)))))
+; (fprint (current-error-port)
+; "node=" (car entries)
+; " body=" (markup-body (car entries))
+; " title=" (markup-option (car entries)
+; :title)
+; " len=" entry-length)
+ (if (> label-width entry-length)
+ label-width
+ entry-length))))))
+ :after (lambda (n e)
+ (display "\n@EndList # the-bibliography (end)\n")))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :before "@TagItem "
+ :action (lambda (n e)
+ (display " { ")
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (display " } { ")
+ (output n e (markup-writer-get '&bib-entry-body e))
+ (display " }"))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before " \"[\""
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "\"]\" ")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e)
+ (display "@Center { ") ;; FIXME: Needs to be rewritten.
+ (for-each (lambda (h)
+ (let ((f (engine-custom e 'index-header-font-size)))
+ (if f
+ (skribe-eval (font :size f (bold (it h))) e)
+ (output h e))
+ (display " ")))
+ (markup-body n))
+ (display " }")
+ (skribe-eval (linebreak 2) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+
+;*---------------------------------------------------------------------*/
+;* Illustrations */
+;*---------------------------------------------------------------------*/
+(define (lout-illustration . args)
+ ;; Introduce a Lout illustration (such as a diagram) whose code is either
+ ;; the body of `lout-illustration' or the contents of `file'. For engines
+ ;; other than Lout, an EPS file is produced and then converted if needed.
+ ;; The `:alt' option is equivalent to HTML's `alt' attribute for the `img'
+ ;; markup, i.e. it is passed as the body of the `image' markup for
+ ;; non-Lout back-ends.
+
+ (define (file-contents file)
+ ;; Return the contents (a string) of file `file'.
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((contents "")
+ (line (read-line)))
+ (if (eof-object? line)
+ contents
+ (loop (string-append contents line "\n")
+ (read-line)))))))
+
+ (define (illustration-header)
+ ;; Return a string denoting the header of a Lout illustration.
+ (let ((lout (find-engine 'lout)))
+ (string-append "@SysInclude { picture }\n"
+ (engine-custom lout 'includes)
+ "\n\n@Illustration\n"
+ " @InitialFont { "
+ (engine-custom lout 'initial-font)
+ " }\n"
+ " @InitialBreak { "
+ (engine-custom lout 'initial-break)
+ " }\n"
+ " @InitialLanguage { "
+ (engine-custom lout 'initial-language)
+ " }\n"
+ " @InitialSpace { tex }\n"
+ "{\n")))
+
+ (define (illustration-ending)
+ ;; Return a string denoting the end of a Lout illustration.
+ "\n}\n")
+
+ (let* ((opts (the-options args '(file ident alt)))
+ (file* (assoc ':file opts))
+ (ident* (assoc ':ident opts))
+ (alt* (assoc ':alt opts))
+ (file (and file* (cadr file*)))
+ (ident (and ident* (cadr ident*)))
+ (alt (or (and alt* (cadr alt*)) "An illustration")))
+
+ (let ((contents (if (not file)
+ (car (the-body args))
+ (file-contents file))))
+ (if (engine-format? "lout")
+ (! contents) ;; simply inline the illustration
+ (cond-expand
+ (bigloo
+ (let* ((lout (find-engine 'lout))
+ (output (string-append (or ident
+ (symbol->string
+ (gensym 'lout-illustration)))
+ ".eps"))
+ (proc (run-process (or (engine-custom lout
+ 'lout-program-name)
+ "lout")
+ "-o" output
+ "-EPS"
+ input: pipe:))
+ (port (process-input-port proc)))
+
+ ;; send the illustration to Lout's standard input
+ (display (illustration-header) port)
+ (display contents port)
+ (display (illustration-ending) port)
+ (close-output-port port)
+
+ (process-wait proc)
+ (if (not (= 0 (process-exit-status proc)))
+ (skribe-error 'lout-illustration
+ "lout exited with error code"
+ (process-exit-status proc)))
+ (if (not (file-exists? output))
+ (skribe-error 'lout-illustration "file not created"
+ output))
+ (if (= 0 (file-size output))
+ (skribe-error 'lout-illustration
+ "empty output file" output))
+
+ ;; the image
+ (image :file output alt)))
+
+ (else ;; Unfortunately, chances are low that STklos has the same
+ ;; process API as the one Bigloo has.
+ (skribe-error 'lout
+ "lout-illustration: Not implemented" file)))))))
+
+
+;*---------------------------------------------------------------------*/
+;* Slides */
+;* */
+;* At some point, this should move to `slide.skr'. */
+;*---------------------------------------------------------------------*/
+; (skribe-load "slide.skr")
+
+; (markup-writer 'slide
+; ;; FIXME: In `slide.skr', `:ident' is systematically generated.
+; :options '(:title :number :toc :ident) ;; '(:bg :vspace :image)
+
+; :validate (lambda (n e)
+; (eq? (engine-custom e 'document-type) 'slides))
+
+; :before (lambda (n e)
+; (display "\n@Overhead\n")
+; (display " @Title { ")
+; (output (markup-option n :title) e)
+; (display " }\n")
+; (if (markup-ident n)
+; (begin
+; (display " @Tag { ")
+; (display (lout-tagify (markup-ident n)))
+; (display " }\n")))
+; (if (markup-option n :number)
+; (begin
+; (display " @BypassNumber { ")
+; (output (markup-option n :number) e)
+; (display " }\n")))
+; (display "@Begin\n")
+
+; ;; `doc' documents produce their PDF outline right after
+; ;; `@Text @Begin'; other types of documents must produce it
+; ;; as part of their first chapter.
+; (lout-output-pdf-meta-info (ast-document n) e))
+
+; :after "@End @Overhead\n")
+
+; (markup-writer 'slide-vspace
+; :options '(:unit)
+; :validate (lambda (n e)
+; (and (pair? (markup-body n))
+; (number? (car (markup-body n)))))
+; :action (lambda (n e)
+; (printf "\n//~a~a # slide-vspace\n"
+; (car (markup-body n))
+; (case (markup-option n :unit)
+; ((cm) "c")
+; ((point points pt) "p")
+; ((inch inches) "i")
+; (else
+; (skribe-error 'lout
+; "Unknown vspace unit"
+; (markup-option n :unit)))))))
+
+; (markup-writer 'slide-pause
+; ;; FIXME: Use a `pdfmark' custom action and a PDF transition action.
+; ;; << /Type /Action
+; ;; << /S /Trans
+; ;; entry in the trans dict
+; ;; << /Type /Trans /S /Dissolve >>
+; :action (lambda (n e)
+; (let ((filter (make-string-replace lout-verbatim-encoding))
+; (pdfmark "
+; [ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark"))
+; (display (lout-embedded-postscript-code
+; (filter pdfmark))))))
+
+; ;; For movies, see
+; ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty .
+; (markup-writer 'slide-embed
+; :options '(:alt :geometry :rgeometry :geometry-opt :command)
+; ;; FIXME: `pdfmark'.
+; ;; << /Type /Action /S /Launch
+; :action (lambda (n e)
+; (let ((command (markup-option n :command))
+; (filter (make-string-replace lout-verbatim-encoding))
+; (pdfmark "[ /Rect [ 0 ysize xsize 0 ]
+; /Name /Comment
+; /Contents (This is an embedded application)
+; /ANN pdfmark
+
+; [ /Type /Action
+; /S /Launch
+; /F (~a)
+; /OBJ pdfmark"))
+; (display (string-append
+; "4c @Wide 3c @High "
+; (lout-embedded-postscript-code
+; (filter (format #f pdfmark command))))))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
+
+
+;; Local Variables: --
+;; mode: Scheme --
+;; coding: latin-1 --
+;; scheme-program-name: "guile" --
+;; End: --
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index ef8ef8d..aaf1a8f 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -194,8 +194,9 @@
;;;
(define (%skribe-warn level file line lst)
(let ((port (current-error-port)))
- (format port "**** WARNING:\n")
- (when (and file line) (format port "~a: ~a: " file line))
+ (when (and file line)
+ (format port "~a:~a: " file line))
+ (format port "warning: ")
(for-each (lambda (x) (format port "~a " x)) lst)
(newline port)))
@@ -346,7 +347,7 @@
(define hashtable-put! hash-set!)
(define hashtable-update! hash-set!)
(define hashtable->list (lambda (h)
- (map cdr (hash-table->list h))))
+ (map cdr (hash-map->list cons h))))
(define find-runtime-type (lambda (obj) obj))
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 854c50d..1a8f622 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -44,6 +44,8 @@
;(srfi srfi-19) ;; date and time
(oop goops) ;; `make'
(ice-9 optargs) ;; `define*'
+ (ice-9 and-let-star) ;; `and-let*'
+ (ice-9 receive) ;; `receive'
(skribilo module)
(skribilo types) ;; `<document>', `document?', etc.
@@ -56,7 +58,9 @@
(skribilo engine)
(skribilo writer)
(skribilo output)
- (skribilo evaluator)))
+ (skribilo evaluator)
+ (skribilo color)
+ (skribilo debug)))
(define *skribe-core-modules*
'("utils" "api" "bib" "index" "param" "sui"))
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm
index 1f411dc..03e515c 100644
--- a/src/guile/skribilo/runtime.scm
+++ b/src/guile/skribilo/runtime.scm
@@ -25,9 +25,10 @@
;;;
(define-module (skribilo runtime)
+ ;; FIXME: Useful procedures are scattered between here and
+ ;; `(skribilo skribe utils)'.
:export (;; Utilities
strip-ref-base ast->file-location string-canonicalize
- the-options the-body
;; Markup functions
markup-option markup-option-add! markup-output
@@ -42,7 +43,10 @@
make-string-replace
;; AST
- ast->string))
+ ast-parent ast->string
+ markup-parent markup-document markup-chapter
+
+ handle-body))
(use-modules (skribilo debug)
(skribilo types)
@@ -51,6 +55,7 @@
(skribilo output)
(skribilo evaluator)
(skribilo vars)
+ (skribilo lib)
(srfi srfi-13)
(oop goops))
@@ -201,7 +206,7 @@
(let ((path (search-path (skribe-image-path) file)))
(if (not path)
(skribe-error 'convert-image
- (format "Can't find `~a' image file in path: " file)
+ (format #f "can't find `~a' image file in path: " file)
(skribe-image-path))
(let ((suf (suffix file)))
(if (member suf formats)
@@ -224,6 +229,7 @@
p
(loop (cdr fmts)))))))))))
+
;;; ======================================================================
;;;
;;; S T R I N G - W R I T I N G
@@ -316,7 +322,7 @@
-
+
;;; ======================================================================
;;;
;;; A S T
@@ -346,120 +352,53 @@
(ast->string (slot-ref ast 'body)))
-;;NEW ;;
-;;NEW ;; AST-PARENT
-;;NEW ;;
-;;NEW (define (ast-parent n)
-;;NEW (slot-ref n 'parent))
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-PARENT
-;;NEW ;;
-;;NEW (define (markup-parent m)
-;;NEW (let ((p (slot-ref m 'parent)))
-;;NEW (if (eq? p 'unspecified)
-;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m)
-;;NEW p)))
-;;NEW
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-DOCUMENT
-;;NEW ;;
-;;NEW (define (markup-document m)
-;;NEW (let Loop ((p m)
-;;NEW (l #f))
-;;NEW (cond
-;;NEW ((is-markup? p 'document) p)
-;;NEW ((or (eq? p 'unspecified) (not p)) l)
-;;NEW (else (Loop (slot-ref p 'parent) p)))))
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-CHAPTER
-;;NEW ;;
-;;NEW (define (markup-chapter m)
-;;NEW (let loop ((p m)
-;;NEW (l #f))
-;;NEW (cond
-;;NEW ((is-markup? p 'chapter) p)
-;;NEW ((or (eq? p 'unspecified) (not p)) l)
-;;NEW (else (loop (slot-ref p 'parent) p)))))
-;;NEW
-;;NEW
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; H A N D L E S
-;;NEW ;;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (handle-body h)
-;;NEW (slot-ref h 'body))
-;;NEW
-;;NEW
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; F I N D
-;;NEW ;;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (find pred obj)
-;;NEW (with-debug 4 'find
-;;NEW (debug-item "obj=" obj)
-;;NEW (let loop ((obj (if (is-a? obj <container>) (container-body obj) obj)))
-;;NEW (cond
-;;NEW ((pair? obj)
-;;NEW (apply append (map (lambda (o) (loop o)) obj)))
-;;NEW ((is-a? obj <container>)
-;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident))
-;;NEW (if (pred obj)
-;;NEW (list (cons obj (loop (container-body obj))))
-;;NEW '()))
-;;NEW (else
-;;NEW (if (pred obj)
-;;NEW (list obj)
-;;NEW '()))))))
-;;NEW
+
+;;
+;; AST-PARENT
+;;
+(define (ast-parent n)
+ (slot-ref n 'parent))
+
+;;
+;; MARKUP-PARENT
+;;
+(define (markup-parent m)
+ (let ((p (slot-ref m 'parent)))
+ (if (eq? p 'unspecified)
+ (skribe-error 'markup-parent "Unresolved parent reference" m)
+ p)))
+
+
+;;
+;; MARKUP-DOCUMENT
+;;
+(define (markup-document m)
+ (let Loop ((p m)
+ (l #f))
+ (cond
+ ((is-markup? p 'document) p)
+ ((or (eq? p 'unspecified) (not p)) l)
+ (else (Loop (slot-ref p 'parent) p)))))
+
+;;
+;;
+;; MARKUP-CHAPTER
+;;
+(define (markup-chapter m)
+ (let loop ((p m)
+ (l #f))
+ (cond
+ ((is-markup? p 'chapter) p)
+ ((or (eq? p 'unspecified) (not p)) l)
+ (else (loop (slot-ref p 'parent) p)))))
+
;;;; ======================================================================
;;;;
-;;;; M A R K U P A R G U M E N T P A R S I N G
+;;;; H A N D L E S
;;;;
;;;; ======================================================================
-(define (the-body opt)
- ;; Filter out the options
- (let loop ((opt* opt)
- (res '()))
- (cond
- ((null? opt*)
- (reverse! res))
- ((not (pair? opt*))
- (skribe-error 'the-body "Illegal body" opt))
- ((keyword? (car opt*))
- (if (null? (cdr opt*))
- (skribe-error 'the-body "Illegal option" (car opt*))
- (loop (cddr opt*) res)))
- (else
- (loop (cdr opt*) (cons (car opt*) res))))))
-
-
-
-(define (the-options opt+ . out)
- ;; Returns an list made of options.The OUT argument contains
- ;; keywords that are filtered out.
- (let loop ((opt* opt+)
- (res '()))
- (cond
- ((null? opt*)
- (reverse! res))
- ((not (pair? opt*))
- (skribe-error 'the-options "Illegal options" opt*))
- ((keyword? (car opt*))
- (cond
- ((null? (cdr opt*))
- (skribe-error 'the-options "Illegal option" (car opt*)))
- ((memq (car opt*) out)
- (loop (cdr opt*) res))
- (else
- (loop (cdr opt*)
- (cons (list (car opt*) (cadr opt*)) res)))))
- (else
- (loop (cdr opt*) res)))))
+(define (handle-body h)
+ (slot-ref h 'body))
diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm
index e7ba4a6..d66b3b4 100644
--- a/src/guile/skribilo/skribe/api.scm
+++ b/src/guile/skribilo/skribe/api.scm
@@ -40,6 +40,7 @@
(gensym-orig (cond ((symbol? obj) (symbol->string obj))
(else obj))))))
+
;*---------------------------------------------------------------------*/
;* include ... */
;*---------------------------------------------------------------------*/
@@ -253,7 +254,6 @@
;* paragraph ... */
;*---------------------------------------------------------------------*/
(define-simple-markup paragraph)
-(define-public p paragraph)
;*---------------------------------------------------------------------*/
;* footnote ... */
@@ -464,7 +464,7 @@
((and (integer? start) (integer? stop) (> start stop))
(skribe-error 'source
"start line > stop line"
- (format "~a/~a" start stop)))
+ (format #f "~a/~a" start stop)))
((and language (not (language? language)))
(skribe-error 'source "Illegal language" language))
((and tab (not (integer? tab)))
@@ -553,7 +553,7 @@
(if (not (is-markup? r markup))
(skribe-warning 2
for
- (format "Illegal `~a' element, `~a' expected"
+ (format #f "illegal `~a' element, `~a' expected"
(if (markup? r)
(markup-markup r)
(find-runtime-type r))
@@ -643,17 +643,17 @@
(cond
((and frame (not (memq frame frame-vals)))
(skribe-error 'table
- (format "frame should be one of \"~a\"" frame-vals)
+ (format #f "frame should be one of \"~a\"" frame-vals)
frame))
((and rules (not (memq rules rules-vals)))
(skribe-error 'table
- (format "rules should be one of \"~a\"" rules-vals)
+ (format #f "rules should be one of \"~a\"" rules-vals)
rules))
((not (or (memq cellstyle cells-vals)
(string? cellstyle)
(number? cellstyle)))
(skribe-error 'table
- (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals)
+ (format #f "cellstyle should be one of \"~a\", or a number, or a string" cells-vals)
cellstyle))
(else
(new container
@@ -689,7 +689,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(let ((align (if (string? align)
(string->symbol align)
align))
@@ -735,7 +735,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(apply tc 'th opts))
;*---------------------------------------------------------------------*/
@@ -746,7 +746,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(apply tc 'td opts))
;*---------------------------------------------------------------------*/
@@ -818,19 +818,20 @@
;*---------------------------------------------------------------------*/
;* symbol ... */
;*---------------------------------------------------------------------*/
-(define-markup (symbol symbol)
- (let ((v (cond
- ((symbol? symbol)
- (symbol->string symbol))
- ((string? symbol)
- symbol)
- (else
- (skribe-error 'symbol
- "Illegal argument (symbol expected)"
- symbol)))))
- (new markup
- (markup 'symbol)
- (body v))))
+(set! symbol
+ (lambda (symbol)
+ (let ((v (cond
+ ((symbol? symbol)
+ (symbol->string symbol))
+ ((string? symbol)
+ symbol)
+ (else
+ (skribe-error 'symbol
+ "Illegal argument (symbol expected)"
+ symbol)))))
+ (new markup
+ (markup 'symbol)
+ (body v)))))
;*---------------------------------------------------------------------*/
;* ! ... */
@@ -972,7 +973,7 @@
(skribe #f)
(page #f))
(define (unref ast text kind)
- (let ((msg (format "Can't find `~a': " kind)))
+ (let ((msg (format #f "can't find `~a': " kind)))
(if (ast? ast)
(begin
(skribe-warning/ast 1 ast 'ref msg text)
@@ -1259,3 +1260,73 @@
char-offset
header-limit
column))))))))
+
+
+;;; This part comes from the file `skribe.skr' in the original Skribe
+;;; distribution.
+
+;*---------------------------------------------------------------------*/
+;* p ... */
+;*---------------------------------------------------------------------*/
+(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location)
+ (paragraph :ident ident :class class :loc &skribe-eval-location
+ (the-body opt)))
+
+;*---------------------------------------------------------------------*/
+;* fg ... */
+;*---------------------------------------------------------------------*/
+(define-public (fg c . body)
+ (color :fg c body))
+
+;*---------------------------------------------------------------------*/
+;* bg ... */
+;*---------------------------------------------------------------------*/
+(define-public (bg c . body)
+ (color :bg c body))
+
+;*---------------------------------------------------------------------*/
+;* counter ... */
+;* ------------------------------------------------------------- */
+;* This produces a kind of "local enumeration" that is: */
+;* (counting "toto," "tutu," "titi.") */
+;* produces: */
+;* i) toto, ii) tutu, iii) titi. */
+;*---------------------------------------------------------------------*/
+(define-markup (counter #!rest opts #!key (numbering 'roman))
+ (define items (if (eq? (car opts) :numbering) (cddr opts) opts))
+ (define vroman #(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x"))
+ (define (the-roman-number num)
+ (if (< num (vector-length vroman))
+ (list (list "(" (it (vector-ref vroman num)) ") "))
+ (skribe-error 'counter
+ "too many items for roman numbering"
+ (length items))))
+ (define (the-arabic-number num)
+ (list (list "(" (it (integer->string num)) ") ")))
+ (define (the-alpha-number num)
+ (list (list "(" (it (+ (integer->char #\a) num -1)) ") ")))
+ (let ((the-number (case numbering
+ ((roman) the-roman-number)
+ ((arabic) the-arabic-number)
+ ((alpha) the-alpha-number)
+ (else (skribe-error 'counter
+ "Illegal numbering"
+ numbering)))))
+ (let loop ((num 1)
+ (items items)
+ (res '()))
+ (if (null? items)
+ (reverse! res)
+ (loop (+ num 1)
+ (cdr items)
+ (cons (list (the-number num) (car items)) res))))))
+
+;*---------------------------------------------------------------------*/
+;* q */
+;*---------------------------------------------------------------------*/
+(define-markup (q #!rest opt)
+ (new markup
+ (markup 'q)
+ (options (the-options opt))
+ (body (the-body opt))))
+
diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm
index 2ec5c0b..0a80ec9 100644
--- a/src/guile/skribilo/skribe/bib.scm
+++ b/src/guile/skribilo/skribe/bib.scm
@@ -35,7 +35,7 @@
;*---------------------------------------------------------------------*/
;* bib-load! ... */
;*---------------------------------------------------------------------*/
-(define (bib-load! table filename command)
+(define-public (bib-load! table filename command)
(if (not (bib-table? table))
(skribe-error 'bib-load "Illegal bibliography table" table)
;; read the file
@@ -49,7 +49,7 @@
;*---------------------------------------------------------------------*/
;* resolve-bib ... */
;*---------------------------------------------------------------------*/
-(define (resolve-bib table ident)
+(define-public (resolve-bib table ident)
(if (not (bib-table? table))
(skribe-error 'resolve-bib "Illegal bibliography table" table)
(let* ((i (cond
@@ -64,7 +64,7 @@
;*---------------------------------------------------------------------*/
;* make-bib-entry ... */
;*---------------------------------------------------------------------*/
-(define (make-bib-entry kind ident fields from)
+(define-public (make-bib-entry kind ident fields from)
(let* ((m (new markup
(markup '&bib-entry)
(ident ident)
@@ -91,7 +91,7 @@
;*---------------------------------------------------------------------*/
;* bib-sort/authors ... */
;*---------------------------------------------------------------------*/
-(define (bib-sort/authors l)
+(define-public (bib-sort/authors l)
(define (cmp i1 i2 def)
(cond
((and (markup? i1) (markup? i2))
@@ -128,13 +128,13 @@
;*---------------------------------------------------------------------*/
;* bib-sort/idents ... */
;*---------------------------------------------------------------------*/
-(define (bib-sort/idents l)
+(define-public (bib-sort/idents l)
(sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f)))))
;*---------------------------------------------------------------------*/
;* bib-sort/dates ... */
;*---------------------------------------------------------------------*/
-(define (bib-sort/dates l)
+(define-public (bib-sort/dates l)
(sort l (lambda (p1 p2)
(define (month-num m)
(let ((body (markup-body m)))
@@ -182,7 +182,7 @@
;*---------------------------------------------------------------------*/
;* resolve-the-bib ... */
;*---------------------------------------------------------------------*/
-(define (resolve-the-bib table n sort pred count opts)
+(define-public (resolve-the-bib table n sort pred count opts)
(define (count! entries)
(let loop ((es entries)
(i 1))
diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm
index b2a5cfb..9aaa81f 100644
--- a/src/guile/skribilo/skribe/utils.scm
+++ b/src/guile/skribilo/skribe/utils.scm
@@ -19,8 +19,7 @@
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
-(define-skribe-module (skribilo skribe utils)
- #:export (ast-document))
+(define-skribe-module (skribilo skribe utils))
;;; Author: Manuel Serrano
;;; Commentary:
@@ -36,7 +35,7 @@
;*---------------------------------------------------------------------*/
;* engine-custom-add! ... */
;*---------------------------------------------------------------------*/
-(define (engine-custom-add! e id val)
+(define-public (engine-custom-add! e id val)
(let ((old (engine-custom e id)))
(if (unspecified? old)
(engine-custom-set! e id (list val))
@@ -45,7 +44,7 @@
;*---------------------------------------------------------------------*/
;* find-markup-ident ... */
;*---------------------------------------------------------------------*/
-(define (find-markup-ident ident)
+(define-public (find-markup-ident ident)
(let ((r (find-markups ident)))
(if (or (pair? r) (null? r))
r
@@ -54,7 +53,7 @@
;*---------------------------------------------------------------------*/
;* container-search-down ... */
;*---------------------------------------------------------------------*/
-(define (container-search-down pred obj)
+(define-public (container-search-down pred obj)
(with-debug 4 'container-search-down
(debug-item "obj=" (find-runtime-type obj))
(let loop ((obj (markup-body obj)))
@@ -74,7 +73,7 @@
;*---------------------------------------------------------------------*/
;* search-down ... */
;*---------------------------------------------------------------------*/
-(define (search-down pred obj)
+(define-public (search-down pred obj)
(with-debug 4 'search-down
(debug-item "obj=" (find-runtime-type obj))
(let loop ((obj (markup-body obj)))
@@ -94,7 +93,7 @@
;*---------------------------------------------------------------------*/
;* find-down ... */
;*---------------------------------------------------------------------*/
-(define (find-down pred obj)
+(define-public (find-down pred obj)
(with-debug 4 'find-down
(debug-item "obj=" (find-runtime-type obj))
(let loop ((obj obj))
@@ -115,7 +114,7 @@
;*---------------------------------------------------------------------*/
;* find1-down ... */
;*---------------------------------------------------------------------*/
-(define (find1-down pred obj)
+(define-public (find1-down pred obj)
(with-debug 4 'find1-down
(let loop ((obj obj)
(stack '()))
@@ -143,7 +142,7 @@
;*---------------------------------------------------------------------*/
;* find-up ... */
;*---------------------------------------------------------------------*/
-(define (find-up pred obj)
+(define-public (find-up pred obj)
(let loop ((obj obj)
(res '()))
(cond
@@ -157,7 +156,7 @@
;*---------------------------------------------------------------------*/
;* find1-up ... */
;*---------------------------------------------------------------------*/
-(define (find1-up pred obj)
+(define-public (find1-up pred obj)
(let loop ((obj obj))
(cond
((not (ast? obj))
@@ -170,19 +169,19 @@
;*---------------------------------------------------------------------*/
;* ast-document ... */
;*---------------------------------------------------------------------*/
-(define (ast-document m)
+(define-public (ast-document m)
(find1-up document? m))
;*---------------------------------------------------------------------*/
;* ast-chapter ... */
;*---------------------------------------------------------------------*/
-(define (ast-chapter m)
+(define-public (ast-chapter m)
(find1-up (lambda (n) (is-markup? n 'chapter)) m))
;*---------------------------------------------------------------------*/
;* ast-section ... */
;*---------------------------------------------------------------------*/
-(define (ast-section m)
+(define-public (ast-section m)
(find1-up (lambda (n) (is-markup? n 'section)) m))
;*---------------------------------------------------------------------*/
@@ -190,7 +189,7 @@
;* ------------------------------------------------------------- */
;* Filter out the options */
;*---------------------------------------------------------------------*/
-(define (the-body opt+)
+(define-public (the-body opt+)
(let loop ((opt* opt+)
(res '()))
(cond
@@ -211,7 +210,7 @@
;* Returns an list made of options. The OUT argument contains */
;* keywords that are filtered out. */
;*---------------------------------------------------------------------*/
-(define (the-options opt+ . out)
+(define-public (the-options opt+ . out)
(let loop ((opt* opt+)
(res '()))
(cond
@@ -234,7 +233,7 @@
;*---------------------------------------------------------------------*/
;* list-split ... */
;*---------------------------------------------------------------------*/
-(define (list-split l num . fill)
+(define-public (list-split l num . fill)
(let loop ((l l)
(i 0)
(acc '())
diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm
index 0893587..8d51c8c 100644
--- a/src/guile/skribilo/types.scm
+++ b/src/guile/skribilo/types.scm
@@ -34,7 +34,7 @@
<engine> engine? engine-ident engine-format engine-customs
engine-filter engine-symbol-table
<writer> writer? write-object writer-options writer-ident
- writer-before writer-action writer-after
+ writer-before writer-action writer-after writer-class
<processor> processor? processor-combinator processor-engine
<markup> markup? bind-markup! markup-options is-markup?
markup-markup markup-body markup-ident markup-class
diff --git a/src/guile/skribilo/vars.scm b/src/guile/skribilo/vars.scm
index 7e75e0f..4877e78 100644
--- a/src/guile/skribilo/vars.scm
+++ b/src/guile/skribilo/vars.scm
@@ -21,8 +21,7 @@
;;; USA.
-(define-module (skribilo vars)
- #:use-module (srfi srfi-17))
+(define-module (skribilo vars))
;;;
;;; Switches
@@ -31,10 +30,6 @@
(define-public *skribe-warning* 5)
(define-public *load-rc* #t)
-(define-public skribe-debug
- (let ((level 0))
- (getter-with-setter (lambda () level)
- (lambda (val) (set! level val)))))
;;;
;;; PATH variables
diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm
index 1ff0b5b..0f9e053 100644
--- a/src/guile/skribilo/verify.scm
+++ b/src/guile/skribilo/verify.scm
@@ -28,9 +28,9 @@
:export (verify))
(use-modules (skribilo debug)
-; (skribilo engine)
+ (skribilo engine)
(skribilo writer)
-; (skribilo runtime)
+ (skribilo runtime)
(skribilo types)
(skribilo lib) ;; `when', `unless'
(oop goops))
@@ -53,7 +53,7 @@
(for-each (lambda (o)
(if (not (memq o options))
(skribe-error (engine-ident engine)
- (format "Option unsupported: ~a, supported options: ~a" o options)
+ (format #f "option unsupported: ~a, supported options: ~a" o options)
markup)))
required-options)
(slot-set! writer 'verified? #t)))))
@@ -79,7 +79,7 @@
3
markup
'verify
- (format "Engine ~a does not support markup ~a option `~a' -- ~a"
+ (format #f "engine ~a does not support markup ~a option `~a' -- ~a"
(engine-ident engine)
(markup-markup markup)
o
@@ -140,7 +140,7 @@
(skribe-warning
1
node
- (format "Node `~a' forbidden here by ~a engine"
+ (format #f "node `~a' forbidden here by ~a engine"
(markup-markup node)
(engine-ident e))))))))
node))
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
index eeefe8b..abfb10c 100644
--- a/src/guile/skribilo/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -139,8 +139,9 @@
;;; will consider the value of ENGINE to be the first keyword found.
; (let ((e (or engine (default-engine))))
- (let ((e (or (and (list? engine)
- (not (keyword? (car engine))))
+ (let ((e (or (if (and (list? engine) (not (keyword? (car engine))))
+ (car engine)
+ #f)
(default-engine))))
(cond
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 23:14:16 +0000