aboutsummaryrefslogtreecommitdiff
path: root/legacy/bigloo/output.scm
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/output.scm')
-rw-r--r--legacy/bigloo/output.scm167
1 files changed, 167 insertions, 0 deletions
diff --git a/legacy/bigloo/output.scm b/legacy/bigloo/output.scm
new file mode 100644
index 0000000..4bc6271
--- /dev/null
+++ b/legacy/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*)))))
+
+