Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 196 insertions, 0 deletions

diff --git a/src/bigloo/prog.scm b/src/bigloo/prog.scm
new file mode 100644
index 0000000..baad0f0
--- /dev/null
+++ b/src/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))))))))