diff options
Diffstat (limited to 'legacy/bigloo/output.scm')
| -rw-r--r-- | legacy/bigloo/output.scm | 167 |
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*))))) + + |