aboutsummaryrefslogtreecommitdiff
path: root/legacy/bigloo/lib.bgl
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/lib.bgl')
-rw-r--r--legacy/bigloo/lib.bgl340
1 files changed, 0 insertions, 340 deletions
diff --git a/legacy/bigloo/lib.bgl b/legacy/bigloo/lib.bgl
deleted file mode 100644
index 6dd6d37..0000000
--- a/legacy/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)
-
generated by cgit v1.2.3 (git 2.44.0) at 2024-06-01 12:19:53 +0000