Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 456 insertions, 0 deletions

diff --git a/src/stklos/runtime.stk b/src/stklos/runtime.stk
new file mode 100644
index 0000000..58d0d45
--- /dev/null
+++ b/src/stklos/runtime.stk
@@ -0,0 +1,456 @@
+;;;;
+;;;; 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 
+
+
+)