From d4360259d60722eaa175a483f792fce7b8c66d97 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 11 Oct 2006 07:43:47 +0000 Subject: slide: Propagate the `outline?' parameter in `slide-(sub)?topic'. * src/guile/skribilo/package/slide.scm (slide-topic): Propagate the `outline?' parameter as an option. (slide-subtopic): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1 --- skribe/src/bigloo/lib.bgl | 340 ---------------------------------------------- 1 file changed, 340 deletions(-) delete mode 100644 skribe/src/bigloo/lib.bgl (limited to 'skribe/src/bigloo/lib.bgl') diff --git a/skribe/src/bigloo/lib.bgl b/skribe/src/bigloo/lib.bgl deleted file mode 100644 index 6dd6d37..0000000 --- a/skribe/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! "<" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\>) - (blit-string! ">" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\&) - (blit-string! "&" 0 res w 5) - (loop (+fx r 1) (+fx w 5))) - ((#\") - (blit-string! """ 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 ">"))) - 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) - -- cgit v1.2.3