aboutsummaryrefslogtreecommitdiff
path: root/src/bigloo/lib.bgl
diff options
context:
space:
mode:
Diffstat (limited to 'src/bigloo/lib.bgl')
-rw-r--r--src/bigloo/lib.bgl340
1 files changed, 340 insertions, 0 deletions
diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl
new file mode 100644
index 0000000..6dd6d37
--- /dev/null
+++ b/src/bigloo/lib.bgl
@@ -0,0 +1,340 @@
+;*=====================================================================*/
+;* 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)
+
generated by cgit v1.2.3 (git 2.45.0) at 2024-06-28 06:45:53 +0000