summaryrefslogtreecommitdiff
path: root/legacy/stklos/runtime.stk
diff options
context:
space:
mode:
authorLudovic Courtes2006-01-15 09:57:49 +0000
committerLudovic Courtes2006-01-15 09:57:49 +0000
commita1b1ba4d3edd2a5326dfb82527c4bdcdef29284a (patch)
tree60840e49d2fff01db18f70ffbcdf6d8aeff15783 /legacy/stklos/runtime.stk
parentea34b16594933b0d6fa7a85ac5615a718e33c95d (diff)
downloadskribilo-a1b1ba4d3edd2a5326dfb82527c4bdcdef29284a.tar.gz
skribilo-a1b1ba4d3edd2a5326dfb82527c4bdcdef29284a.tar.lz
skribilo-a1b1ba4d3edd2a5326dfb82527c4bdcdef29284a.zip
Removed the Bigloo/STkLos in the `legacy' directory.
Removed the `legacy' directory. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-22
Diffstat (limited to 'legacy/stklos/runtime.stk')
-rw-r--r--legacy/stklos/runtime.stk456
1 files changed, 0 insertions, 456 deletions
diff --git a/legacy/stklos/runtime.stk b/legacy/stklos/runtime.stk
deleted file mode 100644
index 58d0d45..0000000
--- a/legacy/stklos/runtime.stk
+++ /dev/null
@@ -1,456 +0,0 @@
-;;;;
-;;;; runtime.stk -- Skribe runtime system
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; 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 SKRIBE-RUNTIME-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-VERIFY-MODULE SKRIBE-RESOLVE-MODULE
- SKRIBE-OUTPUT-MODULE SKRIBE-EVAL-MODULE)
-
- (export ;; Utilities
- strip-ref-base ast->file-location string-canonicalize
-
- ;; Markup functions
- markup-option markup-option-add! markup-output
-
- ;; Container functions
- container-env-get
-
- ;; Images
- convert-image
-
- ;; String writing
- make-string-replace
-
- ;; AST
- ast->string
- )
-
-;;;; ======================================================================
-;;;;
-;;;; U T I L I T I E S
-;;;;
-;;;; ======================================================================
-(define skribe-load 'function-defined-below)
-
-
-;;FIXME: Remonter cette fonction
-(define (strip-ref-base file)
- (if (not (string? *skribe-ref-base*))
- file
- (let ((l (string-length *skribe-ref-base*)))
- (cond
- ((not (> (string-length file) (+ l 2)))
- file)
- ((not (substring=? file *skribe-ref-base* l))
- file)
- ((not (char=? (string-ref file l) (file-separator)))
- file)
- (else
- (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))
- (new (make-string l)))
- (let loop ((r 0)
- (w 0)
- (s #f))
- (cond
- ((= r l)
- (cond
- ((= w 0)
- "")
- ((char-whitespace? (string-ref new (- w 1)))
- (substring new 0 (- w 1)))
- ((= w r)
- new)
- (else
- (substring new 0 w))))
- ((char-whitespace? (string-ref old r))
- (if s
- (loop (+ r 1) w #t)
- (begin
- (string-set! new w #\-)
- (loop (+ r 1) (+ w 1) #t))))
- ((or (char=? (string-ref old r) #\#)
- (>= (char->integer (string-ref old r)) #x7f))
- (string-set! new w #\-)
- (loop (+ r 1) (+ w 1) #t))
- (else
- (string-set! new w (string-ref old r))
- (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))))
-
-
-;;;; ======================================================================
-;;;;
-;;;; I M A G E S
-;;;;
-;;;; ======================================================================
-(define (builtin-convert-image from fmt dir)
- (let* ((s (suffix from))
- (f (string-append (prefix (basename from)) "." fmt))
- (to (string-append dir "/" f))) ;; FIXME:
- (cond
- ((string=? s fmt)
- to)
- ((file-exists? to)
- to)
- (else
- (let ((c (if (string=? s "fig")
- (string-append "fig2dev -L " fmt " " from " > " to)
- (string-append "convert " from " " to))))
- (cond
- ((> *skribe-verbose* 1)
- (format (current-error-port) " [converting image: ~S (~S)]" from c))
- ((> *skribe-verbose* 0)
- (format (current-error-port) " [converting image: ~S]" from)))
- (and (zero? (system c))
- to))))))
-
-(define (convert-image file formats)
- (let ((path (find-path file (skribe-image-path))))
- (if (not path)
- (skribe-error 'convert-image
- (format "Can't find `~a' image file in path: " file)
- (skribe-image-path))
- (let ((suf (suffix file)))
- (if (member suf formats)
- (let* ((dir (if (string? *skribe-dest*)
- (dirname *skribe-dest*)
- #f)))
- (if dir
- (let ((dest (basename path)))
- (copy-file path (make-path dir dest))
- dest)
- path))
- (let loop ((fmts formats))
- (if (null? fmts)
- #f
- (let* ((dir (if (string? *skribe-dest*)
- (dirname *skribe-dest*)
- "."))
- (p (builtin-convert-image path (car fmts) dir)))
- (if (string? p)
- p
- (loop (cdr fmts)))))))))))
-
-;;;; ======================================================================
-;;;;
-;;;; S T R I N G - W R I T I N G
-;;;;
-;;;; ======================================================================
-
-;;
-;; (define (%make-html-replace)
-;; ;; Ad-hoc version for HTML, a little bit faster than the
-;; ;; make-general-string-replace define later (particularily if there
-;; ;; is nothing to replace since, it does not allocate a new string
-;; (let ((specials (string->regexp "&|\"|<|>")))
-;; (lambda (str)
-;; (if (regexp-match specials str)
-;; (begin
-;; (let ((out (open-output-string)))
-;; (dotimes (i (string-length str))
-;; (let ((ch (string-ref str i)))
-;; (case ch
-;; ((#\") (display "&quot;" out))
-;; ((#\&) (display "&amp;" out))
-;; ((#\<) (display "&lt;" out))
-;; ((#\>) (display "&gt;" out))
-;; (else (write-char ch out)))))
-;; (get-output-string out)))
-;; str))))
-
-
-(define (%make-general-string-replace lst)
- ;; The general version
- (lambda (str)
- (let ((out (open-output-string)))
- (dotimes (i (string-length str))
- (let* ((ch (string-ref str i))
- (res (assq ch lst)))
- (display (if res (cadr res) ch) out)))
- (get-output-string out))))
-
-
-(define (make-string-replace lst)
- (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
- (cond
- ((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
- string->html)
- (else
- (%make-general-string-replace lst)))))
-
-
-
-
-;;;; ======================================================================
-;;;;
-;;;; 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)))
-
-
-;;NEW ;;
-;;NEW ;; AST-PARENT
-;;NEW ;;
-;;NEW (define (ast-parent n)
-;;NEW (slot-ref n 'parent))
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-PARENT
-;;NEW ;;
-;;NEW (define (markup-parent m)
-;;NEW (let ((p (slot-ref m 'parent)))
-;;NEW (if (eq? p 'unspecified)
-;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m)
-;;NEW p)))
-;;NEW
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-DOCUMENT
-;;NEW ;;
-;;NEW (define (markup-document m)
-;;NEW (let Loop ((p m)
-;;NEW (l #f))
-;;NEW (cond
-;;NEW ((is-markup? p 'document) p)
-;;NEW ((or (eq? p 'unspecified) (not p)) l)
-;;NEW (else (Loop (slot-ref p 'parent) p)))))
-;;NEW
-;;NEW ;;
-;;NEW ;; MARKUP-CHAPTER
-;;NEW ;;
-;;NEW (define (markup-chapter m)
-;;NEW (let loop ((p m)
-;;NEW (l #f))
-;;NEW (cond
-;;NEW ((is-markup? p 'chapter) p)
-;;NEW ((or (eq? p 'unspecified) (not p)) l)
-;;NEW (else (loop (slot-ref p 'parent) p)))))
-;;NEW
-;;NEW
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; H A N D L E S
-;;NEW ;;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (handle-body h)
-;;NEW (slot-ref h 'body))
-;;NEW
-;;NEW
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; F I N D
-;;NEW ;;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (find pred obj)
-;;NEW (with-debug 4 'find
-;;NEW (debug-item "obj=" obj)
-;;NEW (let loop ((obj (if (is-a? obj <container>) (container-body obj) obj)))
-;;NEW (cond
-;;NEW ((pair? obj)
-;;NEW (apply append (map (lambda (o) (loop o)) obj)))
-;;NEW ((is-a? obj <container>)
-;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident))
-;;NEW (if (pred obj)
-;;NEW (list (cons obj (loop (container-body obj))))
-;;NEW '()))
-;;NEW (else
-;;NEW (if (pred obj)
-;;NEW (list obj)
-;;NEW '()))))))
-;;NEW
-
-;;NEW ;;;; ======================================================================
-;;NEW ;;;;
-;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G
-;;NEW ;;;
-;;NEW ;;;; ======================================================================
-;;NEW (define (the-body opt)
-;;NEW ;; Filter out the options
-;;NEW (let loop ((opt* opt)
-;;NEW (res '()))
-;;NEW (cond
-;;NEW ((null? opt*)
-;;NEW (reverse! res))
-;;NEW ((not (pair? opt*))
-;;NEW (skribe-error 'the-body "Illegal body" opt))
-;;NEW ((keyword? (car opt*))
-;;NEW (if (null? (cdr opt*))
-;;NEW (skribe-error 'the-body "Illegal option" (car opt*))
-;;NEW (loop (cddr opt*) res)))
-;;NEW (else
-;;NEW (loop (cdr opt*) (cons (car opt*) res))))))
-;;NEW
-;;NEW
-;;NEW
-;;NEW (define (the-options opt+ . out)
-;;NEW ;; Returns an list made of options.The OUT argument contains
-;;NEW ;; keywords that are filtered out.
-;;NEW (let loop ((opt* opt+)
-;;NEW (res '()))
-;;NEW (cond
-;;NEW ((null? opt*)
-;;NEW (reverse! res))
-;;NEW ((not (pair? opt*))
-;;NEW (skribe-error 'the-options "Illegal options" opt*))
-;;NEW ((keyword? (car opt*))
-;;NEW (cond
-;;NEW ((null? (cdr opt*))
-;;NEW (skribe-error 'the-options "Illegal option" (car opt*)))
-;;NEW ((memq (car opt*) out)
-;;NEW (loop (cdr opt*) res))
-;;NEW (else
-;;NEW (loop (cdr opt*)
-;;NEW (cons (list (car opt*) (cadr opt*)) res)))))
-;;NEW (else
-;;NEW (loop (cdr opt*) res)))))
-;;NEW
-
-
-)