Moved the STkLos and Bigloo code to `legacy'.

Moved the STkLos and Bigloo code from `src' to `legacy'.

git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9

1 files changed, 0 insertions, 340 deletions

diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl
deleted file mode 100644
index 6dd6d37..0000000
--- a/src/bigloo/lib.bgl
+++ /dev/null
@@ -1,340 +0,0 @@
-;*=====================================================================*/
-;*    serrano/prgm/project/skribe/src/bigloo/lib.bgl                   */
-;*    -------------------------------------------------------------    */
-;*    Author      :  Manuel Serrano                                    */
-;*    Creation    :  Wed Jul 23 12:48:11 2003                          */
-;*    Last change :  Wed Dec  1 14:27:57 2004 (serrano)                */
-;*    Copyright   :  2003-04 Manuel Serrano                            */
-;*    -------------------------------------------------------------    */
-;*    The Skribe runtime (i.e., the style user functions).             */
-;*    -------------------------------------------------------------    */
-;*    Implementation: @label lib@                                      */
-;*    bigloo: @path ../common/lib.scm@                                 */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;*    The module                                                       */
-;*---------------------------------------------------------------------*/
-(module skribe_lib
-   
-   (include "debug.sch")
-   
-   (import  skribe_types
-	    skribe_eval
-	    skribe_param
-	    skribe_output
-	    skribe_engine)
-   
-   (export  (markup-option ::%markup ::obj)
-	    (markup-option-add! ::%markup ::obj ::obj)
-	    (markup-class ::%markup)
-				
-	    (container-env-get ::%container ::symbol)
-	    (container-search-down::pair-nil ::procedure ::%container)
-	    (search-down::pair-nil ::procedure ::obj)
-
-	    (find-markup-ident::pair-nil ::bstring)
-	    
-	    (find-down::pair-nil ::procedure ::obj)
-	    (find1-down::obj ::procedure ::obj)
-	    (find-up::pair-nil ::procedure ::obj)
-	    (find1-up::obj ::procedure ::obj)
-
-	    (ast-document ::%ast)
-	    (ast-chapter ::%ast)
-	    (ast-section ::%ast)
-	    
-	    (the-body ::pair-nil)
-	    (the-options ::pair-nil . rest)
-
-	    (list-split::pair-nil ::pair-nil ::int . ::obj)
-	    
-	    (generic ast->string::bstring ::obj)
-	    
-	    (strip-ref-base ::bstring)
-	    (ast->file-location ::%ast)
-
-	    (convert-image ::bstring ::pair-nil)
-	    
-	    (make-string-replace ::pair-nil)
-	    (string-canonicalize::bstring ::bstring)
-	    (inline unspecified?::bool ::obj)))
-
-;*---------------------------------------------------------------------*/
-;*    markup-option ...                                                */
-;*---------------------------------------------------------------------*/
-(define (markup-option m opt)
-   (if (%markup? m)
-       (with-access::%markup m (options)
-	  (let ((c (assq opt options)))
-	     (and (pair? c) (pair? (cdr c)) (cadr c))))
-       (skribe-type-error 'markup-option "Illegal markup:" m "markup")))
-
-;*---------------------------------------------------------------------*/
-;*    markup-option-add! ...                                           */
-;*---------------------------------------------------------------------*/
-(define (markup-option-add! m opt val)
-   (if (%markup? m)
-       (with-access::%markup m (options)
-	  (set! options (cons (list opt val) options)))
-       (skribe-type-error 'markup-option "Illegal markup:" m "markup")))
-
-;*---------------------------------------------------------------------*/
-;*    markup-class ...                                                 */
-;*---------------------------------------------------------------------*/
-(define (markup-class m)
-   (%markup-class m))
-
-;*---------------------------------------------------------------------*/
-;*    container-env-get ...                                            */
-;*---------------------------------------------------------------------*/
-(define (container-env-get m key)
-   (with-access::%container m (env)
-      (let ((c (assq key env)))
-	 (and (pair? c) (cadr c)))))
-
-;*---------------------------------------------------------------------*/
-;*    strip-ref-base ...                                               */
-;*---------------------------------------------------------------------*/
-(define (strip-ref-base file)
-   (if (not (string? *skribe-ref-base*))
-       file
-       (let ((l (string-length *skribe-ref-base*)))
-	  (cond
-	     ((not (>fx (string-length file) (+fx l 2)))
-	      file)
-	     ((not (substring=? file *skribe-ref-base* l))
-	      file)
-	     ((not (char=? (string-ref file l) (file-separator)))
-	      file)
-	     (else
-	      (substring file (+fx l 1) (string-length file)))))))
-
-;*---------------------------------------------------------------------*/
-;*    ast->file-location ...                                           */
-;*---------------------------------------------------------------------*/
-(define (ast->file-location ast)
-   (let ((l (ast-loc ast)))
-      (if (location? l)
-	  (format "~a:~a" (location-file l) (location-pos l))
-	  "")))
-
-;*---------------------------------------------------------------------*/
-;*    builtin-convert-image ...                                        */
-;*---------------------------------------------------------------------*/
-(define (builtin-convert-image from fmt dir)
-   (let* ((s (suffix from))
-	  (f (string-append (prefix (basename from)) "." fmt))
-	  (to (make-file-name dir f)))
-      (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
-		((>fx *skribe-verbose* 1)
-		 (fprint (current-error-port)
-			 "  [converting image: " from " (" c ")]"))
-		((>fx *skribe-verbose* 0)
-		 (fprint (current-error-port)
-			 "  [converting image: " from "]")))
-	     (if (=fx (system c) 0) to #f))))))
-
-;*---------------------------------------------------------------------*/
-;*    convert-image ...                                                */
-;*---------------------------------------------------------------------*/
-(define (convert-image file formats)
-   (let ((path (find-file/path file (skribe-image-path))))
-      (if (not (string? path))
-	  (skribe-error '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-file-name 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)))))))))))
-
-;*---------------------------------------------------------------------*/
-;*    html-string ...                                                  */
-;*---------------------------------------------------------------------*/
-(define (html-string str)
-   (let ((len (string-length str)))
-      (let loop ((r 0)
-		 (nlen len))
-	 (if (=fx r len)
-	     (if (=fx nlen len)
-		 str
-		 (let ((res (make-string nlen)))
-		    (let loop ((r 0)
-			       (w 0))
-		       (if (=fx w nlen)
-			   res
-			   (let ((c (string-ref-ur str r)))
-			      (case c
-				 ((#\<)
-				  (blit-string! "&lt;" 0 res w 4)
-				  (loop (+fx r 1) (+fx w 4)))
-				 ((#\>)
-				  (blit-string! "&gt;" 0 res w 4)
-				  (loop (+fx r 1) (+fx w 4)))
-				 ((#\&)
-				  (blit-string! "&amp;" 0 res w 5)
-				  (loop (+fx r 1) (+fx w 5)))
-				 ((#\")
-				  (blit-string! "&quot;" 0 res w 6)
-				  (loop (+fx r 1) (+fx w 6)))
-				 (else
-				  (string-set! res w c)
-				  (loop (+fx r 1) (+fx w 1)))))))))
-	     (case (string-ref-ur str r)
-		((#\< #\>)
-		 (loop (+fx r 1) (+fx nlen 3)))
-		((#\&)
-		 (loop (+fx r 1) (+fx nlen 4)))
-		((#\")
-		 (loop (+fx r 1) (+fx nlen 5)))
-		(else
-		 (loop (+fx r 1) nlen)))))))
-
-;*---------------------------------------------------------------------*/
-;*    make-generic-string-replace ...                                  */
-;*---------------------------------------------------------------------*/
-(define (make-generic-string-replace lst)
-   (lambda (str)
-      (let ((len (string-length str)))
-	 (let loop ((r 0)
-		    (nlen len))
-	    (if (=fx r len)
-		(let ((res (make-string nlen)))
-		   (let loop ((r 0)
-			      (w 0))
-		      (if (=fx w nlen)
-			  res
-			  (let* ((c (string-ref-ur str r))
-				 (p (assq c lst)))
-			     (if (pair? p)
-				 (let ((pl (string-length (cadr p))))
-				    (blit-string! (cadr p) 0 res w pl)
-				    (loop (+fx r 1) (+fx w pl)))
-				 (begin
-				    (string-set! res w c)
-				    (loop (+fx r 1) (+fx w 1))))))))
-		(let* ((c (string-ref-ur str r))
-		       (p (assq c lst)))
-		   (if (pair? p)
-		       (loop (+fx r 1)
-			     (+fx nlen (-fx (string-length (cadr p)) 1)))
-		       (loop (+fx r 1)
-			     nlen))))))))
-
-;*---------------------------------------------------------------------*/
-;*    make-string-replace ...                                          */
-;*---------------------------------------------------------------------*/
-(define (make-string-replace lst)
-   (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
-      (cond
-	 ((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
-	  html-string)
-	 (else
-	  (make-generic-string-replace lst)))))
-
-;*---------------------------------------------------------------------*/
-;*    ast->string ...                                                  */
-;*---------------------------------------------------------------------*/
-(define-generic (ast->string ast)
-   (cond
-      ((string? ast)
-       ast)
-      ((number? ast)
-       (number->string ast))
-      ((pair? ast)
-       (let* ((t (map ast->string ast))
-	      (res (make-string
-		    (apply + -1 (length t) (map string-length t))
-		    #\space)))
-	  (let loop ((t t)
-		     (w 0))
-	     (if (null? t)
-		 res
-		 (let ((l (string-length (car t))))
-		    (blit-string! (car t) 0 res w l)
-		    (loop (cdr t) (+ w l 1)))))))
-      (else
-       "")))
-
-;*---------------------------------------------------------------------*/
-;*    ast->string ::%node ...                                          */
-;*---------------------------------------------------------------------*/
-(define-method (ast->string ast::%node)
-   (ast->string (%node-body ast)))
-
-;*---------------------------------------------------------------------*/
-;*    string-canonicalize ...                                          */
-;*---------------------------------------------------------------------*/
-(define (string-canonicalize old)
-   (let* ((l (string-length old))
-	  (new (make-string l)))
-      (let loop ((r 0)
-		 (w 0)
-		 (s #f))
-	 (cond
-	    ((=fx r l)
-	     (cond
-		((=fx w 0)
-		 "")
-		((char-whitespace? (string-ref new (-fx w 1)))
-		 (substring new 0 (-fx w 1)))
-		((=fx w r)
-		 new)
-		(else
-		 (substring new 0 w))))
-	    ((char-whitespace? (string-ref old r))
-	     (if s
-		 (loop (+fx r 1) w #t)
-		 (begin
-		    (string-set! new w #\-)
-		    (loop (+fx r 1) (+fx w 1) #t))))
-	    ((or (char=? (string-ref old r) #\#)
-		 (char=? (string-ref old r) #\,)
-		 (>= (char->integer (string-ref old r)) #x7f))
-	     (string-set! new w #\-)
-	     (loop (+fx r 1) (+fx w 1) #t))
-	    (else
-	     (string-set! new w (string-ref old r))
-	     (loop (+fx r 1) (+fx w 1) #f))))))
-
-;*---------------------------------------------------------------------*/
-;*    unspecified? ...                                                 */
-;*---------------------------------------------------------------------*/
-(define-inline (unspecified? obj)
-   (eq? obj #unspecified))
-
-;*---------------------------------------------------------------------*/
-;*    base                                                             */
-;*    -------------------------------------------------------------    */
-;*    A base engine must pre-exist before anything is loaded. In       */
-;*    particular, this dummy base engine is used to load the           */
-;*    actual definition of base.                                       */
-;*---------------------------------------------------------------------*/
-(make-engine 'base :version 'bootstrap)
-