diff options
author | Ludovic Court`es | 2005-11-02 10:08:38 +0000 |
---|---|---|
committer | Ludovic Court`es | 2005-11-02 10:08:38 +0000 |
commit | b76d5e1b252967521f210eac10ddbf089dde8c6a (patch) | |
tree | 00fc81c51256991c04799d79a749bbdd5b9fad30 /skribe/src/bigloo/source.scm | |
parent | ba63b8d4780428d9f63f6ace7f49361b77401112 (diff) | |
parent | f553cb65b157b6df9563cefa593902d59301461b (diff) | |
download | skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.tar.gz skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.tar.lz skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.zip |
Cleaned up the source tree and the installation process.
Patches applied:
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-6
Cosmetic changes.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-7
Removed useless files, integrated packages.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-8
Removed useless files, integrated packages.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9
Moved the STkLos and Bigloo code to `legacy'.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-10
Installed Autoconf/Automake machinery. Fixed a few things.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-11
Changes related to source-highlighting and to the manual.
git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-10
Diffstat (limited to 'skribe/src/bigloo/source.scm')
-rw-r--r-- | skribe/src/bigloo/source.scm | 238 |
1 files changed, 0 insertions, 238 deletions
diff --git a/skribe/src/bigloo/source.scm b/skribe/src/bigloo/source.scm deleted file mode 100644 index babadff..0000000 --- a/skribe/src/bigloo/source.scm +++ /dev/null @@ -1,238 +0,0 @@ -;*=====================================================================*/ -;* 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)))))) - |