diff options
Diffstat (limited to 'legacy/bigloo/output.scm')
| -rw-r--r-- | legacy/bigloo/output.scm | 167 |
1 files changed, 0 insertions, 167 deletions
diff --git a/legacy/bigloo/output.scm b/legacy/bigloo/output.scm deleted file mode 100644 index 4bc6271..0000000 --- a/legacy/bigloo/output.scm +++ /dev/null @@ -1,167 +0,0 @@ -;*=====================================================================*/ -;* 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*))))) - - |