summaryrefslogtreecommitdiff
path: root/legacy/bigloo/source.scm
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/source.scm')
-rw-r--r--legacy/bigloo/source.scm238
1 files changed, 238 insertions, 0 deletions
diff --git a/legacy/bigloo/source.scm b/legacy/bigloo/source.scm
new file mode 100644
index 0000000..babadff
--- /dev/null
+++ b/legacy/bigloo/source.scm
@@ -0,0 +1,238 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/source.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Fri Aug 29 07:27:25 2003 */
+;* Last change : Tue Nov 2 14:25:50 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Bigloo handling of Skribe programs. */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module skribe_source
+
+ (include "new.sch")
+
+ (import skribe_types
+ skribe_lib
+ skribe_resolve
+ skribe_eval
+ skribe_api
+ skribe_param)
+
+ (export (source-read-chars::bstring ::bstring ::int ::int ::obj)
+ (source-read-lines::bstring ::bstring ::obj ::obj ::obj)
+ (source-read-definition::bstring ::bstring ::obj ::obj ::obj)
+ (source-fontify ::obj ::obj)
+ (split-string-newline::pair-nil ::bstring)))
+
+;*---------------------------------------------------------------------*/
+;* source-read-lines ... */
+;*---------------------------------------------------------------------*/
+(define (source-read-chars file start stop tab)
+ (define (readl p)
+ (read/rp (regular-grammar ()
+ ((: (* (out #\Newline)) (? #\Newline))
+ (the-string))
+ (else
+ (the-failure)))
+ p))
+ (let ((p (find-file/path file (skribe-source-path))))
+ (if (or (not (string? p)) (not (file-exists? p)))
+ (skribe-error 'source
+ (format "Can't find `~a' source file in path" file)
+ (skribe-source-path))
+ (with-input-from-file p
+ (lambda ()
+ (if (>fx *skribe-verbose* 0)
+ (fprint (current-error-port) " [source file: " p "]"))
+ (let loop ((c -1)
+ (s (readl (current-input-port)))
+ (r '()))
+ (let ((p (input-port-position (current-input-port))))
+ (cond
+ ((eof-object? s)
+ (apply string-append (reverse! r)))
+ ((>=fx p stop)
+ (let* ((len (-fx (-fx stop start) c))
+ (line (untabify (substring s 0 len) tab)))
+ (apply string-append
+ (reverse! (cons line r)))))
+ ((>=fx c 0)
+ (loop (+fx (string-length s) c)
+ (readl (current-input-port))
+ (cons (untabify s tab) r)))
+ ((>=fx p start)
+ (let* ((len (string-length s))
+ (nc (-fx p start)))
+ (if (>fx p stop)
+ (untabify
+ (substring s
+ (-fx len (-fx p start))
+ (-fx (-fx p stop) 1))
+ tab)
+ (loop nc
+ (readl (current-input-port))
+ (list
+ (untabify
+ (substring s
+ (-fx len (-fx p start))
+ len)
+ tab))))))
+ (else
+ (loop c (readl (current-input-port)) r))))))))))
+
+;*---------------------------------------------------------------------*/
+;* source-read-lines ... */
+;*---------------------------------------------------------------------*/
+(define (source-read-lines file start stop tab)
+ (let ((p (find-file/path file (skribe-source-path))))
+ (if (or (not (string? p)) (not (file-exists? p)))
+ (skribe-error 'source
+ (format "Can't find `~a' source file in path" file)
+ (skribe-source-path))
+ (with-input-from-file p
+ (lambda ()
+ (if (>fx *skribe-verbose* 0)
+ (fprint (current-error-port) " [source file: " p "]"))
+ (let ((startl (if (string? start) (string-length start) -1))
+ (stopl (if (string? stop) (string-length stop) -1)))
+ (let loop ((l 1)
+ (armedp (not (or (integer? start)
+ (string? start))))
+ (s (read-line))
+ (r '()))
+ (cond
+ ((or (eof-object? s)
+ (and (integer? stop) (> l stop))
+ (and (string? stop) (substring=? stop s stopl)))
+ (apply string-append (reverse! r)))
+ (armedp
+ (loop (+fx l 1)
+ #t
+ (read-line)
+ (cons* "\n" (untabify s tab) r)))
+ ((and (integer? start) (>= l start))
+ (loop (+fx l 1)
+ #t
+ (read-line)
+ (cons* "\n" (untabify s tab) r)))
+ ((and (string? start) (substring=? start s startl))
+ (loop (+fx l 1) #t (read-line) r))
+ (else
+ (loop (+fx l 1) #f (read-line) r))))))))))
+
+;*---------------------------------------------------------------------*/
+;* untabify ... */
+;*---------------------------------------------------------------------*/
+(define (untabify obj tab)
+ (if (not tab)
+ obj
+ (let ((len (string-length obj))
+ (tabl tab))
+ (let loop ((i 0)
+ (col 1))
+ (cond
+ ((=fx i len)
+ (let ((nlen (-fx col 1)))
+ (if (=fx len nlen)
+ obj
+ (let ((new (make-string col #\space)))
+ (let liip ((i 0)
+ (j 0)
+ (col 1))
+ (cond
+ ((=fx i len)
+ new)
+ ((char=? (string-ref obj i) #\tab)
+ (let ((next-tab (*fx (/fx (+fx col tabl)
+ tabl)
+ tabl)))
+ (liip (+fx i 1)
+ next-tab
+ next-tab)))
+ (else
+ (string-set! new j (string-ref obj i))
+ (liip (+fx i 1) (+fx j 1) (+fx col 1)))))))))
+ ((char=? (string-ref obj i) #\tab)
+ (loop (+fx i 1)
+ (*fx (/fx (+fx col tabl) tabl) tabl)))
+ (else
+ (loop (+fx i 1) (+fx col 1))))))))
+
+;*---------------------------------------------------------------------*/
+;* source-read-definition ... */
+;*---------------------------------------------------------------------*/
+(define (source-read-definition file definition tab lang)
+ (let ((p (find-file/path file (skribe-source-path))))
+ (cond
+ ((not (%language-extractor lang))
+ (skribe-error 'source
+ "The specified language has not defined extractor"
+ lang))
+ ((or (not p) (not (file-exists? p)))
+ (skribe-error 'source
+ (format "Can't find `~a' program file in path" file)
+ (skribe-source-path)))
+ (else
+ (let ((ip (open-input-file p)))
+ (if (>fx *skribe-verbose* 0)
+ (fprint (current-error-port) " [source file: " p "]"))
+ (if (not (input-port? ip))
+ (skribe-error 'source "Can't open file for input" p)
+ (unwind-protect
+ (let ((s ((%language-extractor lang) ip definition tab)))
+ (if (not (string? s))
+ (skribe-error 'source
+ "Can't find definition"
+ definition)
+ s))
+ (close-input-port ip))))))))
+
+;*---------------------------------------------------------------------*/
+;* source-fontify ... */
+;*---------------------------------------------------------------------*/
+(define (source-fontify o language)
+ (define (fontify f o)
+ (cond
+ ((string? o) (f o))
+ ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o))
+ (else o)))
+ (let ((f (%language-fontifier language)))
+ (if (procedure? f)
+ (fontify f o)
+ o)))
+
+;*---------------------------------------------------------------------*/
+;* split-string-newline ... */
+;*---------------------------------------------------------------------*/
+(define (split-string-newline str)
+ (let ((l (string-length str)))
+ (let loop ((i 0)
+ (j 0)
+ (r '()))
+ (cond
+ ((=fx i l)
+ (if (=fx i j)
+ (reverse! r)
+ (reverse! (cons (substring str j i) r))))
+ ((char=? (string-ref str i) #\Newline)
+ (loop (+fx i 1)
+ (+fx i 1)
+ (if (=fx i j)
+ (cons 'eol r)
+ (cons* 'eol (substring str j i) r))))
+ ((and (char=? (string-ref str i) #a013)
+ (<fx (+fx i 1) l)
+ (char=? (string-ref str (+fx i 1)) #\Newline))
+ (loop (+fx i 2)
+ (+fx i 2)
+ (if (=fx i j)
+ (cons 'eol r)
+ (cons* 'eol (substring str j i) r))))
+ (else
+ (loop (+fx i 1) j r))))))
+
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-06 01:35:53 +0000