diff options
Diffstat (limited to 'legacy/bigloo/prog.scm')
| -rw-r--r-- | legacy/bigloo/prog.scm | 196 |
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)))))))) |