aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo/lib.scm137
-rw-r--r--src/guile/skribilo/location.scm31
-rw-r--r--src/guile/skribilo/package/base.scm50
-rw-r--r--src/guile/skribilo/package/eq.scm4
-rw-r--r--src/guile/skribilo/package/slide.scm22
-rw-r--r--src/guile/skribilo/package/web-book2.scm52
6 files changed, 172 insertions, 124 deletions
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index feb5c8a..96bf483 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,6 +1,6 @@
;;; lib.scm -- Utilities. -*- coding: iso-8859-1 -*-
;;;
-;;; Copyright 2005, 2007, 2009 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2007, 2009, 2012 Ludovic Courtès <ludo@gnu.org>
;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;
;;;
@@ -65,50 +65,97 @@
;;;
;;; DEFINE-MARKUP
;;;
-(define-macro (define-markup bindings . body)
- ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
- ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the
- ;; `:rest' argument can only appear last, which is not what Skribe/DSSSL
- ;; expect, hence `fix-rest-arg'. In addition, all keyword arguments are
- ;; allowed (hence `:allow-other-keys'); they are then checked by `verify'.
- (define (fix-rest-arg args)
- (let loop ((args args)
- (result '())
- (rest-arg '())
- (has-keywords? #f))
- (cond ((null? args)
- (let ((result (if has-keywords?
- (cons :allow-other-keys result)
- result)))
- (append! (reverse! result) rest-arg)))
-
- ((list? args)
- (let ((is-rest-arg? (eq? (car args) :rest))
- (is-keyword? (eq? (car args) :key)))
- (if is-rest-arg?
- (loop (cddr args)
- result
- (list (car args) (cadr args))
- (or has-keywords? is-keyword?))
- (loop (cdr args)
- (cons (car args) result)
- rest-arg
- (or has-keywords? is-keyword?)))))
-
- ((pair? args)
- (loop '()
- (cons (car args) result)
- (list #:rest (cdr args))
- has-keywords?)))))
-
- (let ((name (car bindings))
- (opts (cdr bindings)))
- `(define*-public ,(cons name (fix-rest-arg opts))
- ;; Memorize the invocation location. Note: the invocation depth
- ;; passed to `invocation-location' was determined experimentally and
- ;; may change as Guile changes (XXX).
- (let ((&invocation-location (invocation-location 3)))
- ,@body))))
+
+(define (dsssl->guile-formals args)
+ ;; When using `(ice-9 optargs)', the `:rest' argument can only appear last,
+ ;; which is not what Skribe/DSSSL expect'. In addition, all keyword
+ ;; arguments are allowed (hence `:allow-other-keys'); they are then checked
+ ;; by `verify'. This procedure shuffles ARGS accordingly.
+
+ (let loop ((args args)
+ (result '())
+ (rest-arg '())
+ (has-keywords? #f))
+ (cond ((null? args)
+ (let ((result (if has-keywords?
+ (cons :allow-other-keys result)
+ result)))
+ (append (reverse result) rest-arg)))
+
+ ((list? args)
+ (let ((is-rest-arg? (eq? (car args) :rest))
+ (is-keyword? (eq? (car args) :key)))
+ (if is-rest-arg?
+ (loop (cddr args)
+ result
+ (list (car args) (cadr args))
+ (or has-keywords? is-keyword?))
+ (loop (cdr args)
+ (cons (car args) result)
+ rest-arg
+ (or has-keywords? is-keyword?)))))
+
+ ((pair? args)
+ (loop '()
+ (cons (car args) result)
+ (list :rest (cdr args))
+ has-keywords?)))))
+
+;; `define-markup' is similar to Guile's `lambda*', with DSSSL
+;; keyword style, and a couple other differences handled by
+;; `dsssl->guile-formals'.
+
+(cond-expand
+ (guile-2
+ ;; On Guile 2.0, `define-markup' generates a macro for the markup, such
+ ;; that the macro captures its invocation source location using
+ ;; `current-source-location'.
+
+ (define-syntax define-markup
+ (lambda (s)
+ (syntax-case s ()
+ ;; Note: Use a dotted pair for formals, to allow for dotted forms
+ ;; like: `(define-markup (foo x . rest) ...)'.
+ ((_ (name . formals) body ...)
+ (let ((formals (map (lambda (s)
+ (datum->syntax #'formals s))
+ (dsssl->guile-formals (syntax->datum #'formals))))
+ (internal (symbol-append '% (syntax->datum #'name)
+ '-internal)))
+ (with-syntax ((internal/loc (datum->syntax #'name internal)))
+ #`(begin
+ (define* (internal/loc loc #,@formals)
+ (syntax-parameterize ((&invocation-location
+ (identifier-syntax loc)))
+ body ...))
+ (define-syntax name
+ (lambda (s)
+ (syntax-case s ()
+ ((_ . args)
+ #'(let ((loc (source-properties->location
+ (current-source-location))))
+ (internal/loc loc . args)))
+ (_
+ #'(lambda args
+ (let ((loc (source-properties->location
+ (current-source-location))))
+ (apply internal/loc loc args)))))))
+ internal/loc ; mark it as used
+ (export name)))))))))
+
+ (else ; Guile 1.8
+ ;; On Guile 1.8, a markup is a procedure. Its invocation source location
+ ;; is captured by walking the stack, which is fragile.
+
+ (define-macro (define-markup bindings . body)
+ (let ((name (car bindings))
+ (opts (cdr bindings)))
+ `(define*-public ,(cons name (dsssl->guile-formals opts))
+ ;; Memorize the invocation location. Note: the invocation depth
+ ;; passed to `invocation-location' was determined experimentally and
+ ;; may change as Guile changes (XXX).
+ (let ((&invocation-location (invocation-location 3)))
+ ,@body))))))
;;;
diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm
index 888ea94..048082a 100644
--- a/src/guile/skribilo/location.scm
+++ b/src/guile/skribilo/location.scm
@@ -1,7 +1,7 @@
;;; location.scm -- Skribilo source location.
;;; -*- coding: iso-8859-1 -*-
;;;
-;;; Copyright 2005, 2007, 2009, 2010 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2007, 2009, 2010, 2012 Ludovic Courtès <ludo@gnu.org>
;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;
;;;
@@ -26,7 +26,8 @@
:autoload (srfi srfi-13) (string-prefix?)
:export (<location> location? ast-location
location-file location-line location-column
- invocation-location))
+ invocation-location
+ source-properties->location))
;;; Author: Ludovic Courtès
;;;
@@ -95,17 +96,19 @@
(stack (make-stack #t)))
(and stack
(< depth (stack-length stack))
- (let* ((frame (stack-ref stack depth))
- (source (frame-source frame)))
- (and source
- (let ((file (source-property source 'filename))
- (line (source-property source 'line))
- (col (source-property source 'column)))
- (and file
- (make <location> :file file
- :line (and line (+ line 1))
- :column col))))))))
-
-;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83
+ (let ((frame (stack-ref stack depth)))
+ (source-properties->location (frame-source frame))))))
+
+(define (source-properties->location loc)
+ "Return a location object based on the info in LOC, an alist as returned
+by Guile's `source-properties', `frame-source', `current-source-location',
+etc."
+ (let ((file (assq-ref loc 'filename))
+ (line (assq-ref loc 'line))
+ (col (assq-ref loc 'column)))
+ (and file (make <location>
+ :file file
+ :line (and line (+ line 1))
+ :column (and col (+ col 1))))))
;;; location.scm ends here.
diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm
index 52ce6c9..60eccb1 100644
--- a/src/guile/skribilo/package/base.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -135,6 +135,31 @@
(body #f))))
;*---------------------------------------------------------------------*/
+;* handle ... */
+;*---------------------------------------------------------------------*/
+(define-markup (handle :rest opts
+ :key (ident #f) (class "handle") value section)
+ (let ((body (the-body opts)))
+ (cond
+ (section
+ (error 'handle "Illegal handle `section' option" section)
+ (new unresolved
+ (loc &invocation-location)
+ (proc (lambda (n e env)
+ (let ((s (resolve-ident section 'section n env)))
+ (new handle
+ (loc &invocation-location)
+ (ast s)))))))
+ ((and (pair? body)
+ (null? (cdr body))
+ (markup? (car body)))
+ (new handle
+ (loc &invocation-location)
+ (ast (car body))))
+ (else
+ (skribe-error 'handle "Illegal handle" opts)))))
+
+;*---------------------------------------------------------------------*/
;* toc ... */
;*---------------------------------------------------------------------*/
(define-markup (toc :rest
@@ -964,31 +989,6 @@
(define-processor-markup tex-processor)
;*---------------------------------------------------------------------*/
-;* handle ... */
-;*---------------------------------------------------------------------*/
-(define-markup (handle :rest opts
- :key (ident #f) (class "handle") value section)
- (let ((body (the-body opts)))
- (cond
- (section
- (error 'handle "Illegal handle `section' option" section)
- (new unresolved
- (loc &invocation-location)
- (proc (lambda (n e env)
- (let ((s (resolve-ident section 'section n env)))
- (new handle
- (loc &invocation-location)
- (ast s)))))))
- ((and (pair? body)
- (null? (cdr body))
- (markup? (car body)))
- (new handle
- (loc &invocation-location)
- (ast (car body))))
- (else
- (skribe-error 'handle "Illegal handle" opts)))))
-
-;*---------------------------------------------------------------------*/
;* mailto ... */
;* ------------------------------------------------------------- */
;* doc: */
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
index ee0d40d..781b394 100644
--- a/src/guile/skribilo/package/eq.scm
+++ b/src/guile/skribilo/package/eq.scm
@@ -1,7 +1,7 @@
;;; eq.scm -- An equation formatting package.
;;; -*- coding: iso-8859-1 -*-
;;;
-;;; Copyright 2005, 2006, 2007, 2008, 2009 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2005, 2006, 2007, 2008, 2009, 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;;
;;; This file is part of Skribilo.
@@ -28,7 +28,7 @@
:use-module (skribilo condition)
:use-module (skribilo utils syntax)
:use-module (skribilo utils keywords) ;; `the-options', etc.
- :autoload (skribilo package base) (it symbol sub sup)
+ :use-module (skribilo package base)
:autoload (skribilo engine lout) (lout-illustration)
:autoload (skribilo resolve) (resolve-counter)
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index 60e11b0..9ba0692 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -1,7 +1,7 @@
;;; slide.scm -- Overhead transparencies.
;;; -*- coding: iso-8859-1 -*-
;;;
-;;; Copyright 2006, 2007, 2008, 2009 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2006, 2007, 2008, 2009, 2012 Ludovic Courtès <ludo@gnu.org>
;;; Copyright 2003, 2004 Manuel Serrano
;;;
;;;
@@ -52,6 +52,16 @@
(define %slide-the-counter 0)
;*---------------------------------------------------------------------*/
+;* slide-vspace ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-vspace :rest opt :key (unit 'cm))
+ (new markup
+ (markup 'slide-vspace)
+ (loc &invocation-location)
+ (options `((:unit ,unit) ,@(the-options opt :unit)))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
;* slide ... */
;*---------------------------------------------------------------------*/
(define-markup (slide :rest opt
@@ -152,16 +162,6 @@
(markup 'slide-pause)))
;*---------------------------------------------------------------------*/
-;* slide-vspace ... */
-;*---------------------------------------------------------------------*/
-(define-markup (slide-vspace :rest opt :key (unit 'cm))
- (new markup
- (markup 'slide-vspace)
- (loc &invocation-location)
- (options `((:unit ,unit) ,@(the-options opt :unit)))
- (body (the-body opt))))
-
-;*---------------------------------------------------------------------*/
;* slide-embed ... */
;*---------------------------------------------------------------------*/
(define-markup (slide-embed :rest opt
diff --git a/src/guile/skribilo/package/web-book2.scm b/src/guile/skribilo/package/web-book2.scm
index d44933b..0ce01c5 100644
--- a/src/guile/skribilo/package/web-book2.scm
+++ b/src/guile/skribilo/package/web-book2.scm
@@ -1,7 +1,7 @@
;;; web-book2.scm -- Another web book style.
;;; -*- coding: iso-8859-1 -*-
;;;
-;;; Copyright 2008 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright 2008, 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;;
;;; This file is part of Skribilo.
@@ -22,7 +22,7 @@
(define-module (skribilo package web-book2)
:use-module (skribilo ast)
:use-module (skribilo engine)
- :use-module (skribilo package base)
+ :use-module ((skribilo package base) :renamer (symbol-prefix-proc 'b:))
:use-module (skribilo utils syntax)
:use-module (skribilo utils keywords)
@@ -63,27 +63,27 @@
(define enclose
(if (engine-format? "html" e)
(lambda (toc)
- (! (format #f "\n<div class=\"~a\">\n$1\n</div>" %small-toc-class)
- toc))
+ (b:! (format #f "\n<div class=\"~a\">\n$1\n</div>" %small-toc-class)
+ toc))
(lambda (toc)
- (p :class %small-toc-class toc))))
+ (b:p :class %small-toc-class toc))))
(define (make-uplink)
(let ((parent (ast-parent n)))
(and parent
- (ref :handle (handle parent)
- :text (list (symbol "uparrow") " "
- (markup-option parent :title))))))
+ (b:ref :handle (b:handle parent)
+ :text (list (b:symbol "uparrow") " "
+ (markup-option parent :title))))))
(let ((kids (filter section? (markup-body n))))
(enclose
(list
(and (not (null? kids))
(list "Contents"
- (itemize
+ (b:itemize
(map (lambda (section)
- (item (ref :handle (handle section)
- :text (markup-option section :title))))
+ (b:item (b:ref :handle (b:handle section)
+ :text (markup-option section :title))))
kids))))
(make-uplink)))))
@@ -101,35 +101,33 @@
;;; Overrides.
;;;
-(define %base-package
- (resolve-interface '(skribilo package base)))
-
(define (make-overriding-markup markup)
;; Override the `chapter' markup from the `base' package to allow the
;; production of a small TOC at the beginning of each chapter.
- (let ((real-markup (module-ref %base-package markup)))
- (lambda args
- ;;(format (current-error-port) "in new `~a'~%" markup)
- (if (engine-format? "html")
- (apply real-markup
- (append (concatenate (the-options args))
- (cons (resolve (lambda (n e env)
+ (lambda args
+ ;;(format (current-error-port) "in new `~a'~%" markup)
+ (if (engine-format? "html")
+ (apply markup
+ (append (concatenate (the-options args))
+ (cons (b:resolve (lambda (n e env)
(let ((p (ast-parent n)))
(and (in-file-of-its-own? p e)
(make-small-toc p e)))))
- (the-body args))))
- (apply real-markup args)))))
+ (the-body args))))
+ (apply markup args))))
+
+;; FIXME: With this technique, source location info is lost.
(define chapter
- (make-overriding-markup 'chapter))
+ (make-overriding-markup b:chapter))
(define section
- (make-overriding-markup 'section))
+ (make-overriding-markup b:section))
(define subsection
- (make-overriding-markup 'subsection))
+ (make-overriding-markup b:subsection))
(define subsubsection
- (make-overriding-markup 'subsubsection))
+ (make-overriding-markup b:subsubsection))
;;; web-book2.scm ends here
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-10 07:39:57 +0000