Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 167 insertions, 0 deletions

diff --git a/skribe/src/bigloo/output.scm b/skribe/src/bigloo/output.scm
new file mode 100644
index 0000000..4bc6271
--- /dev/null
+++ b/skribe/src/bigloo/output.scm
@@ -0,0 +1,167 @@
+;*=====================================================================*/
+;*    serrano/prgm/project/skribe/src/bigloo/output.scm                */
+;*    -------------------------------------------------------------    */
+;*    Author      :  Manuel Serrano                                    */
+;*    Creation    :  Wed Jul 23 12:48:11 2003                          */
+;*    Last change :  Wed Feb  4 10:33:19 2004 (serrano)                */
+;*    Copyright   :  2003-04 Manuel Serrano                            */
+;*    -------------------------------------------------------------    */
+;*    The Skribe engine                                                */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;*    The module                                                       */
+;*---------------------------------------------------------------------*/
+(module skribe_output
+   
+   (include "debug.sch")
+   
+   (import  skribe_types
+	    skribe_lib
+	    skribe_engine
+	    skribe_writer
+	    skribe_eval)
+
+   (export  (output ::obj ::%engine . w)))
+
+;*---------------------------------------------------------------------*/
+;*    output ...                                                       */
+;*---------------------------------------------------------------------*/
+(define (output node e . writer)
+   (with-debug 3 'output
+      (debug-item "node=" node " " (if (markup? node) (markup-markup node) ""))
+      (debug-item "writer=" writer)
+      (if (pair? writer)
+	  (cond
+	     ((%writer? (car writer))
+	      (out/writer node e (car writer)))
+	     ((not (car writer))
+	      (skribe-error 'output 
+			    (format "Illegal `~a' user writer" (%engine-ident e))
+			    (if (markup? node) (%markup-markup node) node)))
+	     (else
+	      (skribe-error 'output "Illegal user writer" (car writer))))
+	  (out node e))))
+       
+;*---------------------------------------------------------------------*/
+;*    out/writer ...                                                   */
+;*---------------------------------------------------------------------*/
+(define (out/writer n e w)
+   (with-debug 5 'out/writer
+      (debug-item "n=" (find-runtime-type n)
+		  " " (if (markup? n) (markup-markup n) ""))
+      (debug-item "e=" (%engine-ident e))
+      (debug-item "w=" (%writer-ident w))
+      (if (%writer? w)
+	  (with-access::%writer w (before action after)
+	     (invoke before n e)
+	     (invoke action n e)
+	     (invoke after n e)))))
+   
+;*---------------------------------------------------------------------*/
+;*    out ...                                                          */
+;*---------------------------------------------------------------------*/
+(define-generic (out node e::%engine)
+   (cond
+      ((pair? node)
+       (out* node e))
+      ((string? node)
+       (let ((f (%engine-filter e)))
+	  (if (procedure? f)
+	      (display (f node))
+	      (display node))))
+      ((number? node)
+       (display node))
+      (else
+       #f)))
+
+;*---------------------------------------------------------------------*/
+;*    out ::%processor ...                                             */
+;*---------------------------------------------------------------------*/
+(define-method (out n::%processor e::%engine)
+   (with-access::%processor n (combinator engine body procedure)
+      (let ((newe (processor-get-engine combinator engine e)))
+	 (out (procedure body newe) newe))))
+
+;*---------------------------------------------------------------------*/
+;*    out ::%command ...                                               */
+;*---------------------------------------------------------------------*/
+(define-method (out node::%command e::%engine)
+   (with-access::%command node (fmt body)
+      (let ((lb (length body))
+	    (lf (string-length fmt)))
+	 (define (loops i n)
+	    (if (= i lf)
+		(begin
+		   (if (> n 0)
+		       (if (<= n lb)
+			   (output (list-ref body (- n 1)) e)
+			   (skribe-error '!
+					 "Too few arguments provided"
+					 node)))
+		   lf)
+		(let ((c (string-ref fmt i)))
+		   (cond
+		      ((char=? c #\$)
+		       (display "$")
+		       (+ 1 i))
+		      ((not (char-numeric? c))
+		       (cond
+			  ((= n 0)
+			   i)
+			  ((<= n lb)
+			   (output (list-ref body (- n 1)) e)
+			   i)
+			  (else
+			   (skribe-error '!
+					 "Too few arguments provided"
+					 node))))
+		      (else
+		       (loops (+ i 1)
+			      (+ (- (char->integer c)
+				    (char->integer #\0))
+				 (* 10 n))))))))
+	 (let loop ((i 0))
+	    (cond
+	       ((= i lf)
+		#f)
+	       ((not (char=? (string-ref fmt i) #\$))
+		(display (string-ref fmt i))
+		(loop (+ i 1)))
+	       (else
+		(loop (loops (+ i 1) 0))))))))
+
+;*---------------------------------------------------------------------*/
+;*    out ::%handle ...                                                */
+;*---------------------------------------------------------------------*/
+(define-method (out node::%handle e::%engine)
+   #unspecified)
+
+;*---------------------------------------------------------------------*/
+;*    out ::%unresolved ...                                            */
+;*---------------------------------------------------------------------*/
+(define-method (out node::%unresolved e::%engine)
+   (error 'output "Orphan unresolved" node))
+
+;*---------------------------------------------------------------------*/
+;*    out ::%markup ...                                                */
+;*---------------------------------------------------------------------*/
+(define-method (out node::%markup e::%engine)
+   (let ((w (lookup-markup-writer node e)))
+      (if (writer? w)
+	  (out/writer node e w)
+	  (output (%markup-body node) e))))
+
+;*---------------------------------------------------------------------*/
+;*    out* ...                                                         */
+;*---------------------------------------------------------------------*/
+(define (out* n+ e)
+   (let loop ((n* n+))
+      (cond
+	 ((pair? n*)
+	  (out (car n*) e)
+	  (loop (cdr n*)))
+	 ((not (null? n*))
+	  (error 'output "Illegal argument" n*)))))
+
+