aboutsummaryrefslogtreecommitdiff
path: root/legacy/bigloo/output.scm
diff options
context:
space:
mode:
authorLudovic Courtes2006-01-15 22:07:23 +0000
committerLudovic Courtes2006-01-15 22:07:23 +0000
commita427c398fad59341c99a124a6fbd6e0c619ecdb1 (patch)
tree60840e49d2fff01db18f70ffbcdf6d8aeff15783 /legacy/bigloo/output.scm
parent929063bfca2404a927bf0bec047db37d490aa8e1 (diff)
parenta1b1ba4d3edd2a5326dfb82527c4bdcdef29284a (diff)
downloadskribilo-a427c398fad59341c99a124a6fbd6e0c619ecdb1.tar.gz
skribilo-a427c398fad59341c99a124a6fbd6e0c619ecdb1.tar.lz
skribilo-a427c398fad59341c99a124a6fbd6e0c619ecdb1.zip
Removed the Bigloo/STkLos in the `legacy' directory.
Removed the `legacy' directory. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-25
Diffstat (limited to 'legacy/bigloo/output.scm')
-rw-r--r--legacy/bigloo/output.scm167
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*)))))
-
-