diff options
Diffstat (limited to 'src/guile/skribilo/runtime.scm')
-rw-r--r-- | src/guile/skribilo/runtime.scm | 234 |
1 files changed, 16 insertions, 218 deletions
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm index 03e515c..d4be2e9 100644 --- a/src/guile/skribilo/runtime.scm +++ b/src/guile/skribilo/runtime.scm @@ -1,8 +1,8 @@ ;;; -;;; runtime.stk -- Skribe runtime system +;;; runtime.scm -- Skribilo runtime system ;;; ;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> -;;; +;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -18,46 +18,22 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -;;; -;;; Author: Erick Gallesio [eg@essi.fr] -;;; Creation date: 13-Aug-2003 18:47 (eg) -;;; Last file update: 15-Nov-2004 14:03 (eg) -;;; (define-module (skribilo runtime) ;; FIXME: Useful procedures are scattered between here and ;; `(skribilo skribe utils)'. :export (;; Utilities - strip-ref-base ast->file-location string-canonicalize - - ;; Markup functions - markup-option markup-option-add! markup-output + strip-ref-base string-canonicalize - ;; Container functions - container-env-get ;; Images convert-image ;; String writing - make-string-replace - - ;; AST - ast-parent ast->string - markup-parent markup-document markup-chapter - - handle-body)) - -(use-modules (skribilo debug) - (skribilo types) - (skribilo verify) - (skribilo resolve) - (skribilo output) - (skribilo evaluator) - (skribilo vars) - (skribilo lib) - (srfi srfi-13) - (oop goops)) + make-string-replace) + :use-module (skribilo parameters) + :use-module (skribilo lib) + :use-module (srfi srfi-13)) @@ -70,13 +46,13 @@ ;;FIXME: Remonter cette fonction (define (strip-ref-base file) - (if (not (string? *skribe-ref-base*)) + (if (not (string? (*ref-base*))) file - (let ((l (string-length *skribe-ref-base*))) + (let ((l (string-length (*ref-base*)))) (cond ((not (> (string-length file) (+ l 2))) file) - ((not (substring=? file *skribe-ref-base* l)) + ((not (substring=? file (*ref-base*) l)) file) ((not (char=? (string-ref file l) (file-separator))) file) @@ -84,12 +60,6 @@ (substring file (+ l 1) (string-length file))))))) -(define (ast->file-location ast) - (let ((l (ast-loc ast))) - (if (location? l) - (format "~a:~a:" (location-file l) (location-line l)) - ""))) - ;; FIXME: Remonter cette fonction (define (string-canonicalize old) (let* ((l (string-length old)) @@ -123,58 +93,6 @@ (loop (+ r 1) (+ w 1) #f)))))) -;;; ====================================================================== -;;; -;;; M A R K U P S F U N C T I O N S -;;; -;;; ====================================================================== -;; (define (markup-output markup -;; :optional (engine #f) -;; :key (predicate #f) -;; (options '()) -;; (before #f) -;; (action #f) -;; (after #f)) -;; (let ((e (or engine (use-engine)))) -;; (cond -;; ((not (is-a? e <engine>)) -;; (skribe-error 'markup-writer "illegal engine" e)) -;; ((and (not before) -;; (not action) -;; (not after)) -;; (%find-markup-output e markup)) -;; (else -;; (let ((mp (if (procedure? predicate) -;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) -;; (lambda (n e) (is-markup? n markup))))) -;; (engine-output e markup mp options -;; (or before (slot-ref e 'default-before)) -;; (or action (slot-ref e 'default-action)) -;; (or after (slot-ref e 'default-after)))))))) - -(define (markup-option m opt) - (if (markup? m) - (let ((c (assq opt (slot-ref m 'options)))) - (and (pair? c) (pair? (cdr c)) - (cadr c))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - - -(define (markup-option-add! m opt val) - (if (markup? m) - (slot-set! m 'options (cons (list opt val) - (slot-ref m 'options))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - -;;; ====================================================================== -;;; -;;; C O N T A I N E R S -;;; -;;; ====================================================================== -(define (container-env-get m key) - (let ((c (assq key (slot-ref m 'env)))) - (and (pair? c) (cadr c)))) - ;;; ====================================================================== ;;; @@ -195,9 +113,9 @@ (string-append "fig2dev -L " fmt " " from " > " to) (string-append "convert " from " " to)))) (cond - ((> *skribe-verbose* 1) + ((> (*verbose*) 1) (format (current-error-port) " [converting image: ~S (~S)]" from c)) - ((> *skribe-verbose* 0) + ((> (*verbose*) 0) (format (current-error-port) " [converting image: ~S]" from))) (and (zero? (system c)) to)))))) @@ -210,8 +128,8 @@ (skribe-image-path)) (let ((suf (suffix file))) (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) #f))) (if dir (let ((dest (basename path))) @@ -221,8 +139,8 @@ (let loop ((fmts formats)) (if (null? fmts) #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) ".")) (p (builtin-convert-image path (car fmts) dir))) (if (string? p) @@ -282,123 +200,3 @@ - -;;; ====================================================================== -;;; -;;; O P T I O N S -;;; -;;; ====================================================================== - -;;NEW ;; -;;NEW ;; GET-OPTION -;;NEW ;; -;;NEW (define (get-option obj key) -;;NEW ;; This function either searches inside an a-list or a markup. -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (pair? (cdr c)) (cadr c)))) -;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key)) -;;NEW (else #f))) -;;NEW -;;NEW ;; -;;NEW ;; BIND-OPTION! -;;NEW ;; -;;NEW (define (bind-option! obj key value) -;;NEW (slot-set! obj 'option* (cons (list key value) -;;NEW (slot-ref obj 'option*)))) -;;NEW -;;NEW -;;NEW ;; -;;NEW ;; GET-ENV -;;NEW ;; -;;NEW (define (get-env obj key) -;;NEW ;; This function either searches inside an a-list or a container -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (cadr c)))) -;;NEW ((container? obj) (get-env (slot-ref obj 'env) key)) -;;NEW (else #f))) -;;NEW - - - - -;;; ====================================================================== -;;; -;;; A S T -;;; -;;; ====================================================================== - -(define-generic ast->string) - - -(define-method (ast->string (ast <top>)) "") -(define-method (ast->string (ast <string>)) ast) -(define-method (ast->string (ast <number>)) (number->string ast)) - -(define-method (ast->string (ast <pair>)) - (let ((out (open-output-string))) - (let Loop ((lst ast)) - (cond - ((null? lst) - (get-output-string out)) - (else - (display (ast->string (car lst)) out) - (unless (null? (cdr lst)) - (display #\space out)) - (Loop (cdr lst))))))) - -(define-method (ast->string (ast <node>)) - (ast->string (slot-ref ast 'body))) - - - -;; -;; AST-PARENT -;; -(define (ast-parent n) - (slot-ref n 'parent)) - -;; -;; MARKUP-PARENT -;; -(define (markup-parent m) - (let ((p (slot-ref m 'parent))) - (if (eq? p 'unspecified) - (skribe-error 'markup-parent "Unresolved parent reference" m) - p))) - - -;; -;; MARKUP-DOCUMENT -;; -(define (markup-document m) - (let Loop ((p m) - (l #f)) - (cond - ((is-markup? p 'document) p) - ((or (eq? p 'unspecified) (not p)) l) - (else (Loop (slot-ref p 'parent) p))))) - -;; -;; -;; MARKUP-CHAPTER -;; -(define (markup-chapter m) - (let loop ((p m) - (l #f)) - (cond - ((is-markup? p 'chapter) p) - ((or (eq? p 'unspecified) (not p)) l) - (else (loop (slot-ref p 'parent) p))))) - - - -;;;; ====================================================================== -;;;; -;;;; H A N D L E S -;;;; -;;;; ====================================================================== -(define (handle-body h) - (slot-ref h 'body)) - |