Merge from lcourtes@laas.fr--2005-libre

Patches applied:

 * lcourtes@laas.fr--2005-libre/skribilo--engine-classes--1.2  (patch 1-6)

   - Preliminary support for engine classes (not working).
   - Fixed creation of engines from an engine class.
   - Tolerate engine instances in `lookup-engine-class'.
   - `base' engine: tolerate engine classes and instances in `processor'.
   - `slide' package: use the native APIs.
   - doc: Started documenting the engine and engine classes.

git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--engine-classes--1.2--patch-2

3 files changed, 60 insertions, 36 deletions

diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index 0622e11..b1e4235 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -107,23 +107,10 @@
   (customs		:init-keyword :custom		:init-value '())
   (symbol-table		:init-keyword :symbol-table	:init-value '()))
 
-(define-class <engine> ()
+(define-class <engine> (<object>)
   (customs	:init-keyword :customs	:init-value '())
   :metaclass <engine-class>)
 
-(define-method (compute-cpl (class <engine-class>))
-  ;; Automatically set the class precedence list of <engine> subclasses.
-  (format (current-error-port) "computing CPL for ~a~%" class)
-  (list class <engine> <top>))
-
-(define-method (initialize (engine-class <engine-class>) . args)
-  ;; Set the name of <engine> subclasses.
-  (let ((result (next-method))
-	(ident (slot-ref engine-class 'ident)))
-    (slot-set! engine-class 'name
-	       (symbol-append '<engine: ident '>))
-    result))
-
 
 (define %format format)
 (define* (make-engine-class ident :key (version 'unspecified)
@@ -133,7 +120,11 @@
 				       (symbol-table '())
 				       (custom '())
 				       (info '()))
-  (let ((e (make <engine-class>
+  ;; We use `make-class' from `(oop goops)' (currently undocumented).
+  (let ((e (make-class (list <engine>) '()
+             :metaclass <engine-class>
+             :name (symbol-append '<engine: ident '>)
+
 	     :ident ident :version version :format format
 	     :filter filter :delegate delegate
 	     :symbol-table symbol-table
@@ -169,33 +160,40 @@
 (define (engine? obj)
   (is-a? obj <engine>))
 
+(define (engine-class e)
+  (and (engine? e) (class-of e)))
+
 ;; A mapping of engine classes to hooks.
 (define %engine-instantiate-hook (make-hash-table))
 
-(define-method (initialize (engine <engine>) . args)
-  (format (current-error-port) "initializing engine ~a~%" engine)
-  engine)
-
 (define-method (make-instance (class <engine-class>) . args)
+  (define (initialize-engine! engine)
+    ;; Automatically initialize the `customs' slot of the newly created
+    ;; engine.
+    (let ((init-values (engine-class-customs class)))
+      (slot-set! engine 'customs (map list-copy init-values))
+      engine))
+
   (format #t "making engine of class ~a~%" class)
   (let ((engine (next-method)))
     (if (engine? engine)
-	(let ((hook (hashq-ref %engine-instantiate-hook engine-class)))
+	(let ((hook (hashq-ref %engine-instantiate-hook class)))
 	  (format (current-error-port) "engine made: ~a~%" engine)
+          (initialize-engine! engine)
 	  (if (hook? hook)
 	      (run-hook hook engine class))
 	  engine)
 	engine)))
 
 (define (make-engine engine-class)
-  (make engine-class
-    :customs (list-copy (slot-ref engine-class 'customs))))
+  ;; Instantiate ENGINE-CLASS.
+  (make engine-class))
+
 
 ;; Convenience functions.
 
 (define (engine-ident obj) (engine-class-ident (engine-class obj)))
 (define (engine-format obj) (engine-class-format (engine-class obj)))
-;;(define (engine-customs obj) (engine-class-customs (engine-class obj)))
 (define (engine-filter obj) (engine-class-filter (engine-class obj)))
 (define (engine-symbol-table obj)
   (engine-class-symbol-table (engine-class obj)))
@@ -209,6 +207,11 @@
 	(string=? fmt (engine-format e)))))
 
 
+
+;;;
+;;; Writers.
+;;;
+
 (define (engine-class-add-writer! e ident pred upred opt before action
 				  after class valid)
   ;; Add a writer to engine class E.  If IDENT is a symbol, then it should
@@ -272,8 +275,7 @@
 ;;;
 (define (copy-engine e)
   (let ((new (shallow-clone e)))
-    (slot-set! new 'class   (engine-class e))
-    (slot-set! new 'customs (list-copy (slot-ref e 'customs)))
+    (slot-set! new 'customs (map list-copy (slot-ref e 'customs)))
     new))
 
 (define* (copy-engine-class ident e :key (version 'unspecified)
@@ -362,9 +364,15 @@ otherwise the requested engine is returned."
      (let* ((engine (symbol-append id '-engine))
 	    (m (resolve-module (engine-id->module-name id))))
        (if (module-bound? m engine)
-	   (let ((e (module-ref m engine)))
-	     (if e (consume-load-hook! id))
-	     e)
+	   (let* ((e (module-ref m engine))
+                  ;; We have to have this thin compatibility layer here.
+                  (c (cond ((engine-class? e) e)
+                           ((engine? e) (engine-class e))
+                           (else
+                            (skribe-error 'lookup-engine-class
+                                          "not an engine class" e)))))
+	     (if c (consume-load-hook! id))
+	     c)
 	   (error "no such engine" id)))))
 
 
diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm
index bbb2a62..53f9e5c 100644
--- a/src/guile/skribilo/package/base.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -30,7 +30,7 @@
   :use-module (skribilo utils keywords)
   :autoload   (srfi srfi-1)        (every any filter)
   :autoload   (skribilo evaluator) (include-document)
-  :autoload   (skribilo engine)    (engine?)
+  :autoload   (skribilo engine)    (engine? engine-class?)
 
   ;; optional ``sub-packages''
   :autoload   (skribilo biblio)    (default-bib-table resolve-bib
@@ -896,7 +896,7 @@
    (cond
       ((and combinator (not (procedure? combinator)))
        (skribe-error 'processor "Combinator not a procedure" combinator))
-      ((and engine (not (engine? engine)))
+      ((and engine (not (or (engine? engine) (engine-class? engine))))
        (skribe-error 'processor "Illegal engine" engine))
       ((and procedure
 	    (or (not (procedure? procedure))
@@ -911,7 +911,9 @@
       (else
        (new processor
 	  (combinator combinator)
-	  (engine engine)
+	  (engine (if (engine-class? engine)
+                      (make-engine engine)
+                      engine))
 	  (procedure (or procedure (lambda (n e) n)))
 	  (body (the-body opts))))))
 
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index 12955ce..e25e222 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -20,13 +20,27 @@
 ;;; USA.
 
 
-(define-skribe-module (skribilo package slide))
+(define-module (skribilo package slide)
+  :use-module (skribilo reader)
+  :use-module (skribilo utils syntax)
 
+  :use-module (skribilo lib)
+  :use-module (skribilo ast)
+  :use-module (skribilo engine)
+  :use-module (skribilo evaluator) ;; `*load-options*'
+  :use-module (skribilo package base)
 
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 optargs))
+
+(fluid-set! current-reader (make-reader 'skribe))
+
+
+
 ;*---------------------------------------------------------------------*/
 ;*    slide-options                                                    */
 ;*---------------------------------------------------------------------*/
-(define-public &slide-load-options (skribe-load-options))
+(define-public &slide-load-options (*load-options*))
 
 
 ;*---------------------------------------------------------------------*/
@@ -49,7 +63,7 @@
    (let ((s (new container
 	       (markup 'slide)
 	       (ident (if (not ident)
-			  (symbol->string (gensym 'slide))
+			  (symbol->string (gensym "slide"))
 			  ident))
 	       (class class)
 	       (required-options '(:title :number :toc))
@@ -231,7 +245,7 @@
    (new container
       (markup 'slide-topic)
       (required-options '(:title :outline?))
-      (ident (or ident (symbol->string (gensym 'slide-topic))))
+      (ident (or ident (symbol->string (gensym "slide-topic"))))
       (options (the-options opt))
       (body (the-body opt))))
 
@@ -244,7 +258,7 @@
    (new container
       (markup 'slide-subtopic)
       (required-options '(:title :outline?))
-      (ident (or ident (symbol->string (gensym 'slide-subtopic))))
+      (ident (or ident (symbol->string (gensym "slide-subtopic"))))
       (options (the-options opt))
       (body (the-body opt))))