aboutsummaryrefslogtreecommitdiff
path: root/legacy/bigloo/prog.scm
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/prog.scm')
-rw-r--r--legacy/bigloo/prog.scm196
1 files changed, 196 insertions, 0 deletions
diff --git a/legacy/bigloo/prog.scm b/legacy/bigloo/prog.scm
new file mode 100644
index 0000000..baad0f0
--- /dev/null
+++ b/legacy/bigloo/prog.scm
@@ -0,0 +1,196 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/prog.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Wed Aug 27 09:14:28 2003 */
+;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */
+;* Copyright : 2003 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe prog bigloo implementation */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module skribe_prog
+
+ (include "new.sch")
+
+ (import skribe_types
+ skribe_lib
+ skribe_resolve
+ skribe_eval
+ skribe_api)
+
+ (export (make-prog-body ::obj ::obj ::obj ::obj)
+ (resolve-line ::bstring)))
+
+;*---------------------------------------------------------------------*/
+;* *lines* ... */
+;*---------------------------------------------------------------------*/
+(define *lines* (make-hashtable))
+
+;*---------------------------------------------------------------------*/
+;* make-line-mark ... */
+;*---------------------------------------------------------------------*/
+(define (make-line-mark m lnum b)
+ (let* ((ls (integer->string lnum))
+ (n (list (mark ls) b)))
+ (hashtable-put! *lines* m n)
+ n))
+
+;*---------------------------------------------------------------------*/
+;* resolve-line ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-line id)
+ (hashtable-get *lines* id))
+
+;*---------------------------------------------------------------------*/
+;* extract-string-mark ... */
+;*---------------------------------------------------------------------*/
+(define (extract-string-mark line mark regexp)
+ (let ((m (pregexp-match regexp line)))
+ (if (pair? m)
+ (values (substring (car m)
+ (string-length mark)
+ (string-length (car m)))
+ (pregexp-replace regexp line ""))
+ (values #f line))))
+
+;*---------------------------------------------------------------------*/
+;* extract-mark ... */
+;* ------------------------------------------------------------- */
+;* Extract the prog mark from a line. */
+;*---------------------------------------------------------------------*/
+(define (extract-mark line mark regexp)
+ (cond
+ ((not regexp)
+ (values #f line))
+ ((string? line)
+ (extract-string-mark line mark regexp))
+ ((pair? line)
+ (let loop ((ls line)
+ (res '()))
+ (if (null? ls)
+ (values #f line)
+ (multiple-value-bind (m l)
+ (extract-mark (car ls) mark regexp)
+ (if (not m)
+ (loop (cdr ls) (cons l res))
+ (values m (append (reverse! res) (cons l (cdr ls)))))))))
+ ((%node? line)
+ (multiple-value-bind (m l)
+ (extract-mark (%node-body line) mark regexp)
+ (if (not m)
+ (values #f line)
+ (begin
+ (%node-body-set! line l)
+ (values m line)))))
+ (else
+ (values #f line))))
+
+;*---------------------------------------------------------------------*/
+;* split-line ... */
+;*---------------------------------------------------------------------*/
+(define (split-line line)
+ (cond
+ ((string? line)
+ (let ((l (string-length line)))
+ (let loop ((r1 0)
+ (r2 0)
+ (res '()))
+ (cond
+ ((=fx r2 l)
+ (if (=fx r1 r2)
+ (reverse! res)
+ (reverse! (cons (substring line r1 r2) res))))
+ ((char=? (string-ref line r2) #\Newline)
+ (loop (+fx r2 1)
+ (+fx r2 1)
+ (if (=fx r1 r2)
+ (cons 'eol res)
+ (cons* 'eol (substring line r1 r2) res))))
+ (else
+ (loop r1
+ (+fx r2 1)
+ res))))))
+ ((pair? line)
+ (let loop ((ls line)
+ (res '()))
+ (if (null? ls)
+ res
+ (loop (cdr ls) (append res (split-line (car ls)))))))
+ (else
+ (list line))))
+
+;*---------------------------------------------------------------------*/
+;* flat-lines ... */
+;*---------------------------------------------------------------------*/
+(define (flat-lines lines)
+ (apply append (map split-line lines)))
+
+;*---------------------------------------------------------------------*/
+;* collect-lines ... */
+;*---------------------------------------------------------------------*/
+(define (collect-lines lines)
+ (let loop ((lines (flat-lines lines))
+ (res '())
+ (tmp '()))
+ (cond
+ ((null? lines)
+ (reverse! (cons (reverse! tmp) res)))
+ ((eq? (car lines) 'eol)
+ (cond
+ ((null? (cdr lines))
+ (reverse! (cons (reverse! tmp) res)))
+ ((and (null? res) (null? tmp))
+ (loop (cdr lines)
+ res
+ '()))
+ (else
+ (loop (cdr lines)
+ (cons (reverse! tmp) res)
+ '()))))
+ (else
+ (loop (cdr lines)
+ res
+ (cons (car lines) tmp))))))
+
+;*---------------------------------------------------------------------*/
+;* make-prog-body ... */
+;*---------------------------------------------------------------------*/
+(define (make-prog-body src lnum-init ldigit mark)
+ (define (int->str i rl)
+ (let* ((s (integer->string i))
+ (l (string-length s)))
+ (if (= l rl)
+ s
+ (string-append (make-string (- rl l) #\space) s))))
+ (let* ((regexp (and mark
+ (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+"
+ (pregexp-quote mark))))
+ (src (cond
+ ((not (pair? src)) (list src))
+ ((and (pair? (car src)) (null? (cdr src))) (car src))
+ (else src)))
+ (lines (collect-lines src))
+ (lnum (if (integer? lnum-init) lnum-init 1))
+ (s (integer->string (+fx (if (integer? ldigit)
+ (max lnum (expt 10 (-fx ldigit 1)))
+ lnum)
+ (length lines))))
+ (cs (string-length s)))
+ (let loop ((lines lines)
+ (lnum lnum)
+ (res '()))
+ (if (null? lines)
+ (reverse! res)
+ (multiple-value-bind (m l)
+ (extract-mark (car lines) mark regexp)
+ (let ((n (new markup
+ (markup '&prog-line)
+ (ident (and lnum-init (int->str lnum cs)))
+ (body (if m (make-line-mark m lnum l) l)))))
+ (loop (cdr lines)
+ (+ lnum 1)
+ (cons n res))))))))