~ chicken-core (chicken-5) e8e3b17b65f9921c3277f0768e757d2f03121fd9
commit e8e3b17b65f9921c3277f0768e757d2f03121fd9
Author: Felix <bunny351@gmail.com>
AuthorDate: Sun Nov 8 00:13:43 2009 +0100
Commit: Felix <bunny351@gmail.com>
CommitDate: Sun Nov 8 00:13:43 2009 +0100
removed meaningless benchmarks and replaced them with two real ones; also did some test-suite cleanups
diff --git a/Makefile b/Makefile
index f1aaa31a..fb2816e0 100644
--- a/Makefile
+++ b/Makefile
@@ -75,6 +75,4 @@ libs:
$(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) libs
bootstrap:
$(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bootstrap
-bench:
- $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
endif
diff --git a/benchmarks/0.scm b/benchmarks/0.scm
deleted file mode 100644
index 81a44219..00000000
--- a/benchmarks/0.scm
+++ /dev/null
@@ -1,3 +0,0 @@
-;;;; 0.scm - does nothing
-
-(time #f)
diff --git a/benchmarks/binarytrees.scm b/benchmarks/binarytrees.scm
deleted file mode 100644
index 8ed7ce9c..00000000
--- a/benchmarks/binarytrees.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-;;; The Computer Language Benchmarks Game
-;;; http://shootout.alioth.debian.org/
-;;; contributed by Sven Hartrumpf
-
-(define make (lambda (item d)
- (if (= d 0)
- (list 'empty item)
- (let ((item2 (* item 2))
- (d2 (- d 1)))
- (list 'node (make (- item2 1) d2) item (make item2 d2))))))
-
-(define check (lambda (t)
- (if (eq? (car t) 'empty)
- (cadr t)
- (+ (caddr t) (- (check (cadr t)) (check (cadddr t)))))))
-
-(define main (lambda (n)
- (let* ((min-depth 4)
- (max-depth (max (+ min-depth 2) n)))
- (let ((stretch-depth (+ max-depth 1)))
- (display "stretch tree of depth ") (display stretch-depth) (write-char #\tab) (display " check: ") (display (check (make 0 stretch-depth))) (newline))
- (let ((long-lived-tree (make 0 max-depth)))
- (do ((d 4 (+ d 2))
- (c 0 0))
- ((> d max-depth))
- (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))) ; chicken-specific: arithmetic-shift
- (do ((i 0 (+ i 1)))
- ((>= i iterations))
- (set! c (+ c (check (make i d)) (check (make (- i) d)))))
- (display (* 2 iterations)) (write-char #\tab) (display " trees of depth ") (display d) (write-char #\tab) (display " check: ") (display c) (newline)))
- (display "long lived tree of depth ") (display max-depth) (write-char #\tab) (display " check: ") (display (check long-lived-tree)) (newline)))))
-
-(time (main 10))
diff --git a/benchmarks/boyer.scm b/benchmarks/boyer.scm
deleted file mode 100644
index d6118372..00000000
--- a/benchmarks/boyer.scm
+++ /dev/null
@@ -1,284 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: boyer.sc
-;;; Description: The Boyer benchmark
-;;; Author: Bob Boyer
-;;; Created: 5-Apr-85
-;;; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
-;;; 22-Jul-87 (Will Clinger)
-;;; 23-May-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme (but see note)
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Note: This benchmark uses property lists. The procedures that must
-;;; be supplied are get and put, where (put x y z) is equivalent to Common
-;;; Lisp's (setf (get x y) z).
-;;; Note: The Common Lisp version of this benchmark returns the wrong
-;;; answer because it uses the Common Lisp equivalent of memv instead of
-;;; member in the falsep and truep procedures. (The error arose because
-;;; memv is called member in Common Lisp. Don't ask what member is called,
-;;; unless you want to learn about keyword arguments.) This Scheme version
-;;; may run a few percent slower than it would if it were equivalent to
-;;; the Common Lisp version, but it works.
-
-;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
-;;; Fairly CONS intensive.
-
-
-(define unify-subst '()) ;Qobi
-
-(define temp-temp #f) ;Qobi
-
-(define (add-lemma term)
- (cond ((and (pair? term) (eq? (car term) 'equal) (pair? (cadr term)))
- (put! (car (cadr term))
- 'lemmas
- (cons term (or (get (car (cadr term)) 'lemmas) '()))))
- (else (display "ADD-LEMMA did not like term: ") ;Qobi
- (display term) ;Qobi
- (newline)))) ;Qobi
-
-(define (add-lemma-lst lst)
- (cond ((null? lst) #t)
- (else (add-lemma (car lst)) (add-lemma-lst (cdr lst)))))
-
-(define (apply-subst alist term)
- (cond ((not (pair? term))
- (cond ((begin (set! temp-temp (assq term alist)) temp-temp)
- (cdr temp-temp))
- (else term)))
- (else (cons (car term) (apply-subst-lst alist (cdr term))))))
-
-(define (apply-subst-lst alist lst)
- (cond ((null? lst) '()) ;Qobi
- (else (cons (apply-subst alist (car lst))
- (apply-subst-lst alist (cdr lst))))))
-
-(define (falsep x lst) (or (equal? x '(f)) (member x lst)))
-
-(define (one-way-unify term1 term2)
- (set! unify-subst '()) ;Qobi
- (one-way-unify1 term1 term2))
-
-(define (one-way-unify1 term1 term2)
- (cond ((not (pair? term2))
- (cond ((begin (set! temp-temp (assq term2 unify-subst)) temp-temp)
- (equal? term1 (cdr temp-temp)))
- (else (set! unify-subst (cons (cons term2 term1) unify-subst))
- #t)))
- ((not (pair? term1)) #f)
- ((eq? (car term1) (car term2))
- (one-way-unify1-lst (cdr term1) (cdr term2)))
- (else #f)))
-
-(define (one-way-unify1-lst lst1 lst2)
- (cond ((null? lst1) #t)
- ((one-way-unify1 (car lst1) (car lst2))
- (one-way-unify1-lst (cdr lst1) (cdr lst2)))
- (else #f)))
-
-(define (rewrite term)
- (cond ((not (pair? term)) term)
- (else (rewrite-with-lemmas
- (cons (car term) (rewrite-args (cdr term)))
- (or (get (car term) 'lemmas) '())))))
-
-(define (rewrite-args lst)
- (cond ((null? lst) '()) ;Qobi
- (else (cons (rewrite (car lst)) (rewrite-args (cdr lst))))))
-
-(define (rewrite-with-lemmas term lst)
- (cond ((null? lst) term)
- ((one-way-unify term (cadr (car lst)))
- (rewrite (apply-subst unify-subst (caddr (car lst)))))
- (else (rewrite-with-lemmas term (cdr lst)))))
-
-(define (setup)
- (add-lemma-lst
- '((equal (compile form) (reverse (codegen (optimize form) (nil))))
- (equal (eqp x y) (equal (fix x) (fix y)))
- (equal (greaterp x y) (lessp y x))
- (equal (lesseqp x y) (not (lessp y x)))
- (equal (greatereqp x y) (not (lessp x y)))
- (equal (boolean x) (or (equal x (t)) (equal x (f))))
- (equal (iff x y) (and (implies x y) (implies y x)))
- (equal (even1 x) (if (zerop x) (t) (odd (sub1 x)))) ;Qobi
- (equal (countps- l pred) (countps-loop l pred (zero)))
- (equal (fact- i) (fact-loop i (one)))
- (equal (reverse- x) (reverse-loop x (nil)))
- (equal (divides x y) (zerop (remainder y x)))
- (equal (assume-true var alist) (cons (cons var (t)) alist))
- (equal (assume-false var alist) (cons (cons var (f)) alist))
- (equal (tautology-checker x) (tautologyp (normalize x) (nil)))
- (equal (falsify x) (falsify1 (normalize x) (nil)))
- (equal (prime x)
- (and (not (zerop x))
- (not (equal x (add1 (zero))))
- (prime1 x (sub1 x)))) ;Qobi
- (equal (and p q) (if p (if q (t) (f)) (f)))
- (equal (or p q) (if p (t) (if q (t) (f)) (f)))
- (equal (not p) (if p (f) (t)))
- (equal (implies p q) (if p (if q (t) (f)) (t)))
- (equal (fix x) (if (numberp x) x (zero)))
- (equal (if (if a b c) d e) (if a (if b d e) (if c d e)))
- (equal (zerop x) (or (equal x (zero)) (not (numberp x))))
- (equal (plus (plus x y) z) (plus x (plus y z)))
- (equal (equal (plus a b) (zero)) (and (zerop a) (zerop b)))
- (equal (difference x x) (zero))
- (equal (equal (plus a b) (plus a c)) (equal (fix b) (fix c)))
- (equal (equal (zero) (difference x y)) (not (lessp y x)))
- (equal (equal x (difference x y))
- (and (numberp x) (or (equal x (zero)) (zerop y))))
- (equal (meaning (plus-tree (append x y)) a)
- (plus (meaning (plus-tree x) a) (meaning (plus-tree y) a)))
- (equal (meaning (plus-tree (plus-fringe x)) a) (fix (meaning x a)))
- (equal (append (append x y) z) (append x (append y z)))
- (equal (reverse (append a b)) (append (reverse b) (reverse a)))
- (equal (times x (plus y z)) (plus (times x y) (times x z)))
- (equal (times (times x y) z) (times x (times y z)))
- (equal (equal (times x y) (zero)) (or (zerop x) (zerop y)))
- (equal (exec (append x y) pds envrn) (exec y (exec x pds envrn) envrn))
- (equal (mc-flatten x y) (append (flatten x) y))
- (equal (member x (append a b)) (or (member x a) (member x b)))
- (equal (member x (reverse y)) (member x y))
- (equal (length (reverse x)) (length x))
- (equal (member a (intersect b c)) (and (member a b) (member a c)))
- (equal (nth (zero) i) (zero))
- (equal (exp i (plus j k)) (times (exp i j) (exp i k)))
- (equal (exp i (times j k)) (exp (exp i j) k))
- (equal (reverse-loop x y) (append (reverse x) y))
- (equal (reverse-loop x (nil)) (reverse x))
- (equal (count-list z (sort-lp x y))
- (plus (count-list z x) (count-list z y)))
- (equal (equal (append a b) (append a c)) (equal b c))
- (equal (plus (remainder x y) (times y (quotient x y))) (fix x))
- (equal (power-eval (big-plus1 l i base) base)
- (plus (power-eval l base) i))
- (equal (power-eval (big-plus x y i base) base)
- (plus i (plus (power-eval x base) (power-eval y base))))
- (equal (remainder y (one)) (zero))
- (equal (lessp (remainder x y) y) (not (zerop y)))
- (equal (remainder x x) (zero))
- (equal (lessp (quotient i j) i)
- (and (not (zerop i)) (or (zerop j) (not (equal j (one))))))
- (equal (lessp (remainder x y) x)
- (and (not (zerop y)) (not (zerop x)) (not (lessp x y))))
- (equal (power-eval (power-rep i base) base) (fix i))
- (equal (power-eval (big-plus (power-rep i base)
- (power-rep j base)
- (zero)
- base)
- base)
- (plus i j))
- (equal (gcd x y) (gcd y x))
- (equal (nth (append a b) i)
- (append (nth a i) (nth b (difference i (length a)))))
- (equal (difference (plus x y) x) (fix y))
- (equal (difference (plus y x) x) (fix y))
- (equal (difference (plus x y) (plus x z)) (difference y z))
- (equal (times x (difference c w)) (difference (times c x) (times w x)))
- (equal (remainder (times x z) z) (zero))
- (equal (difference (plus b (plus a c)) a) (plus b c))
- (equal (difference (add1 (plus y z)) z) (add1 y))
- (equal (lessp (plus x y) (plus x z)) (lessp y z))
- (equal (lessp (times x z) (times y z)) (and (not (zerop z)) (lessp x y)))
- (equal (lessp y (plus x y)) (not (zerop x)))
- (equal (gcd (times x z) (times y z)) (times z (gcd x y)))
- (equal (value (normalize x) a) (value x a))
- (equal (equal (flatten x) (cons y (nil))) (and (nlistp x) (equal x y)))
- (equal (listp (gopher x)) (listp x))
- (equal (samefringe x y) (equal (flatten x) (flatten y)))
- (equal (equal (greatest-factor x y) (zero))
- (and (or (zerop y) (equal y (one))) (equal x (zero))))
- (equal (equal (greatest-factor x y) (one)) (equal x (one)))
- (equal (numberp (greatest-factor x y))
- (not (and (or (zerop y) (equal y (one))) (not (numberp x)))))
- (equal (times-list (append x y)) (times (times-list x) (times-list y)))
- (equal (prime-list (append x y)) (and (prime-list x) (prime-list y)))
- (equal (equal z (times w z))
- (and (numberp z) (or (equal z (zero)) (equal w (one)))))
- (equal (greatereqpr x y) (not (lessp x y)))
- (equal (equal x (times x y))
- (or (equal x (zero)) (and (numberp x) (equal y (one)))))
- (equal (remainder (times y x) y) (zero))
- (equal (equal (times a b) (one))
- (and (not (equal a (zero)))
- (not (equal b (zero)))
- (numberp a)
- (numberp b)
- (equal (sub1 a) (zero)) ;Qobi
- (equal (sub1 b) (zero)))) ;Qobi
- (equal (lessp (length (delete x l)) (length l)) (member x l))
- (equal (sort2 (delete x l)) (delete x (sort2 l)))
- (equal (dsort x) (sort2 x))
- (equal (length
- (cons x1 (cons x2 (cons x3 (cons x4 (cons x5 (cons x6 x7)))))))
- (plus (six) (length x7)))
- (equal (difference (add1 (add1 x)) (two)) (fix x))
- (equal (quotient (plus x (plus x y)) (two)) (plus x (quotient y (two))))
- (equal (sigma (zero) i) (quotient (times i (add1 i)) (two)))
- (equal (plus x (add1 y)) (if (numberp y) (add1 (plus x y)) (add1 x)))
- (equal (equal (difference x y) (difference z y))
- (if (lessp x y)
- (not (lessp y z))
- (if (lessp z y) (not (lessp y x)) (equal (fix x) (fix z)))))
- (equal (meaning (plus-tree (delete x y)) a)
- (if (member x y)
- (difference (meaning (plus-tree y) a) (meaning x a))
- (meaning (plus-tree y) a)))
- (equal (times x (add1 y)) (if (numberp y) (plus x (times x y)) (fix x)))
- (equal (nth (nil) i) (if (zerop i) (nil) (zero)))
- (equal (last (append a b))
- (if (listp b) (last b) (if (listp a) (cons (car (last a)) b) b)))
- (equal (equal (lessp x y) z) (if (lessp x y) (equal t z) (equal f z)))
- (equal (assignment x (append a b))
- (if (assignedp x a) (assignment x a) (assignment x b)))
- (equal (car (gopher x)) (if (listp x) (car (flatten x)) (zero)))
- (equal (flatten (cdr (gopher x)))
- (if (listp x) (cdr (flatten x)) (cons (zero) (nil))))
- (equal (quotient (times y x) y) (if (zerop y) (zero) (fix x)))
- (equal (get j (set i val mem)) (if (eqp j i) val (get j mem))))))
-
-(define (tautologyp x true-lst false-lst)
- (cond ((truep x true-lst) #t)
- ((falsep x false-lst) #f)
- ((not (pair? x)) #f)
- ((eq? (car x) 'if)
- (cond ((truep (cadr x) true-lst)
- (tautologyp (caddr x) true-lst false-lst))
- ((falsep (cadr x) false-lst)
- (tautologyp (cadddr x) true-lst false-lst))
- (else (and (tautologyp (caddr x)
- (cons (cadr x) true-lst)
- false-lst)
- (tautologyp (cadddr x)
- true-lst
- (cons (cadr x) false-lst))))))
- (else #f)))
-
-(define (tautp x) (tautologyp (rewrite x) '() '())) ;Qobi
-
-(define (test)
- (define ans #f)
- (define term #f)
- (set! term
- (apply-subst
- '((x f (plus (plus a b) (plus c (zero))))
- (y f (times (times a b) (plus c d)))
- (z f (reverse (append (append a b) (nil))))
- (u equal (plus a b) (difference x y))
- (w lessp (remainder a b) (member a (length b))))
- '(implies (and (implies x y)
- (and (implies y z) (and (implies z u) (implies u w))))
- (implies x w))))
- (set! ans (tautp term))
- ans)
-
-(define (truep x lst) (or (equal? x '(t)) (member x lst)))
-
-(setup)
-
-(if (not (eq? #t (time (test))))
- (error "wrong result") )
diff --git a/benchmarks/browse.scm b/benchmarks/browse.scm
deleted file mode 100644
index bb433899..00000000
--- a/benchmarks/browse.scm
+++ /dev/null
@@ -1,151 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: browse.sc
-;;; Description: The BROWSE benchmark from the Gabriel tests
-;;; Author: Richard Gabriel
-;;; Created: 8-Apr-85
-;;; Modified: 14-Jun-85 18:44:49 (Bob Shaw)
-;;; 16-Aug-87 (Will Clinger)
-;;; 22-Jan-88 (Will Clinger)
-;;; 24-Mar-96 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme (but see notes below)
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Note: This benchmark has been run only in implementations in which
-;;; the empty list is the same as #f, and may not work if that is not true.
-;;; Note: This benchmark uses property lists. The procedures that must
-;;; be supplied are get and put, where (put x y z) is equivalent to Common
-;;; Lisp's (setf (get x y) z).
-;;; Note: The Common Lisp version assumes that eq works on characters,
-;;; which is not a portable assumption but is true in most implementations.
-;;; This translation makes the same assumption about eq?.
-;;; Note: The gensym procedure was left as in Common Lisp. Most Scheme
-;;; implementations have something similar internally.
-;;; Note: The original benchmark took the car or cdr of the empty list
-;;; 14,600 times. Before explicit tests were added to protect the offending
-;;; calls to car and cdr, MacScheme was spending a quarter of its run time
-;;; in the exception handler recovering from those errors.
-
-; 11/07/00 - felix:
-;
-; - Renamed 'match' to 'bmatch', because there exists a macro-definition of
-; 'match' already.
-
-;;; The next few definitions should be omitted if the Scheme implementation
-;;; already provides them.
-
-(define (append! x y)
- (if (null? x)
- y
- (do ((a x b) (b (cdr x) (cdr b))) ((null? b) (set-cdr! a y) x))))
-
-(define (copy-tree x)
- (if (not (pair? x)) x (cons (copy-tree (car x)) (copy-tree (cdr x)))))
-
-
-;;; BROWSE -- Benchmark to create and browse through
-;;; an AI-like data base of units.
-
-;;; n is # of symbols
-;;; m is maximum amount of stuff on the plist
-;;; npats is the number of basic patterns on the unit
-;;; ipats is the instantiated copies of the patterns
-
-(define *rand* 21)
-
-(define (init n m npats ipats)
- (let ((ipats (copy-tree ipats)))
- (do ((p ipats (cdr p))) ((null? (cdr p)) (set-cdr! p ipats)))
- (do ((n n (- n 1))
- (i m (cond ((zero? i) m) (else (- i 1))))
- (name (gensym) (gensym))
- (a '()))
- ((= n 0) a)
- (set! a (cons name a))
- (do ((i i (- i 1))) ((zero? i)) (put! name (gensym) #f))
- (put! name
- 'pattern
- (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '()))
- ((zero? i) a)
- (set! a (cons (car ipats) a))))
- (do ((j (- m i) (- j 1))) ((zero? j)) (put! name (gensym) #f)))))
-
-(define (browse-random)
- (set! *rand* (remainder (* *rand* 17) 251))
- *rand*)
-
-(define (randomize l)
- (do ((a '())) ((null? l) a)
- (let ((n (remainder (browse-random) (length l))))
- (cond ((zero? n)
- (set! a (cons (car l) a))
- (set! l (cdr l))
- l)
- (else (do ((n n (- n 1)) (x l (cdr x)))
- ((= n 1)
- (set! a (cons (cadr x) a))
- (set-cdr! x (cddr x))
- x)))))))
-
-(define (bmatch pat dat alist)
- (cond ((null? pat) (null? dat))
- ((null? dat) #f) ;Qobi: used to depend on () being false
- ((or (eq? (car pat) '?) (eq? (car pat) (car dat)))
- (bmatch (cdr pat) (cdr dat) alist))
- ((eq? (car pat) '*)
- (or (bmatch (cdr pat) dat alist)
- (bmatch (cdr pat) (cdr dat) alist)
- (bmatch pat (cdr dat) alist)))
- (else (cond ((not (pair? (car pat)))
- (cond ((eq? (string-ref (symbol->string (car pat)) 0) #\?)
- (let ((val (assv (car pat) alist)))
- (cond (val (bmatch (cons (cdr val) (cdr pat))
- dat alist))
- (else (bmatch (cdr pat)
- (cdr dat)
- (cons (cons (car pat)
- (car dat))
- alist))))))
- ((eq? (string-ref (symbol->string (car pat)) 0) #\*)
- (let ((val (assv (car pat) alist)))
- (cond (val (bmatch (append (cdr val) (cdr pat))
- dat alist))
- (else
- (do ((l '()
- (append! l
- (cons (if (null? d)
- '()
- (car d))
- '())))
- (e (cons '() dat) (cdr e))
- (d dat (if (null? d) '() (cdr d))))
- ((or (null? e)
- (bmatch (cdr pat)
- d
- (cons (cons (car pat) l)
- alist)))
- (if (null? e) #f #t)))))))
- ;; Qobi: used to depend of missing ELSE returning #F
- (else #f)))
- (else (and (pair? (car dat))
- (bmatch (car pat) (car dat) alist)
- (bmatch (cdr pat) (cdr dat) alist)))))))
-
-(define (browse)
- (investigate (randomize (init 100 10 4 '((a a a b b b b a a a a a b b a a a)
- (a a b b b b a a (a a) (b b))
- (a a a b (b a) b a b a))))
- '((*a ?b *b ?b a *a a *b *a)
- (*a *b *b *a (*a) (*b))
- (? ? * (b a) * ? ?))))
-
-(define (investigate units pats)
- (do ((units units (cdr units))) ((null? units))
- (do ((pats pats (cdr pats))) ((null? pats))
- (do ((p (get (car units) 'pattern) (cdr p))) ((null? p))
- (bmatch (car pats) (car p) '())))))
-
-
-(time (browse))
diff --git a/benchmarks/conform.scm b/benchmarks/conform.scm
deleted file mode 100644
index be2013d5..00000000
--- a/benchmarks/conform.scm
+++ /dev/null
@@ -1,453 +0,0 @@
-;;; CONFORM -- Type checker, written by Jim Miller.
-
-;;; Functional and unstable
-
-(define (sort-list obj pred)
-
- (define (loop l)
- (if (and (pair? l) (pair? (cdr l)))
- (split-list l '() '())
- l))
-
- (define (split-list l one two)
- (if (pair? l)
- (split-list (cdr l) two (cons (car l) one))
- (merge (loop one) (loop two))))
-
- (define (merge one two)
- (cond ((null? one) two)
- ((pred (car two) (car one))
- (cons (car two)
- (merge (cdr two) one)))
- (else
- (cons (car one)
- (merge (cdr one) two)))))
-
- (loop obj))
-
-;; SET OPERATIONS
-; (representation as lists with distinct elements)
-
-(define (adjoin element set)
- (if (memq element set) set (cons element set)))
-
-(define (eliminate element set)
- (cond ((null? set) set)
- ((eq? element (car set)) (cdr set))
- (else (cons (car set) (eliminate element (cdr set))))))
-
-(define (intersect list1 list2)
- (let loop ((l list1))
- (cond ((null? l) '())
- ((memq (car l) list2) (cons (car l) (loop (cdr l))))
- (else (loop (cdr l))))))
-
-(define (union list1 list2)
- (if (null? list1)
- list2
- (union (cdr list1)
- (adjoin (car list1) list2))))
-
-;; GRAPH NODES
-
-(define make-internal-node vector)
-(define (internal-node-name node) (vector-ref node 0))
-(define (internal-node-green-edges node) (vector-ref node 1))
-(define (internal-node-red-edges node) (vector-ref node 2))
-(define (internal-node-blue-edges node) (vector-ref node 3))
-(define (set-internal-node-name! node name) (vector-set! node 0 name))
-(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges))
-(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges))
-(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges))
-
-(define (make-node name . blue-edges) ; User's constructor
- (let ((name (if (symbol? name) (symbol->string name) name))
- (blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
- (make-internal-node name '() '() blue-edges)))
-
-(define (copy-node node)
- (make-internal-node (name node) '() '() (blue-edges node)))
-
-; Selectors
-
-(define name internal-node-name)
-(define (make-edge-getter selector)
- (lambda (node)
- (if (or (none-node? node) (any-node? node))
- (fatal-error "Can't get edges from the ANY or NONE nodes")
- (selector node))))
-(define red-edges (make-edge-getter internal-node-red-edges))
-(define green-edges (make-edge-getter internal-node-green-edges))
-(define blue-edges (make-edge-getter internal-node-blue-edges))
-
-; Mutators
-
-(define (make-edge-setter mutator!)
- (lambda (node value)
- (cond ((any-node? node) (fatal-error "Can't set edges from the ANY node"))
- ((none-node? node) 'OK)
- (else (mutator! node value)))))
-(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
-(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
-(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
-
-;; BLUE EDGES
-
-(define make-blue-edge vector)
-(define (blue-edge-operation edge) (vector-ref edge 0))
-(define (blue-edge-arg-node edge) (vector-ref edge 1))
-(define (blue-edge-res-node edge) (vector-ref edge 2))
-(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value))
-(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value))
-(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value))
-
-; Selectors
-(define operation blue-edge-operation)
-(define arg-node blue-edge-arg-node)
-(define res-node blue-edge-res-node)
-
-; Mutators
-(define set-arg-node! set-blue-edge-arg-node!)
-(define set-res-node! set-blue-edge-res-node!)
-
-; Higher level operations on blue edges
-
-(define (lookup-op op node)
- (let loop ((edges (blue-edges node)))
- (cond ((null? edges) '())
- ((eq? op (operation (car edges))) (car edges))
- (else (loop (cdr edges))))))
-
-(define (has-op? op node)
- (not (null? (lookup-op op node))))
-
-;; GRAPHS
-
-(define make-internal-graph vector)
-(define (internal-graph-nodes graph) (vector-ref graph 0))
-(define (internal-graph-already-met graph) (vector-ref graph 1))
-(define (internal-graph-already-joined graph) (vector-ref graph 2))
-(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes))
-
-; Constructor
-
-(define (make-graph . nodes)
- (make-internal-graph nodes (make-empty-table) (make-empty-table)))
-
-; Selectors
-
-(define graph-nodes internal-graph-nodes)
-(define already-met internal-graph-already-met)
-(define already-joined internal-graph-already-joined)
-
-; Higher level functions on graphs
-
-(define (add-graph-nodes! graph nodes)
- (set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))
-
-(define (copy-graph g)
- (define (copy-list l) (vector->list (list->vector l)))
- (make-internal-graph
- (copy-list (graph-nodes g))
- (already-met g)
- (already-joined g)))
-
-(define (clean-graph g)
- (define (clean-node node)
- (if (not (or (any-node? node) (none-node? node)))
- (begin
- (set-green-edges! node '())
- (set-red-edges! node '()))))
- (for-each clean-node (graph-nodes g))
- g)
-
-(define (canonicalize-graph graph classes)
- (define (fix node)
- (define (fix-set object selector mutator)
- (mutator object
- (map (lambda (node)
- (find-canonical-representative node classes))
- (selector object))))
- (if (not (or (none-node? node) (any-node? node)))
- (begin
- (fix-set node green-edges set-green-edges!)
- (fix-set node red-edges set-red-edges!)
- (for-each
- (lambda (blue-edge)
- (set-arg-node! blue-edge
- (find-canonical-representative (arg-node blue-edge) classes))
- (set-res-node! blue-edge
- (find-canonical-representative (res-node blue-edge) classes)))
- (blue-edges node))))
- node)
- (define (fix-table table)
- (define (canonical? node) (eq? node (find-canonical-representative node classes)))
- (define (filter-and-fix predicate-fn update-fn list)
- (let loop ((list list))
- (cond ((null? list) '())
- ((predicate-fn (car list))
- (cons (update-fn (car list)) (loop (cdr list))))
- (else (loop (cdr list))))))
- (define (fix-line line)
- (filter-and-fix
- (lambda (entry) (canonical? (car entry)))
- (lambda (entry) (cons (car entry)
- (find-canonical-representative (cdr entry) classes)))
- line))
- (if (null? table)
- '()
- (cons (car table)
- (filter-and-fix
- (lambda (entry) (canonical? (car entry)))
- (lambda (entry) (cons (car entry) (fix-line (cdr entry))))
- (cdr table)))))
- (make-internal-graph
- (map (lambda (class) (fix (car class))) classes)
- (fix-table (already-met graph))
- (fix-table (already-joined graph))))
-
-;; USEFUL NODES
-
-(define none-node (make-node 'none #t))
-(define (none-node? node) (eq? node none-node))
-
-(define any-node (make-node 'any '()))
-(define (any-node? node) (eq? node any-node))
-
-;; COLORED EDGE TESTS
-
-(define (green-edge? from-node to-node)
- (cond ((any-node? from-node) #f)
- ((none-node? from-node) #t)
- ((memq to-node (green-edges from-node)) #t)
- (else #f)))
-
-(define (red-edge? from-node to-node)
- (cond ((any-node? from-node) #f)
- ((none-node? from-node) #t)
- ((memq to-node (red-edges from-node)) #t)
- (else #f)))
-
-;; SIGNATURE
-
-; Return signature (i.e. <arg, res>) given an operation and a node
-
-(define sig
- (let ((none-comma-any (cons none-node any-node)))
- (lambda (op node) ; Returns (arg, res)
- (let ((the-edge (lookup-op op node)))
- (if (not (null? the-edge))
- (cons (arg-node the-edge) (res-node the-edge))
- none-comma-any)))))
-
-; Selectors from signature
-
-(define (arg pair) (car pair))
-(define (res pair) (cdr pair))
-
-;; CONFORMITY
-
-(define (conforms? t1 t2)
- (define nodes-with-red-edges-out '())
- (define (add-red-edge! from-node to-node)
- (set-red-edges! from-node (adjoin to-node (red-edges from-node)))
- (set! nodes-with-red-edges-out
- (adjoin from-node nodes-with-red-edges-out)))
- (define (greenify-red-edges! from-node)
- (set-green-edges! from-node
- (append (red-edges from-node) (green-edges from-node)))
- (set-red-edges! from-node '()))
- (define (delete-red-edges! from-node)
- (set-red-edges! from-node '()))
- (define (does-conform t1 t2)
- (cond ((or (none-node? t1) (any-node? t2)) #t)
- ((or (any-node? t1) (none-node? t2)) #f)
- ((green-edge? t1 t2) #t)
- ((red-edge? t1 t2) #t)
- (else
- (add-red-edge! t1 t2)
- (let loop ((blues (blue-edges t2)))
- (if (null? blues)
- #t
- (let* ((current-edge (car blues))
- (phi (operation current-edge)))
- (and (has-op? phi t1)
- (does-conform
- (res (sig phi t1))
- (res (sig phi t2)))
- (does-conform
- (arg (sig phi t2))
- (arg (sig phi t1)))
- (loop (cdr blues)))))))))
- (let ((result (does-conform t1 t2)))
- (for-each (if result greenify-red-edges! delete-red-edges!)
- nodes-with-red-edges-out)
- result))
-
-(define (equivalent? a b)
- (and (conforms? a b) (conforms? b a)))
-
-;; EQUIVALENCE CLASSIFICATION
-; Given a list of nodes, return a list of equivalence classes
-
-(define (classify nodes)
- (let node-loop ((classes '())
- (nodes nodes))
- (if (null? nodes)
- (map (lambda (class)
- (sort-list class
- (lambda (node1 node2)
- (< (string-length (name node1))
- (string-length (name node2))))))
- classes)
- (let ((this-node (car nodes)))
- (define (add-node classes)
- (cond ((null? classes) (list (list this-node)))
- ((equivalent? this-node (caar classes))
- (cons (cons this-node (car classes))
- (cdr classes)))
- (else (cons (car classes)
- (add-node (cdr classes))))))
- (node-loop (add-node classes)
- (cdr nodes))))))
-
-; Given a node N and a classified set of nodes,
-; find the canonical member corresponding to N
-
-(define (find-canonical-representative element classification)
- (let loop ((classes classification))
- (cond ((null? classes) (fatal-error "Can't classify" element))
- ((memq element (car classes)) (car (car classes)))
- (else (loop (cdr classes))))))
-
-; Reduce a graph by taking only one member of each equivalence
-; class and canonicalizing all outbound pointers
-
-(define (reduce graph)
- (let ((classes (classify (graph-nodes graph))))
- (canonicalize-graph graph classes)))
-
-;; TWO DIMENSIONAL TABLES
-
-(define (make-empty-table) (list 'TABLE))
-(define (lookup table x y)
- (let ((one (assq x (cdr table))))
- (if one
- (let ((two (assq y (cdr one))))
- (if two (cdr two) #f))
- #f)))
-(define (insert! table x y value)
- (define (make-singleton-table x y)
- (list (cons x y)))
- (let ((one (assq x (cdr table))))
- (if one
- (set-cdr! one (cons (cons y value) (cdr one)))
- (set-cdr! table (cons (cons x (make-singleton-table y value))
- (cdr table))))))
-
-;; MEET/JOIN
-; These update the graph when computing the node for node1*node2
-
-(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2)
- (make-blue-edge op
- (arg-fn graph (arg sig1) (arg sig2))
- (res-fn graph (res sig1) (res sig2))))
-
-(define (meet graph node1 node2)
- (cond ((eq? node1 node2) node1)
- ((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize
- ((none-node? node1) node2)
- ((none-node? node2) node1)
- ((lookup (already-met graph) node1 node2)) ; return it if found
- ((conforms? node1 node2) node2)
- ((conforms? node2 node1) node1)
- (else
- (let ((result
- (make-node (string-append "(" (name node1) " ^ " (name node2) ")"))))
- (add-graph-nodes! graph result)
- (insert! (already-met graph) node1 node2 result)
- (set-blue-edges! result
- (map
- (lambda (op)
- (blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
- (intersect (map operation (blue-edges node1))
- (map operation (blue-edges node2)))))
- result))))
-
-(define (join graph node1 node2)
- (cond ((eq? node1 node2) node1)
- ((any-node? node1) node2)
- ((any-node? node2) node1)
- ((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize
- ((lookup (already-joined graph) node1 node2)) ; return it if found
- ((conforms? node1 node2) node1)
- ((conforms? node2 node1) node2)
- (else
- (let ((result
- (make-node (string-append "(" (name node1) " v " (name node2) ")"))))
- (add-graph-nodes! graph result)
- (insert! (already-joined graph) node1 node2 result)
- (set-blue-edges! result
- (map
- (lambda (op)
- (blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
- (union (map operation (blue-edges node1))
- (map operation (blue-edges node2)))))
- result))))
-
-;; MAKE A LATTICE FROM A GRAPH
-
-(define (make-lattice g print?)
- (define (step g)
- (let* ((copy (copy-graph g))
- (nodes (graph-nodes copy)))
- (for-each (lambda (first)
- (for-each (lambda (second)
- (meet copy first second) (join copy first second))
- nodes))
- nodes)
- copy))
- (define (loop g count)
- (if print? (display count))
- (let ((lattice (step g)))
- (if print? (begin (display " -> ") (display (length (graph-nodes lattice)))))
- (let* ((new-g (reduce lattice))
- (new-count (length (graph-nodes new-g))))
- (if (= new-count count)
- (begin
- (if print? (newline))
- new-g)
- (begin
- (if print? (begin (display " -> ") (display new-count) (newline)))
- (loop new-g new-count))))))
- (let ((graph
- (apply make-graph
- (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
- (loop graph (length (graph-nodes graph)))))
-
-;; DEBUG and TEST
-
-(define a '())
-(define b '())
-(define c '())
-(define d '())
-
-(define (setup)
- (set! a (make-node 'a))
- (set! b (make-node 'b))
- (set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
- (set-blue-edges! b (list (make-blue-edge 'phi any-node a)
- (make-blue-edge 'theta any-node b)))
- (set! c (make-node "c"))
- (set! d (make-node "d"))
- (set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
- (set-blue-edges! d (list (make-blue-edge 'phi any-node c)
- (make-blue-edge 'theta any-node d)))
- '(made a b c d))
-
-(define (test)
- (setup)
- (map name
- (graph-nodes (make-lattice (make-graph a b c d any-node none-node) #f))))
-
-(time (test))
diff --git a/benchmarks/cpstak.scm b/benchmarks/cpstak.scm
deleted file mode 100644
index 0c6ea7b7..00000000
--- a/benchmarks/cpstak.scm
+++ /dev/null
@@ -1,24 +0,0 @@
-;;; cpstak.scm
-
-
-(define (cpstak x y z)
- (define (tak x y z k)
- (if (not (< y x))
- (k z)
- (tak (- x 1)
- y
- z
- (lambda (v1)
- (tak (- y 1)
- z
- x
- (lambda (v2)
- (tak (- z 1)
- x
- y
- (lambda (v3)
- (tak v1 v2 v3 k)))))))))
- (tak x y z (lambda (a) a)))
-
-(time (do ((i 100 (- i 1))) ((zero? i)) (cpstak 18 12 6)))
-
diff --git a/benchmarks/cscbench.scm b/benchmarks/cscbench.scm
deleted file mode 100644
index cf194c12..00000000
--- a/benchmarks/cscbench.scm
+++ /dev/null
@@ -1,189 +0,0 @@
-;;;; cscbench - Compile and run benchmarks - felix -*- Scheme -*-
-;
-; - Usage: cscbench [-debug] [-cc=<path>] [-csc=<path>] [-chicken=<path>] OPTION ...
-
-(require-extension srfi-1 utils posix regex)
-
-(define ignored-files '("cscbench.scm" "cscbench.scm~"))
-(define flonum-files '("fft" "maze" "nbody"))
-(define cc "gcc")
-(define chicken "chicken")
-(define csc "csc")
-
-(define +chicken-format+
- "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c ~A ~A -debug xopi 2>&1 >>bench.log")
-
-(define +cc-format+
- (cond-expand
- (macos "~a ~a -s -I.. tmpfile.c -o tmpfile ../lib~achicken.a -lm")
- (else "~a ~a -I.. tmpfile.c -o tmpfile ../lib~achicken.a -lm") ) )
-
-(define (abort-run) #f)
-
-(define run
- (let ([secrx (regexp "^ *([-.+e0-9]*(\\.[0-9]*)?) seconds elapsed$")])
- (lambda ()
- (system* "./tmpfile >tmpfile.out")
- (with-input-from-file "tmpfile.out"
- (lambda ()
- (let loop ([line (read-line)])
- (if (eof-object? line)
- (abort-run)
- (let ([m (string-match secrx line)])
- (if m
- (string->number (second m))
- (loop (read-line)) ) ) ) ) ) ) ) ) )
-
-(define (display-l str len pad)
- (let ([slen (string-length str)])
- (display (substring str 0 (min slen len)))
- (display (make-string (max 0 (- len slen)) pad)) ) )
-
-(define (display-r str len pad)
- (let ([slen (string-length str)])
- (display (make-string (max 0 (- len slen)) pad))
- (display (substring str 0 (min slen len))) ) )
-
-(define display-f-4.3
- (let ([florx (regexp "^([-+e0-9]*)(\\.([0-9]*))?$")])
- (lambda (n)
- (let* ([m (string-match florx (number->string n))]
- [is (second m)]
- [fs (fourth m)] )
- (display-r is 4 #\space)
- (display #\.)
- (display-r (or fs "0") 3 #\0) ) ) ) )
-
-(define (display-size n)
- (display-r
- (string-append (number->string (quotient n 1024)) "k")
- 10 #\space))
-
-(define (compile-and-run file decls options coptions unsafe)
- (system* +chicken-format+ chicken file decls options)
- (system* +cc-format+ cc coptions (if unsafe "u" ""))
- (let ((time (call-with-current-continuation
- (lambda (abort)
- (set! abort-run (cut abort #f))
- (let ((runs
- (butlast
- (cdr
- (sort
- (map (lambda _ (run)) (iota 5))
- <)))))
- (/ (apply + runs) 3)))))
- (size (file-size "tmpfile")))
- (display #\space)
- (cond (time
- (display-f-4.3 time)
- (values time size))
- (else
- (display "FAILED")
- (values 9999.9 size)))))
-
-(define (dflush x)
- (display x)
- (flush-output) )
-
-(define (main options)
- (call/cc
- (lambda (return)
- (let loop ((opts options))
- (cond ((null? opts) (return #f))
- ((string=? "-debug" (car opts))
- (set! system*
- (let ([system* system*])
- (lambda args
- (let ([s (apply sprintf args)])
- (printf "system: ~A~%" s)
- (system* s) ) ) ) ) )
- ((string-match "-cc=(.*)" (car opts)) =>
- (lambda (m) (set! cc (second m))))
- ((string-match "-csc=(.*)" (car opts)) =>
- (lambda (m) (set! csc (second m))))
- ((string-match "-chicken=(.*)" (car opts)) =>
- (lambda (m) (set! chicken (second m))))
- (else
- (set! options opts)
- (return #f)))
- (loop (cdr opts)))))
- (set! cc (string-trim-both (with-input-from-pipe "csc -cc-name" read-line)))
- (delete-file* "tmpfile.scm")
- (delete-file* "bench.log")
- (system* "~A -version" chicken)
- (dflush "\nCC:\n")
- (if (eq? (build-platform) 'sun)
- (system (conc cc " -V"))
- (system* "~A -v" cc) )
- (dflush "\nCFLAGS:\n")
- (system* "echo `~a -cflags`" csc)
- (display "\nRunning benchmarks ...\n\n (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped,\n")
- (display " compiler log will be written to \"bench.log\")\n")
- (display "\n (runtime) (code size)\n")
- (display "\n base fast unsafe max base fast unsafe max")
- (display "\n ----------------------------------------------------------------------------------\n")
- (let ((sum-base 0.0)
- (sum-fast 0.0)
- (sum-unsafe 0.0)
- (sum-max 0.0)
- (size-base 0)
- (size-fast 0)
- (size-unsafe 0)
- (size-max 0))
- (for-each
- (lambda (file)
- (let* ([name (pathname-file file)]
- [options (string-intersperse options " ")]
- (t 0))
- (display-l name 16 #\space)
- (flush-output)
- (set!-values
- (t size-base)
- (compile-and-run ; base
- file
- "-debug-level 0 -optimize-level 1"
- options "" #f))
- (set! sum-base (+ sum-base t))
- (dflush " ")
- (set!-values
- (t size-fast)
- (compile-and-run ; fast but safe
- file
- "-debug-level 0 -optimize-level 3 -lambda-lift"
- options "" #f))
- (set! sum-fast (+ sum-fast t))
- (dflush " ")
- (set!-values
- (t size-unsafe)
- (compile-and-run ; fast and unsafe
- file
- "-debug-level 0 -optimize-level 4 -block -disable-interrupts -lambda-lift"
- options "" #t))
- (set! sum-unsafe (+ sum-unsafe t))
- (dflush " ")
- (cond ((member name flonum-files)
- (display " "))
- (else
- (set!-values
- (t size-max)
- (compile-and-run file "-benchmark-mode" options "" #t) ) ; maximal speed
- (set! sum-max (+ sum-max t))))
- (display-size size-base)
- (display-size size-fast)
- (display-size size-unsafe)
- (display-size size-max)
- (newline)
- (flush-output)))
- (lset-difference string=? (sort (glob "*.scm") string<?) ignored-files))
- (display "\nTOTAL ")
- (display-f-4.3 sum-base)
- (display " ")
- (display-f-4.3 sum-fast)
- (display " ")
- (display-f-4.3 sum-unsafe)
- (display " ")
- (display-f-4.3 sum-max)
- (newline)
- 0))
-
-(main (command-line-arguments))
diff --git a/benchmarks/ctak.scm b/benchmarks/ctak.scm
deleted file mode 100644
index c2fc46b0..00000000
--- a/benchmarks/ctak.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; ctak.scm
-
-(define (ctak x y z)
- (call-with-current-continuation
- (lambda (k)
- (ctak-aux k x y z))))
-
-(define (ctak-aux k x y z)
- (cond ((not (< y x)) ;xy
- (k z))
- (else (call-with-current-continuation
- (lambda (k) ; (was missing)
- (ctak-aux
- k
- (call-with-current-continuation
- (lambda (k)
- (ctak-aux k
- (- x 1)
- y
- z)))
- (call-with-current-continuation
- (lambda (k)
- (ctak-aux k
- (- y 1)
- z
- x)))
- (call-with-current-continuation
- (lambda (k)
- (ctak-aux k
- (- z 1)
- x
- y)))))))) )
-
-
-(time (do ((i 10 (- i 1))) ((zero? i)) (ctak 18 12 6)))
diff --git a/benchmarks/dderiv.scm b/benchmarks/dderiv.scm
deleted file mode 100644
index 911082bc..00000000
--- a/benchmarks/dderiv.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: dderiv.sc
-;;; Description: DDERIV benchmark from the Gabriel tests
-;;; Author: Vaughan Pratt
-;;; Created: 8-Apr-85
-;;; Modified: 10-Apr-85 14:53:29 (Bob Shaw)
-;;; 23-Jul-87 (Will Clinger)
-;;; 9-Feb-88 (Will Clinger)
-;;; 21-Mar-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme (but see note below)
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Note: This benchmark uses property lists. The procedures that must
-;;; be supplied are get and put, where (put x y z) is equivalent to Common
-;;; Lisp's (setf (get x y) z).
-
-;;; DDERIV -- Symbolic derivative benchmark written by Vaughan Pratt.
-
-;;; This benchmark is a variant of the simple symbolic derivative program
-;;; (DERIV). The main change is that it is `table-driven.' Instead of using a
-;;; large COND that branches on the CAR of the expression, this program finds
-;;; the code that will take the derivative on the property list of the atom in
-;;; the CAR position. So, when the expression is (+ . <rest>), the code
-;;; stored under the atom '+ with indicator DERIV will take <rest> and
-;;; return the derivative for '+. The way that MacLisp does this is with the
-;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
-;;; atomic name in that it expects an argument list and the compiler compiles
-;;; code, but the name of the function with that code is stored on the
-;;; property list of FOO under the indicator BAR, in this case. You may have
-;;; to do something like:
-
-;;; :property keyword is not Common Lisp.
-
-
-(define (dderiv-aux a) (list '/ (dderiv a) a))
-
-(define (+dderiv a) (cons '+ (map dderiv a)))
-
-(put! '+ 'dderiv +dderiv) ; install procedure on the property list
-
-(define (-dderiv a) (cons '- (map dderiv a)))
-
-(put! '- 'dderiv -dderiv) ; install procedure on the property list
-
-(define (*dderiv a) (list '* (cons '* a) (cons '+ (map dderiv-aux a))))
-
-(put! '* 'dderiv *dderiv) ; install procedure on the property list
-
-(define (/dderiv a)
- (list '-
- (list '/ (dderiv (car a)) (cadr a))
- (list '/
- (car a)
- (list '* (cadr a) (cadr a) (dderiv (cadr a))))))
-
-(put! '/ 'dderiv /dderiv) ; install procedure on the property list
-
-(define (dderiv a)
- (cond ((not (pair? a)) (cond ((eq? a 'x) 1) (else 0)))
- (else (let ((dderiv (get (car a) 'dderiv)))
- (cond (dderiv (dderiv (cdr a)))
- (else 'error))))))
-
-(define (run)
- (do ((i 0 (+ i 1))) ((= i 1000))
- (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
-
-
-(time (do ((i 10 (- i 1))) ((zero? i)) (run)))
diff --git a/benchmarks/deriv.scm b/benchmarks/deriv.scm
deleted file mode 100644
index 10f848cc..00000000
--- a/benchmarks/deriv.scm
+++ /dev/null
@@ -1,42 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: deriv.sc
-;;; Description: The DERIV benchmark from the Gabriel tests.
-;;; Author: Vaughan Pratt
-;;; Created: 8-Apr-85
-;;; Modified: 10-Apr-85 14:53:50 (Bob Shaw)
-;;; 23-Jul-87 (Will Clinger)
-;;; 9-Feb-88 (Will Clinger)
-;;; 21-Mar-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (felix)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; DERIV -- Symbolic derivative benchmark written by Vaughan Pratt.
-;;; It uses a simple subset of Lisp and does a lot of CONSing.
-
-(define (deriv-aux a) (list '/ (deriv a) a))
-
-(define (deriv a)
- (cond ((not (pair? a)) (cond ((eq? a 'x) 1) (else 0)))
- ((eq? (car a) '+) (cons '+ (map deriv (cdr a))))
- ((eq? (car a) '-) (cons '- (map deriv (cdr a))))
- ((eq? (car a) '*) (list '* a (cons '+ (map deriv-aux (cdr a)))))
- ((eq? (car a) '/)
- (list '-
- (list '/ (deriv (cadr a)) (caddr a))
- (list '/
- (cadr a)
- (list '* (caddr a) (caddr a) (deriv (caddr a))))))
- (else 'error)))
-
-(define (run)
- (do ((i 0 (+ i 1))) ((= i 1000))
- (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
- (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
-
-(time (do ((i 10 (- i 1))) ((zero? i)) (run)))
diff --git a/benchmarks/destructive.scm b/benchmarks/destructive.scm
deleted file mode 100644
index 4b54e62a..00000000
--- a/benchmarks/destructive.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-;;; destructive.scm
-
-
-(define (append! lst1 lst2)
- (let loop ((lst1 lst1))
- (cond ((null? lst1) lst2)
- ((null? (cdr lst1)) (set-cdr! lst1 lst2))
- (else (loop (cdr lst1))) ) )
- lst1)
-
-(define (destructive n m)
- (let ((l (do ((i 10 (- i 1))
- (a '() (cons '() a)))
- ((= i 0) a))))
- (do ((i n (- i 1)))
- ((= i 0))
- (cond ((null? (car l))
- (do ((l l (cdr l)))
- ((null? l))
- (or (car l)
- (set-car! l (cons '() '())))
- (append! (car l)
- (do ((j m (- j 1))
- (a '() (cons '() a)))
- ((= j 0) a)))))
- (else
- (do ((l1 l (cdr l1))
- (l2 (cdr l) (cdr l2)))
- ((null? l2))
- (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
- (a (car l2) (cdr a)))
- ((zero? j) a)
- (set-car! a i))
- (let ((n (quotient (length (car l1)) 2)))
- (cond ((= n 0)
- (set-car! l1 '())
- (car l1))
- (else
- (do ((j n (- j 1))
- (a (car l1) (cdr a)))
- ((= j 1)
- (let ((x (cdr a)))
- (set-cdr! a '())
- x))
- (set-car! a i))))))))))))
-
-(time (destructive 6000 50))
diff --git a/benchmarks/div-iter.scm b/benchmarks/div-iter.scm
deleted file mode 100644
index 1639344b..00000000
--- a/benchmarks/div-iter.scm
+++ /dev/null
@@ -1,24 +0,0 @@
-;;; div-iter.scm
-
-
-(define (create-n n)
- (do ((n n (- n 1))
- (a '() (cons '() a)))
- ((= n 0) a)))
-
-(define *ll* (create-n 200))
-
-(define (iterative-div2 l)
- (do ((l l (cddr l))
- (a '() (cons (car l) a)))
- ((null? l) a)))
-
-(define (test l)
- (do ((i 3000 (- i 1)))
- ((= i 0))
- (iterative-div2 l)
- (iterative-div2 l)
- (iterative-div2 l)
- (iterative-div2 l)))
-
-(time (test *ll*))
diff --git a/benchmarks/div-rec.scm b/benchmarks/div-rec.scm
deleted file mode 100644
index d100f405..00000000
--- a/benchmarks/div-rec.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;; div-rec.scm
-
-
-(define (create-n n)
- (do ((n n (- n 1))
- (a '() (cons '() a)))
- ((= n 0) a)))
-
-(define *ll* (create-n 200))
-
-(define (recursive-div2 l)
- (cond ((null? l) '())
- (else (cons (car l) (recursive-div2 (cddr l))))))
-
-(define (test l)
- (do ((i 3000 (- i 1)))
- ((= i 0))
- (recursive-div2 l)
- (recursive-div2 l)
- (recursive-div2 l)
- (recursive-div2 l)))
-
-(time (test *ll*))
diff --git a/benchmarks/dynamic.scm b/benchmarks/dynamic.scm
deleted file mode 100644
index bfe1d140..00000000
--- a/benchmarks/dynamic.scm
+++ /dev/null
@@ -1,2320 +0,0 @@
-;;; DYNAMIC -- Obtained from Andrew Wright.
-;
-; 08/06/01 (felix): renamed "null" to "null2" because stupid MZC can't
-; handle redefinitions of primitives.
-;
-;
-;; Fritz's dynamic type inferencer, set up to run on itself
-;; (see the end of this file).
-
-;----------------------------------------------------------------------------
-; Environment management
-;----------------------------------------------------------------------------
-
-;; environments are lists of pairs, the first component being the key
-
-;; general environment operations
-;;
-;; empty-env: Env
-;; gen-binding: Key x Value -> Binding
-;; binding-key: Binding -> Key
-;; binding-value: Binding -> Value
-;; binding-show: Binding -> Symbol*
-;; extend-env-with-binding: Env x Binding -> Env
-;; extend-env-with-env: Env x Env -> Env
-;; lookup: Key x Env -> (Binding + False)
-;; env->list: Env -> Binding*
-;; env-show: Env -> Symbol*
-
-
-; bindings
-
-(define gen-binding cons)
-; generates a type binding, binding a symbol to a type variable
-
-(define binding-key car)
-; returns the key of a type binding
-
-(define binding-value cdr)
-; returns the tvariable of a type binding
-
-(define (key-show key)
- ; default show procedure for keys
- key)
-
-(define (value-show value)
- ; default show procedure for values
- value)
-
-(define (binding-show binding)
- ; returns a printable representation of a type binding
- (cons (key-show (binding-key binding))
- (cons ': (value-show (binding-value binding)))))
-
-
-; environments
-
-(define dynamic-empty-env '())
-; returns the empty environment
-
-(define (extend-env-with-binding env binding)
- ; extends env with a binding, which hides any other binding in env
- ; for the same key (see dynamic-lookup)
- ; returns the extended environment
- (cons binding env))
-
-(define (extend-env-with-env env ext-env)
- ; extends environment env with environment ext-env
- ; a binding for a key in ext-env hides any binding in env for
- ; the same key (see dynamic-lookup)
- ; returns the extended environment
- (append ext-env env))
-
-(define dynamic-lookup (lambda (x l) (assv x l)))
-; returns the first pair in env that matches the key; returns #f
-; if no such pair exists
-
-(define (env->list e)
- ; converts an environment to a list of bindings
- e)
-
-(define (env-show env)
- ; returns a printable list representation of a type environment
- (map binding-show env))
-;----------------------------------------------------------------------------
-; Parsing for Scheme
-;----------------------------------------------------------------------------
-
-
-;; Needed packages: environment management
-
-;(load "env-mgmt.ss")
-;(load "pars-act.ss")
-
-;; Lexical notions
-
-(define syntactic-keywords
- ;; source: IEEE Scheme, 7.1, <expression keyword>, <syntactic keyword>
- '(lambda if set! begin cond and or case let let* letrec do
- quasiquote else => define unquote unquote-splicing))
-
-
-;; Parse routines
-
-; Datum
-
-; dynamic-parse-datum: parses nonterminal <datum>
-
-(define (dynamic-parse-datum e)
- ;; Source: IEEE Scheme, sect. 7.2, <datum>
- ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as
- ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18)
- ;; ***Note***: quasi-quotations are not permitted! (It would be
- ;; necessary to pass the environment to dynamic-parse-datum.)
- (cond
- ((null? e)
- (dynamic-parse-action-null-const))
- ((boolean? e)
- (dynamic-parse-action-boolean-const e))
- ((char? e)
- (dynamic-parse-action-char-const e))
- ((number? e)
- (dynamic-parse-action-number-const e))
- ((string? e)
- (dynamic-parse-action-string-const e))
- ((symbol? e)
- (dynamic-parse-action-symbol-const e))
- ((vector? e)
- (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e))))
- ((pair? e)
- (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
- (dynamic-parse-datum (cdr e))))
- (else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))
-
-
-; VarDef
-
-; dynamic-parse-formal: parses nonterminal <variable> in defining occurrence position
-
-(define (dynamic-parse-formal f-env e)
- ; e is an arbitrary object, f-env is a forbidden environment;
- ; returns: a variable definition (a binding for the symbol), plus
- ; the value of the binding as a result
- (if (symbol? e)
- (cond
- ((memq e syntactic-keywords)
- (error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
- ((dynamic-lookup e f-env)
- (error 'dynamic-parse-formal "Duplicate variable definition: ~s" e))
- (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
- (cons (gen-binding e dynamic-parse-action-result)
- dynamic-parse-action-result))))
- (error 'dynamic-parse-formal "Not an identifier: ~s" e)))
-
-; dynamic-parse-formal*
-
-(define (dynamic-parse-formal* formals)
- ;; parses a list of formals and returns a pair consisting of generated
- ;; environment and list of parsing action results
- (letrec
- ((pf*
- (lambda (f-env results formals)
- ;; f-env: "forbidden" environment (to avoid duplicate defs)
- ;; results: the results of the parsing actions
- ;; formals: the unprocessed formals
- ;; Note: generates the results of formals in reverse order!
- (cond
- ((null? formals)
- (cons f-env results))
- ((pair? formals)
- (let* ((fst-formal (car formals))
- (binding-result (dynamic-parse-formal f-env fst-formal))
- (binding (car binding-result))
- (var-result (cdr binding-result)))
- (pf*
- (extend-env-with-binding f-env binding)
- (cons var-result results)
- (cdr formals))))
- (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
- (let ((renv-rres (pf* dynamic-empty-env '() formals)))
- (cons (car renv-rres) (reverse (cdr renv-rres))))))
-
-
-; dynamic-parse-formals: parses <formals>
-
-(define (dynamic-parse-formals formals)
- ;; parses <formals>; see IEEE Scheme, sect. 7.3
- ;; returns a pair: env and result
- (letrec ((pfs (lambda (f-env formals)
- (cond
- ((null? formals)
- (cons dynamic-empty-env (dynamic-parse-action-null-formal)))
- ((pair? formals)
- (let* ((fst-formal (car formals))
- (rem-formals (cdr formals))
- (bind-res (dynamic-parse-formal f-env fst-formal))
- (bind (car bind-res))
- (res (cdr bind-res))
- (nf-env (extend-env-with-binding f-env bind))
- (renv-res* (pfs nf-env rem-formals))
- (renv (car renv-res*))
- (res* (cdr renv-res*)))
- (cons
- (extend-env-with-binding renv bind)
- (dynamic-parse-action-pair-formal res res*))))
- (else
- (let* ((bind-res (dynamic-parse-formal f-env formals))
- (bind (car bind-res))
- (res (cdr bind-res)))
- (cons
- (extend-env-with-binding dynamic-empty-env bind)
- res)))))))
- (pfs dynamic-empty-env formals)))
-
-
-; Expr
-
-; dynamic-parse-expression: parses nonterminal <expression>
-
-(define (dynamic-parse-expression env e)
- (cond
- ((symbol? e)
- (dynamic-parse-variable env e))
- ((pair? e)
- (let ((op (car e)) (args (cdr e)))
- (case op
- ((quote) (dynamic-parse-quote env args))
- ((lambda) (dynamic-parse-lambda env args))
- ((if) (dynamic-parse-if env args))
- ((set!) (dynamic-parse-set env args))
- ((begin) (dynamic-parse-begin env args))
- ((cond) (dynamic-parse-cond env args))
- ((case) (dynamic-parse-case env args))
- ((and) (dynamic-parse-and env args))
- ((or) (dynamic-parse-or env args))
- ((let) (dynamic-parse-let env args))
- ((let*) (dynamic-parse-let* env args))
- ((letrec) (dynamic-parse-letrec env args))
- ((do) (dynamic-parse-do env args))
- ((quasiquote) (dynamic-parse-quasiquote env args))
- (else (dynamic-parse-procedure-call env op args)))))
- (else (dynamic-parse-datum e))))
-
-; dynamic-parse-expression*
-
-(define (dynamic-parse-expression* env exprs)
- ;; Parses lists of expressions (returns them in the right order!)
- (letrec ((pe*
- (lambda (results es)
- (cond
- ((null? es) results)
- ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
- (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es))))))
- (reverse (pe* '() exprs))))
-
-
-; dynamic-parse-expressions
-
-(define (dynamic-parse-expressions env exprs)
- ;; parses lists of arguments of a procedure call
- (cond
- ((null? exprs) (dynamic-parse-action-null-arg))
- ((pair? exprs) (let* ((fst-expr (car exprs))
- (rem-exprs (cdr exprs))
- (fst-res (dynamic-parse-expression env fst-expr))
- (rem-res (dynamic-parse-expressions env rem-exprs)))
- (dynamic-parse-action-pair-arg fst-res rem-res)))
- (else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
- exprs))))
-
-
-; dynamic-parse-variable: parses variables (applied occurrences)
-
-(define (dynamic-parse-variable env e)
- (if (symbol? e)
- (if (memq e syntactic-keywords)
- (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e)
- (let ((assoc-var-def (dynamic-lookup e env)))
- (if assoc-var-def
- (dynamic-parse-action-variable (binding-value assoc-var-def))
- (dynamic-parse-action-identifier e))))
- (error 'dynamic-parse-variable "Not an identifier: ~s" e)))
-
-
-; dynamic-parse-procedure-call
-
-(define (dynamic-parse-procedure-call env op args)
- (dynamic-parse-action-procedure-call
- (dynamic-parse-expression env op)
- (dynamic-parse-expressions env args)))
-
-
-; dynamic-parse-quote
-
-(define (dynamic-parse-quote env args)
- (if (list-of-1? args)
- (dynamic-parse-datum (car args))
- (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args)))
-
-
-; dynamic-parse-lambda
-
-(define (dynamic-parse-lambda env args)
- (if (pair? args)
- (let* ((formals (car args))
- (body (cdr args))
- (nenv-fresults (dynamic-parse-formals formals))
- (nenv (car nenv-fresults))
- (fresults (cdr nenv-fresults)))
- (dynamic-parse-action-lambda-expression
- fresults
- (dynamic-parse-body (extend-env-with-env env nenv) body)))
- (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args)))
-
-
-; dynamic-parse-body
-
-(define (dynamic-parse-body env body)
- ; <body> = <definition>* <expression>+
- (define (def-var* f-env body)
- ; finds the defined variables in a body and returns an
- ; environment containing them
- (if (pair? body)
- (let ((n-env (def-var f-env (car body))))
- (if n-env
- (def-var* n-env (cdr body))
- f-env))
- f-env))
- (define (def-var f-env clause)
- ; finds the defined variables in a single clause and extends
- ; f-env accordingly; returns false if it's not a definition
- (if (pair? clause)
- (case (car clause)
- ((define) (if (pair? (cdr clause))
- (let ((pattern (cadr clause)))
- (cond
- ((symbol? pattern)
- (extend-env-with-binding
- f-env
- (gen-binding pattern
- (dynamic-parse-action-var-def pattern))))
- ((and (pair? pattern) (symbol? (car pattern)))
- (extend-env-with-binding
- f-env
- (gen-binding (car pattern)
- (dynamic-parse-action-var-def
- (car pattern)))))
- (else f-env)))
- f-env))
- ((begin) (def-var* f-env (cdr clause)))
- (else #f))
- #f))
- (if (pair? body)
- (dynamic-parse-command* (def-var* env body) body)
- (error 'dynamic-parse-body "Illegal body: ~s" body)))
-
-; dynamic-parse-if
-
-(define (dynamic-parse-if env args)
- (cond
- ((list-of-3? args)
- (dynamic-parse-action-conditional
- (dynamic-parse-expression env (car args))
- (dynamic-parse-expression env (cadr args))
- (dynamic-parse-expression env (caddr args))))
- ((list-of-2? args)
- (dynamic-parse-action-conditional
- (dynamic-parse-expression env (car args))
- (dynamic-parse-expression env (cadr args))
- (dynamic-parse-action-empty)))
- (else (error 'dynamic-parse-if "Not an if-expression: ~s" args))))
-
-
-; dynamic-parse-set
-
-(define (dynamic-parse-set env args)
- (if (list-of-2? args)
- (dynamic-parse-action-assignment
- (dynamic-parse-variable env (car args))
- (dynamic-parse-expression env (cadr args)))
- (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args)))
-
-
-; dynamic-parse-begin
-
-(define (dynamic-parse-begin env args)
- (dynamic-parse-action-begin-expression
- (dynamic-parse-body env args)))
-
-
-; dynamic-parse-cond
-
-(define (dynamic-parse-cond env args)
- (if (and (pair? args) (list? args))
- (dynamic-parse-action-cond-expression
- (map (lambda (e)
- (dynamic-parse-cond-clause env e))
- args))
- (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))
-
-; dynamic-parse-cond-clause
-
-(define (dynamic-parse-cond-clause env e)
- ;; ***Note***: Only (<test> <sequence>) is permitted!
- (if (pair? e)
- (cons
- (if (eqv? (car e) 'else)
- (dynamic-parse-action-empty)
- (dynamic-parse-expression env (car e)))
- (dynamic-parse-body env (cdr e)))
- (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))
-
-
-; dynamic-parse-and
-
-(define (dynamic-parse-and env args)
- (if (list? args)
- (dynamic-parse-action-and-expression
- (dynamic-parse-expression* env args))
- (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))
-
-
-; dynamic-parse-or
-
-(define (dynamic-parse-or env args)
- (if (list? args)
- (dynamic-parse-action-or-expression
- (dynamic-parse-expression* env args))
- (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))
-
-
-; dynamic-parse-case
-
-(define (dynamic-parse-case env args)
- (if (and (list? args) (> (length args) 1))
- (dynamic-parse-action-case-expression
- (dynamic-parse-expression env (car args))
- (map (lambda (e)
- (dynamic-parse-case-clause env e))
- (cdr args)))
- (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))
-
-; dynamic-parse-case-clause
-
-(define (dynamic-parse-case-clause env e)
- (if (pair? e)
- (cons
- (cond
- ((eqv? (car e) 'else)
- (list (dynamic-parse-action-empty)))
- ((list? (car e))
- (map dynamic-parse-datum (car e)))
- (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
- (dynamic-parse-body env (cdr e)))
- (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))
-
-
-; dynamic-parse-let
-
-(define (dynamic-parse-let env args)
- (if (pair? args)
- (if (symbol? (car args))
- (dynamic-parse-named-let env args)
- (dynamic-parse-normal-let env args))
- (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))
-
-
-; dynamic-parse-normal-let
-
-(define (dynamic-parse-normal-let env args)
- ;; parses "normal" let-expressions
- (let* ((bindings (car args))
- (body (cdr args))
- (env-ast (dynamic-parse-parallel-bindings env bindings))
- (nenv (car env-ast))
- (bresults (cdr env-ast)))
- (dynamic-parse-action-let-expression
- bresults
- (dynamic-parse-body (extend-env-with-env env nenv) body))))
-
-; dynamic-parse-named-let
-
-(define (dynamic-parse-named-let env args)
- ;; parses a named let-expression
- (if (pair? (cdr args))
- (let* ((variable (car args))
- (bindings (cadr args))
- (body (cddr args))
- (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
- (vbind (car vbind-vres))
- (vres (cdr vbind-vres))
- (env-ast (dynamic-parse-parallel-bindings env bindings))
- (nenv (car env-ast))
- (bresults (cdr env-ast)))
- (dynamic-parse-action-named-let-expression
- vres bresults
- (dynamic-parse-body (extend-env-with-env
- (extend-env-with-binding env vbind)
- nenv) body)))
- (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))
-
-
-; dynamic-parse-parallel-bindings
-
-(define (dynamic-parse-parallel-bindings env bindings)
- ; returns a pair consisting of an environment
- ; and a list of pairs (variable . asg)
- ; ***Note***: the list of pairs is returned in reverse unzipped form!
- (if (list-of-list-of-2s? bindings)
- (let* ((env-formals-asg
- (dynamic-parse-formal* (map car bindings)))
- (nenv (car env-formals-asg))
- (bresults (cdr env-formals-asg))
- (exprs-asg
- (dynamic-parse-expression* env (map cadr bindings))))
- (cons nenv (cons bresults exprs-asg)))
- (error 'dynamic-parse-parallel-bindings
- "Not a list of bindings: ~s" bindings)))
-
-
-; dynamic-parse-let*
-
-(define (dynamic-parse-let* env args)
- (if (pair? args)
- (let* ((bindings (car args))
- (body (cdr args))
- (env-ast (dynamic-parse-sequential-bindings env bindings))
- (nenv (car env-ast))
- (bresults (cdr env-ast)))
- (dynamic-parse-action-let*-expression
- bresults
- (dynamic-parse-body (extend-env-with-env env nenv) body)))
- (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))
-
-; dynamic-parse-sequential-bindings
-
-(define (dynamic-parse-sequential-bindings env bindings)
- ; returns a pair consisting of an environment
- ; and a list of pairs (variable . asg)
- ;; ***Note***: the list of pairs is returned in reverse unzipped form!
- (letrec
- ((psb
- (lambda (f-env c-env var-defs expr-asgs binds)
- ;; f-env: forbidden environment
- ;; c-env: constructed environment
- ;; var-defs: results of formals
- ;; expr-asgs: results of corresponding expressions
- ;; binds: reminding bindings to process
- (cond
- ((null? binds)
- (cons f-env (cons var-defs expr-asgs)))
- ((pair? binds)
- (let ((fst-bind (car binds)))
- (if (list-of-2? fst-bind)
- (let* ((fbinding-bres
- (dynamic-parse-formal f-env (car fst-bind)))
- (fbind (car fbinding-bres))
- (bres (cdr fbinding-bres))
- (new-expr-asg
- (dynamic-parse-expression c-env (cadr fst-bind))))
- (psb
- (extend-env-with-binding f-env fbind)
- (extend-env-with-binding c-env fbind)
- (cons bres var-defs)
- (cons new-expr-asg expr-asgs)
- (cdr binds)))
- (error 'dynamic-parse-sequential-bindings
- "Illegal binding: ~s" fst-bind))))
- (else (error 'dynamic-parse-sequential-bindings
- "Illegal bindings: ~s" binds))))))
- (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
- (cons (car env-vdefs-easgs)
- (cons (reverse (cadr env-vdefs-easgs))
- (reverse (cddr env-vdefs-easgs)))))))
-
-
-; dynamic-parse-letrec
-
-(define (dynamic-parse-letrec env args)
- (if (pair? args)
- (let* ((bindings (car args))
- (body (cdr args))
- (env-ast (dynamic-parse-recursive-bindings env bindings))
- (nenv (car env-ast))
- (bresults (cdr env-ast)))
- (dynamic-parse-action-letrec-expression
- bresults
- (dynamic-parse-body (extend-env-with-env env nenv) body)))
- (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))
-
-; dynamic-parse-recursive-bindings
-
-(define (dynamic-parse-recursive-bindings env bindings)
- ;; ***Note***: the list of pairs is returned in reverse unzipped form!
- (if (list-of-list-of-2s? bindings)
- (let* ((env-formals-asg
- (dynamic-parse-formal* (map car bindings)))
- (formals-env
- (car env-formals-asg))
- (formals-res
- (cdr env-formals-asg))
- (exprs-asg
- (dynamic-parse-expression*
- (extend-env-with-env env formals-env)
- (map cadr bindings))))
- (cons
- formals-env
- (cons formals-res exprs-asg)))
- (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
-
-
-; dynamic-parse-do
-
-(define (dynamic-parse-do env args)
- ;; parses do-expressions
- ;; ***Note***: Not implemented!
- (error 'dynamic-parse-do "Nothing yet..."))
-
-; dynamic-parse-quasiquote
-
-(define (dynamic-parse-quasiquote env args)
- ;; ***Note***: Not implemented!
- (error 'dynamic-parse-quasiquote "Nothing yet..."))
-
-
-;; Command
-
-; dynamic-parse-command
-
-(define (dynamic-parse-command env c)
- (if (pair? c)
- (let ((op (car c))
- (args (cdr c)))
- (case op
- ((define) (dynamic-parse-define env args))
-; ((begin) (dynamic-parse-command* env args)) ;; AKW
- ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
- (else (dynamic-parse-expression env c))))
- (dynamic-parse-expression env c)))
-
-
-; dynamic-parse-command*
-
-(define (dynamic-parse-command* env commands)
- ;; parses a sequence of commands
- (if (list? commands)
- (map (lambda (command) (dynamic-parse-command env command)) commands)
- (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))
-
-
-; dynamic-parse-define
-
-(define (dynamic-parse-define env args)
- ;; three cases -- see IEEE Scheme, sect. 5.2
- ;; ***Note***: the parser admits forms (define (x . y) ...)
- ;; ***Note***: Variables are treated as applied occurrences!
- (if (pair? args)
- (let ((pattern (car args))
- (exp-or-body (cdr args)))
- (cond
- ((symbol? pattern)
- (if (list-of-1? exp-or-body)
- (dynamic-parse-action-definition
- (dynamic-parse-variable env pattern)
- (dynamic-parse-expression env (car exp-or-body)))
- (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
- ((pair? pattern)
- (let* ((function-name (car pattern))
- (function-arg-names (cdr pattern))
- (env-ast (dynamic-parse-formals function-arg-names))
- (formals-env (car env-ast))
- (formals-ast (cdr env-ast)))
- (dynamic-parse-action-function-definition
- (dynamic-parse-variable env function-name)
- formals-ast
- (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
- (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
- (error 'dynamic-parse-define "Not a valid definition: ~s" args)))
-
-;; Auxiliary routines
-
-; forall?
-
-(define (forall? pred list)
- (if (null? list)
- #t
- (and (pred (car list)) (forall? pred (cdr list)))))
-
-; list-of-1?
-
-(define (list-of-1? l)
- (and (pair? l) (null? (cdr l))))
-
-; list-of-2?
-
-(define (list-of-2? l)
- (and (pair? l) (pair? (cdr l)) (null? (cddr l))))
-
-; list-of-3?
-
-(define (list-of-3? l)
- (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))
-
-; list-of-list-of-2s?
-
-(define (list-of-list-of-2s? e)
- (cond
- ((null? e)
- #t)
- ((pair? e)
- (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
- (else #f)))
-
-
-;; File processing
-
-; dynamic-parse-from-port
-
-(define (dynamic-parse-from-port port)
- (let ((next-input (read port)))
- (if (eof-object? next-input)
- '()
- (dynamic-parse-action-commands
- (dynamic-parse-command dynamic-empty-env next-input)
- (dynamic-parse-from-port port)))))
-
-; dynamic-parse-file
-
-(define (dynamic-parse-file file-name)
- (let ((input-port (open-input-file file-name)))
- (dynamic-parse-from-port input-port)))
-;----------------------------------------------------------------------------
-; Implementation of Union/find data structure in Scheme
-;----------------------------------------------------------------------------
-
-;; for union/find the following attributes are necessary: rank, parent
-;; (see Tarjan, "Data structures and network algorithms", 1983)
-;; In the Scheme realization an element is represented as a single
-;; cons cell; its address is the element itself; the car field contains
-;; the parent, the cdr field is an address for a cons
-;; cell containing the rank (car field) and the information (cdr field)
-
-
-;; general union/find data structure
-;;
-;; gen-element: Info -> Elem
-;; find: Elem -> Elem
-;; link: Elem! x Elem! -> Elem
-;; asymm-link: Elem! x Elem! -> Elem
-;; info: Elem -> Info
-;; set-info!: Elem! x Info -> Void
-
-
-(define (gen-element info)
- ; generates a new element: the parent field is initialized to '(),
- ; the rank field to 0
- (cons '() (cons 0 info)))
-
-(define info (lambda (l) (cddr l)))
- ; returns the information stored in an element
-
-(define (set-info! elem info)
- ; sets the info-field of elem to info
- (set-cdr! (cdr elem) info))
-
-; (define (find! x)
-; ; finds the class representative of x and sets the parent field
-; ; directly to the class representative (a class representative has
-; ; '() as its parent) (uses path halving)
-; ;(display "Find!: ")
-; ;(display (pretty-print (info x)))
-; ;(newline)
-; (let ((px (car x)))
-; (if (null? px)
-; x
-; (let ((ppx (car px)))
-; (if (null? ppx)
-; px
-; (begin
-; (set-car! x ppx)
-; (find! ppx)))))))
-
-(define (find! elem)
- ; finds the class representative of elem and sets the parent field
- ; directly to the class representative (a class representative has
- ; '() as its parent)
- ;(display "Find!: ")
- ;(display (pretty-print (info elem)))
- ;(newline)
- (let ((p-elem (car elem)))
- (if (null? p-elem)
- elem
- (let ((rep-elem (find! p-elem)))
- (set-car! elem rep-elem)
- rep-elem))))
-
-(define (link! elem-1 elem-2)
- ; links class elements by rank
- ; they must be distinct class representatives
- ; returns the class representative of the merged equivalence classes
- ;(display "Link!: ")
- ;(display (pretty-print (list (info elem-1) (info elem-2))))
- ;(newline)
- (let ((rank-1 (cadr elem-1))
- (rank-2 (cadr elem-2)))
- (cond
- ((= rank-1 rank-2)
- (set-car! (cdr elem-2) (+ rank-2 1))
- (set-car! elem-1 elem-2)
- elem-2)
- ((> rank-1 rank-2)
- (set-car! elem-2 elem-1)
- elem-1)
- (else
- (set-car! elem-1 elem-2)
- elem-2))))
-
-(define asymm-link! (lambda (l x) (set-car! l x)))
-
-;(define (asymm-link! elem-1 elem-2)
- ; links elem-1 onto elem-2 no matter what rank;
- ; does not update the rank of elem-2 and does not return a value
- ; the two arguments must be distinct
- ;(display "AsymmLink: ")
- ;(display (pretty-print (list (info elem-1) (info elem-2))))
- ;(newline)
- ;(set-car! elem-1 elem-2))
-
-;----------------------------------------------------------------------------
-; Type management
-;----------------------------------------------------------------------------
-
-; introduces type variables and types for Scheme,
-
-
-;; type TVar (type variables)
-;;
-;; gen-tvar: () -> TVar
-;; gen-type: TCon x TVar* -> TVar
-;; dynamic: TVar
-;; tvar-id: TVar -> Symbol
-;; tvar-def: TVar -> Type + Null
-;; tvar-show: TVar -> Symbol*
-;;
-;; set-def!: !TVar x TCon x TVar* -> Null
-;; equiv!: !TVar x !TVar -> Null
-;;
-;;
-;; type TCon (type constructors)
-;;
-;; ...
-;;
-;; type Type (types)
-;;
-;; gen-type: TCon x TVar* -> Type
-;; type-con: Type -> TCon
-;; type-args: Type -> TVar*
-;;
-;; boolean: TVar
-;; character: TVar
-;; null: TVar
-;; pair: TVar x TVar -> TVar
-;; procedure: TVar x TVar* -> TVar
-;; charseq: TVar
-;; symbol: TVar
-;; array: TVar -> TVar
-
-
-; Needed packages: union/find
-
-;(load "union-fi.so")
-
-; TVar
-
-(define counter 0)
-; counter for generating tvar id's
-
-(define (gen-id)
- ; generates a new id (for printing purposes)
- (set! counter (+ counter 1))
- counter)
-
-(define (gen-tvar)
- ; generates a new type variable from a new symbol
- ; uses union/find elements with two info fields
- ; a type variable has exactly four fields:
- ; car: TVar (the parent field; initially null)
- ; cadr: Number (the rank field; is always nonnegative)
- ; caddr: Symbol (the type variable identifier; used only for printing)
- ; cdddr: Type (the leq field; initially null)
- (gen-element (cons (gen-id) '())))
-
-(define (gen-type tcon targs)
- ; generates a new type variable with an associated type definition
- (gen-element (cons (gen-id) (cons tcon targs))))
-
-(define dynamic (gen-element (cons 0 '())))
-; the special type variable dynamic
-; Generic operations
-
-(define (tvar-id tvar)
- ; returns the (printable) symbol representing the type variable
- (car (info tvar)))
-
-(define (tvar-def tvar)
- ; returns the type definition (if any) of the type variable
- (cdr (info tvar)))
-
-(define (set-def! tvar tcon targs)
- ; sets the type definition part of tvar to type
- (set-cdr! (info tvar) (cons tcon targs))
- '())
-
-(define (reset-def! tvar)
- ; resets the type definition part of tvar to nil
- (set-cdr! (info tvar) '()))
-
-(define type-con (lambda (l) (car l)))
-; returns the type constructor of a type definition
-
-(define type-args (lambda (l) (cdr l)))
-; returns the type variables of a type definition
-
-(define (tvar->string tvar)
- ; converts a tvar's id to a string
- (if (eqv? (tvar-id tvar) 0)
- "Dynamic"
- (string-append "t#" (number->string (tvar-id tvar) 10))))
-
-(define (tvar-show tv)
- ; returns a printable list representation of type variable tv
- (let* ((tv-rep (find! tv))
- (tv-def (tvar-def tv-rep)))
- (cons (tvar->string tv-rep)
- (if (null? tv-def)
- '()
- (cons 'is (type-show tv-def))))))
-
-(define (type-show type)
- ; returns a printable list representation of type definition type
- (cond
- ((eqv? (type-con type) ptype-con)
- (let ((new-tvar (gen-tvar)))
- (cons ptype-con
- (cons (tvar-show new-tvar)
- (tvar-show ((type-args type) new-tvar))))))
- (else
- (cons (type-con type)
- (map (lambda (tv)
- (tvar->string (find! tv)))
- (type-args type))))))
-
-
-
-; Special type operations
-
-; type constructor literals
-
-(define boolean-con 'boolean)
-(define char-con 'char)
-(define null-con 'null)
-(define number-con 'number)
-(define pair-con 'pair)
-(define procedure-con 'procedure)
-(define string-con 'string)
-(define symbol-con 'symbol)
-(define vector-con 'vector)
-
-; type constants and type constructors
-
-(define (null2)
- ; ***Note***: Temporarily changed to be a pair!
- ; (gen-type null-con '())
- (pair (gen-tvar) (gen-tvar)))
-(define (boolean)
- (gen-type boolean-con '()))
-(define (character)
- (gen-type char-con '()))
-(define (number)
- (gen-type number-con '()))
-(define (charseq)
- (gen-type string-con '()))
-(define (symbol)
- (gen-type symbol-con '()))
-(define (pair tvar-1 tvar-2)
- (gen-type pair-con (list tvar-1 tvar-2)))
-(define (array tvar)
- (gen-type vector-con (list tvar)))
-(define (procedure arg-tvar res-tvar)
- (gen-type procedure-con (list arg-tvar res-tvar)))
-
-
-; equivalencing of type variables
-
-(define (equiv! tv1 tv2)
- (let* ((tv1-rep (find! tv1))
- (tv2-rep (find! tv2))
- (tv1-def (tvar-def tv1-rep))
- (tv2-def (tvar-def tv2-rep)))
- (cond
- ((eqv? tv1-rep tv2-rep)
- '())
- ((eqv? tv2-rep dynamic)
- (equiv-with-dynamic! tv1-rep))
- ((eqv? tv1-rep dynamic)
- (equiv-with-dynamic! tv2-rep))
- ((null? tv1-def)
- (if (null? tv2-def)
- ; both tv1 and tv2 are distinct type variables
- (link! tv1-rep tv2-rep)
- ; tv1 is a type variable, tv2 is a (nondynamic) type
- (asymm-link! tv1-rep tv2-rep)))
- ((null? tv2-def)
- ; tv1 is a (nondynamic) type, tv2 is a type variable
- (asymm-link! tv2-rep tv1-rep))
- ((eqv? (type-con tv1-def) (type-con tv2-def))
- ; both tv1 and tv2 are (nondynamic) types with equal numbers of
- ; arguments
- (link! tv1-rep tv2-rep)
- (map equiv! (type-args tv1-def) (type-args tv2-def)))
- (else
- ; tv1 and tv2 are types with distinct type constructors or different
- ; numbers of arguments
- (equiv-with-dynamic! tv1-rep)
- (equiv-with-dynamic! tv2-rep))))
- '())
-
-(define (equiv-with-dynamic! tv)
- (let ((tv-rep (find! tv)))
- (if (not (eqv? tv-rep dynamic))
- (let ((tv-def (tvar-def tv-rep)))
- (asymm-link! tv-rep dynamic)
- (if (not (null? tv-def))
- (map equiv-with-dynamic! (type-args tv-def))))))
- '())
-;----------------------------------------------------------------------------
-; Polymorphic type management
-;----------------------------------------------------------------------------
-
-; introduces parametric polymorphic types
-
-
-;; forall: (Tvar -> Tvar) -> TVar
-;; fix: (Tvar -> Tvar) -> Tvar
-;;
-;; instantiate-type: TVar -> TVar
-
-; type constructor literal for polymorphic types
-
-(define ptype-con 'forall)
-
-(define (forall tv-func)
- (gen-type ptype-con tv-func))
-
-(define (forall2 tv-func2)
- (forall (lambda (tv1)
- (forall (lambda (tv2)
- (tv-func2 tv1 tv2))))))
-
-(define (forall3 tv-func3)
- (forall (lambda (tv1)
- (forall2 (lambda (tv2 tv3)
- (tv-func3 tv1 tv2 tv3))))))
-
-(define (forall4 tv-func4)
- (forall (lambda (tv1)
- (forall3 (lambda (tv2 tv3 tv4)
- (tv-func4 tv1 tv2 tv3 tv4))))))
-
-(define (forall5 tv-func5)
- (forall (lambda (tv1)
- (forall4 (lambda (tv2 tv3 tv4 tv5)
- (tv-func5 tv1 tv2 tv3 tv4 tv5))))))
-
-
-; (polymorphic) instantiation
-
-(define (instantiate-type tv)
- ; instantiates type tv and returns a generic instance
- (let* ((tv-rep (find! tv))
- (tv-def (tvar-def tv-rep)))
- (cond
- ((null? tv-def)
- tv-rep)
- ((eqv? (type-con tv-def) ptype-con)
- (instantiate-type ((type-args tv-def) (gen-tvar))))
- (else
- tv-rep))))
-
-(define (fix tv-func)
- ; forms a recursive type: the fixed point of type mapping tv-func
- (let* ((new-tvar (gen-tvar))
- (inst-tvar (tv-func new-tvar))
- (inst-def (tvar-def inst-tvar)))
- (if (null? inst-def)
- (error 'fix "Illegal recursive type: ~s"
- (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
- (begin
- (set-def! new-tvar
- (type-con inst-def)
- (type-args inst-def))
- new-tvar))))
-
-
-;----------------------------------------------------------------------------
-; Constraint management
-;----------------------------------------------------------------------------
-
-
-; constraints
-
-(define gen-constr (lambda (a b) (cons a b)))
-; generates an equality between tvar1 and tvar2
-
-(define constr-lhs (lambda (c) (car c)))
-; returns the left-hand side of a constraint
-
-(define constr-rhs (lambda (c) (cdr c)))
-; returns the right-hand side of a constraint
-
-(define (constr-show c)
- (cons (tvar-show (car c))
- (cons '=
- (cons (tvar-show (cdr c)) '()))))
-
-
-; constraint set management
-
-(define global-constraints '())
-
-(define (init-global-constraints!)
- (set! global-constraints '()))
-
-(define (add-constr! lhs rhs)
- (set! global-constraints
- (cons (gen-constr lhs rhs) global-constraints))
- '())
-
-(define (glob-constr-show)
- ; returns printable version of global constraints
- (map constr-show global-constraints))
-
-
-; constraint normalization
-
-; Needed packages: type management
-
-;(load "typ-mgmt.so")
-
-(define (normalize-global-constraints!)
- (normalize! global-constraints)
- (init-global-constraints!))
-
-(define (normalize! constraints)
- (map (lambda (c)
- (equiv! (constr-lhs c) (constr-rhs c))) constraints))
-; ----------------------------------------------------------------------------
-; Abstract syntax definition and parse actions
-; ----------------------------------------------------------------------------
-
-; Needed packages: ast-gen.ss
-;(load "ast-gen.ss")
-
-;; Abstract syntax
-;;
-;; VarDef
-;;
-;; Identifier = Symbol - SyntacticKeywords
-;; SyntacticKeywords = { ... } (see Section 7.1, IEEE Scheme Standard)
-;;
-;; Datum
-;;
-;; null-const: Null -> Datum
-;; boolean-const: Bool -> Datum
-;; char-const: Char -> Datum
-;; number-const: Number -> Datum
-;; string-const: String -> Datum
-;; vector-const: Datum* -> Datum
-;; pair-const: Datum x Datum -> Datum
-;;
-;; Expr
-;;
-;; Datum < Expr
-;;
-;; var-def: Identifier -> VarDef
-;; variable: VarDef -> Expr
-;; identifier: Identifier -> Expr
-;; procedure-call: Expr x Expr* -> Expr
-;; lambda-expression: Formals x Body -> Expr
-;; conditional: Expr x Expr x Expr -> Expr
-;; assignment: Variable x Expr -> Expr
-;; cond-expression: CondClause+ -> Expr
-;; case-expression: Expr x CaseClause* -> Expr
-;; and-expression: Expr* -> Expr
-;; or-expression: Expr* -> Expr
-;; let-expression: (VarDef* x Expr*) x Body -> Expr
-;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
-;; let*-expression: (VarDef* x Expr*) x Body -> Expr
-;; letrec-expression: (VarDef* x Expr*) x Body -> Expr
-;; begin-expression: Expr+ -> Expr
-;; do-expression: IterDef* x CondClause x Expr* -> Expr
-;; empty: -> Expr
-;;
-;; VarDef* < Formals
-;;
-;; simple-formal: VarDef -> Formals
-;; dotted-formals: VarDef* x VarDef -> Formals
-;;
-;; Body = Definition* x Expr+ (reversed)
-;; CondClause = Expr x Expr+
-;; CaseClause = Datum* x Expr+
-;; IterDef = VarDef x Expr x Expr
-;;
-;; Definition
-;;
-;; definition: Identifier x Expr -> Definition
-;; function-definition: Identifier x Formals x Body -> Definition
-;; begin-command: Definition* -> Definition
-;;
-;; Expr < Command
-;; Definition < Command
-;;
-;; Program = Command*
-
-
-;; Abstract syntax operators
-
-; Datum
-
-(define null-const 0)
-(define boolean-const 1)
-(define char-const 2)
-(define number-const 3)
-(define string-const 4)
-(define symbol-const 5)
-(define vector-const 6)
-(define pair-const 7)
-
-; Bindings
-
-(define var-def 8)
-(define null-def 29)
-(define pair-def 30)
-
-; Expr
-
-(define variable 9)
-(define identifier 10)
-(define procedure-call 11)
-(define lambda-expression 12)
-(define conditional 13)
-(define assignment 14)
-(define cond-expression 15)
-(define case-expression 16)
-(define and-expression 17)
-(define or-expression 18)
-(define let-expression 19)
-(define named-let-expression 20)
-(define let*-expression 21)
-(define letrec-expression 22)
-(define begin-expression 23)
-(define do-expression 24)
-(define empty 25)
-(define null-arg 31)
-(define pair-arg 32)
-
-; Command
-
-(define definition 26)
-(define function-definition 27)
-(define begin-command 28)
-
-
-;; Parse actions for abstract syntax construction
-
-(define (dynamic-parse-action-null-const)
- ;; dynamic-parse-action for '()
- (ast-gen null-const '()))
-
-(define (dynamic-parse-action-boolean-const e)
- ;; dynamic-parse-action for #f and #t
- (ast-gen boolean-const e))
-
-(define (dynamic-parse-action-char-const e)
- ;; dynamic-parse-action for character constants
- (ast-gen char-const e))
-
-(define (dynamic-parse-action-number-const e)
- ;; dynamic-parse-action for number constants
- (ast-gen number-const e))
-
-(define (dynamic-parse-action-string-const e)
- ;; dynamic-parse-action for string literals
- (ast-gen string-const e))
-
-(define (dynamic-parse-action-symbol-const e)
- ;; dynamic-parse-action for symbol constants
- (ast-gen symbol-const e))
-
-(define (dynamic-parse-action-vector-const e)
- ;; dynamic-parse-action for vector literals
- (ast-gen vector-const e))
-
-(define (dynamic-parse-action-pair-const e1 e2)
- ;; dynamic-parse-action for pairs
- (ast-gen pair-const (cons e1 e2)))
-
-(define (dynamic-parse-action-var-def e)
- ;; dynamic-parse-action for defining occurrences of variables;
- ;; e is a symbol
- (ast-gen var-def e))
-
-(define (dynamic-parse-action-null-formal)
- ;; dynamic-parse-action for null-list of formals
- (ast-gen null-def '()))
-
-(define (dynamic-parse-action-pair-formal d1 d2)
- ;; dynamic-parse-action for non-null list of formals;
- ;; d1 is the result of parsing the first formal,
- ;; d2 the result of parsing the remaining formals
- (ast-gen pair-def (cons d1 d2)))
-
-(define (dynamic-parse-action-variable e)
- ;; dynamic-parse-action for applied occurrences of variables
- ;; ***Note***: e is the result of a dynamic-parse-action on the
- ;; corresponding variable definition!
- (ast-gen variable e))
-
-(define (dynamic-parse-action-identifier e)
- ;; dynamic-parse-action for undeclared identifiers (free variable
- ;; occurrences)
- ;; ***Note***: e is a symbol (legal identifier)
- (ast-gen identifier e))
-
-(define (dynamic-parse-action-null-arg)
- ;; dynamic-parse-action for a null list of arguments in a procedure call
- (ast-gen null-arg '()))
-
-(define (dynamic-parse-action-pair-arg a1 a2)
- ;; dynamic-parse-action for a non-null list of arguments in a procedure call
- ;; a1 is the result of parsing the first argument,
- ;; a2 the result of parsing the remaining arguments
- (ast-gen pair-arg (cons a1 a2)))
-
-(define (dynamic-parse-action-procedure-call op args)
- ;; dynamic-parse-action for procedure calls: op function, args list of arguments
- (ast-gen procedure-call (cons op args)))
-
-(define (dynamic-parse-action-lambda-expression formals body)
- ;; dynamic-parse-action for lambda-abstractions
- (ast-gen lambda-expression (cons formals body)))
-
-(define (dynamic-parse-action-conditional test then-branch else-branch)
- ;; dynamic-parse-action for conditionals (if-then-else expressions)
- (ast-gen conditional (cons test (cons then-branch else-branch))))
-
-(define (dynamic-parse-action-empty)
- ;; dynamic-parse-action for missing or empty field
- (ast-gen empty '()))
-
-(define (dynamic-parse-action-assignment lhs rhs)
- ;; dynamic-parse-action for assignment
- (ast-gen assignment (cons lhs rhs)))
-
-(define (dynamic-parse-action-begin-expression body)
- ;; dynamic-parse-action for begin-expression
- (ast-gen begin-expression body))
-
-(define (dynamic-parse-action-cond-expression clauses)
- ;; dynamic-parse-action for cond-expressions
- (ast-gen cond-expression clauses))
-
-(define (dynamic-parse-action-and-expression args)
- ;; dynamic-parse-action for and-expressions
- (ast-gen and-expression args))
-
-(define (dynamic-parse-action-or-expression args)
- ;; dynamic-parse-action for or-expressions
- (ast-gen or-expression args))
-
-(define (dynamic-parse-action-case-expression key clauses)
- ;; dynamic-parse-action for case-expressions
- (ast-gen case-expression (cons key clauses)))
-
-(define (dynamic-parse-action-let-expression bindings body)
- ;; dynamic-parse-action for let-expressions
- (ast-gen let-expression (cons bindings body)))
-
-(define (dynamic-parse-action-named-let-expression variable bindings body)
- ;; dynamic-parse-action for named-let expressions
- (ast-gen named-let-expression (cons variable (cons bindings body))))
-
-(define (dynamic-parse-action-let*-expression bindings body)
- ;; dynamic-parse-action for let-expressions
- (ast-gen let*-expression (cons bindings body)))
-
-(define (dynamic-parse-action-letrec-expression bindings body)
- ;; dynamic-parse-action for let-expressions
- (ast-gen letrec-expression (cons bindings body)))
-
-(define (dynamic-parse-action-definition variable expr)
- ;; dynamic-parse-action for simple definitions
- (ast-gen definition (cons variable expr)))
-
-(define (dynamic-parse-action-function-definition variable formals body)
- ;; dynamic-parse-action for function definitions
- (ast-gen function-definition (cons variable (cons formals body))))
-
-
-(define dynamic-parse-action-commands (lambda (a b) (cons a b)))
-;; dynamic-parse-action for processing a command result followed by a the
-;; result of processing the remaining commands
-
-
-;; Pretty-printing abstract syntax trees
-
-(define (ast-show ast)
- ;; converts abstract syntax tree to list representation (Scheme program)
- ;; ***Note***: check translation of constructors to numbers at the top of the file
- (let ((syntax-op (ast-con ast))
- (syntax-arg (ast-arg ast)))
- (case syntax-op
- ((0 1 2 3 4 8 10) syntax-arg)
- ((29 31) '())
- ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
- ((5) (list 'quote syntax-arg))
- ((6) (list->vector (map ast-show syntax-arg)))
- ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
- ((9) (ast-arg syntax-arg))
- ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
- ((12) (cons 'lambda (cons (ast-show (car syntax-arg))
- (map ast-show (cdr syntax-arg)))))
- ((13) (cons 'if (cons (ast-show (car syntax-arg))
- (cons (ast-show (cadr syntax-arg))
- (let ((alt (cddr syntax-arg)))
- (if (eqv? (ast-con alt) empty)
- '()
- (list (ast-show alt))))))))
- ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
- ((15) (cons 'cond
- (map (lambda (cc)
- (let ((guard (car cc))
- (body (cdr cc)))
- (cons
- (if (eqv? (ast-con guard) empty)
- 'else
- (ast-show guard))
- (map ast-show body))))
- syntax-arg)))
- ((16) (cons 'case
- (cons (ast-show (car syntax-arg))
- (map (lambda (cc)
- (let ((data (car cc)))
- (if (and (pair? data)
- (eqv? (ast-con (car data)) empty))
- (cons 'else
- (map ast-show (cdr cc)))
- (cons (map datum-show data)
- (map ast-show (cdr cc))))))
- (cdr syntax-arg)))))
- ((17) (cons 'and (map ast-show syntax-arg)))
- ((18) (cons 'or (map ast-show syntax-arg)))
- ((19) (cons 'let
- (cons (map
- (lambda (vd e)
- (list (ast-show vd) (ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map ast-show (cdr syntax-arg)))))
- ((20) (cons 'let
- (cons (ast-show (car syntax-arg))
- (cons (map
- (lambda (vd e)
- (list (ast-show vd) (ast-show e)))
- (caadr syntax-arg)
- (cdadr syntax-arg))
- (map ast-show (cddr syntax-arg))))))
- ((21) (cons 'let*
- (cons (map
- (lambda (vd e)
- (list (ast-show vd) (ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map ast-show (cdr syntax-arg)))))
- ((22) (cons 'letrec
- (cons (map
- (lambda (vd e)
- (list (ast-show vd) (ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map ast-show (cdr syntax-arg)))))
- ((23) (cons 'begin
- (map ast-show syntax-arg)))
- ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
- ((25) (error 'ast-show "This can't happen: empty encountered!"))
- ((26) (list 'define
- (ast-show (car syntax-arg))
- (ast-show (cdr syntax-arg))))
- ((27) (cons 'define
- (cons
- (cons (ast-show (car syntax-arg))
- (ast-show (cadr syntax-arg)))
- (map ast-show (cddr syntax-arg)))))
- ((28) (cons 'begin
- (map ast-show syntax-arg)))
- (else (error 'ast-show "Unknown abstract syntax operator: ~s"
- syntax-op)))))
-
-
-;; ast*-show
-
-(define (ast*-show p)
- ;; shows a list of abstract syntax trees
- (map ast-show p))
-
-
-;; datum-show
-
-(define (datum-show ast)
- ;; prints an abstract syntax tree as a datum
- (case (ast-con ast)
- ((0 1 2 3 4 5) (ast-arg ast))
- ((6) (list->vector (map datum-show (ast-arg ast))))
- ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
- (else (error 'datum-show "This should not happen!"))))
-
-; write-to-port
-
-(define (write-to-port prog port)
- ; writes a program to a port
- (for-each
- (lambda (command)
- (pretty-print command port)
- (newline port))
- prog)
- '())
-
-; write-file
-
-(define (write-to-file prog filename)
- ; write a program to a file
- (let ((port (open-output-file filename)))
- (write-to-port prog port)
- (close-output-port port)
- '()))
-
-; ----------------------------------------------------------------------------
-; Typed abstract syntax tree management: constraint generation, display, etc.
-; ----------------------------------------------------------------------------
-
-
-;; Abstract syntax operations, incl. constraint generation
-
-(define (ast-gen syntax-op arg)
- ; generates all attributes and performs semantic side effects
- (let ((ntvar
- (case syntax-op
- ((0 29 31) (null2))
- ((1) (boolean))
- ((2) (character))
- ((3) (number))
- ((4) (charseq))
- ((5) (symbol))
- ((6) (let ((aux-tvar (gen-tvar)))
- (for-each (lambda (t)
- (add-constr! t aux-tvar))
- (map ast-tvar arg))
- (array aux-tvar)))
- ((7 30 32) (let ((t1 (ast-tvar (car arg)))
- (t2 (ast-tvar (cdr arg))))
- (pair t1 t2)))
- ((8) (gen-tvar))
- ((9) (ast-tvar arg))
- ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
- (if in-env
- (instantiate-type (binding-value in-env))
- (let ((new-tvar (gen-tvar)))
- (set! dynamic-top-level-env (extend-env-with-binding
- dynamic-top-level-env
- (gen-binding arg new-tvar)))
- new-tvar))))
- ((11) (let ((new-tvar (gen-tvar)))
- (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
- (ast-tvar (car arg)))
- new-tvar))
- ((12) (procedure (ast-tvar (car arg))
- (ast-tvar (tail (cdr arg)))))
- ((13) (let ((t-test (ast-tvar (car arg)))
- (t-consequent (ast-tvar (cadr arg)))
- (t-alternate (ast-tvar (cddr arg))))
- (add-constr! (boolean) t-test)
- (add-constr! t-consequent t-alternate)
- t-consequent))
- ((14) (let ((var-tvar (ast-tvar (car arg)))
- (exp-tvar (ast-tvar (cdr arg))))
- (add-constr! var-tvar exp-tvar)
- var-tvar))
- ((15) (let ((new-tvar (gen-tvar)))
- (for-each (lambda (body)
- (add-constr! (ast-tvar (tail body)) new-tvar))
- (map cdr arg))
- (for-each (lambda (e)
- (add-constr! (boolean) (ast-tvar e)))
- (map car arg))
- new-tvar))
- ((16) (let* ((new-tvar (gen-tvar))
- (t-key (ast-tvar (car arg)))
- (case-clauses (cdr arg)))
- (for-each (lambda (exprs)
- (for-each (lambda (e)
- (add-constr! (ast-tvar e) t-key))
- exprs))
- (map car case-clauses))
- (for-each (lambda (body)
- (add-constr! (ast-tvar (tail body)) new-tvar))
- (map cdr case-clauses))
- new-tvar))
- ((17 18) (for-each (lambda (e)
- (add-constr! (boolean) (ast-tvar e)))
- arg)
- (boolean))
- ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
- (def-expr-types (map ast-tvar (cdar arg)))
- (body-type (ast-tvar (tail (cdr arg)))))
- (for-each add-constr! var-def-tvars def-expr-types)
- body-type))
- ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
- (def-expr-types (map ast-tvar (cdadr arg)))
- (body-type (ast-tvar (tail (cddr arg))))
- (named-var-type (ast-tvar (car arg))))
- (for-each add-constr! var-def-tvars def-expr-types)
- (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
- named-var-type)
- body-type))
- ((23) (ast-tvar (tail arg)))
- ((24) (error 'ast-gen
- "Do-expressions not handled! (Argument: ~s) arg"))
- ((25) (gen-tvar))
- ((26) (let ((t-var (ast-tvar (car arg)))
- (t-exp (ast-tvar (cdr arg))))
- (add-constr! t-var t-exp)
- t-var))
- ((27) (let ((t-var (ast-tvar (car arg)))
- (t-formals (ast-tvar (cadr arg)))
- (t-body (ast-tvar (tail (cddr arg)))))
- (add-constr! (procedure t-formals t-body) t-var)
- t-var))
- ((28) (gen-tvar))
- (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
- (cons syntax-op (cons ntvar arg))))
-
-(define ast-con car)
-;; extracts the ast-constructor from an abstract syntax tree
-
-(define ast-arg cddr)
-;; extracts the ast-argument from an abstract syntax tree
-
-(define ast-tvar cadr)
-;; extracts the tvar from an abstract syntax tree
-
-
-;; tail
-
-(define (tail l)
- ;; returns the tail of a nonempty list
- (if (null? (cdr l))
- (car l)
- (tail (cdr l))))
-
-; convert-tvars
-
-(define (convert-tvars tvar-list)
- ;; converts a list of tvars to a single tvar
- (cond
- ((null? tvar-list) (null2))
- ((pair? tvar-list) (pair (car tvar-list)
- (convert-tvars (cdr tvar-list))))
- (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))
-
-
-;; Pretty-printing abstract syntax trees
-
-(define (tast-show ast)
- ;; converts abstract syntax tree to list representation (Scheme program)
- (let ((syntax-op (ast-con ast))
- (syntax-tvar (tvar-show (ast-tvar ast)))
- (syntax-arg (ast-arg ast)))
- (cons
- (case syntax-op
- ((0 1 2 3 4 8 10) syntax-arg)
- ((29 31) '())
- ((30 32) (cons (tast-show (car syntax-arg))
- (tast-show (cdr syntax-arg))))
- ((5) (list 'quote syntax-arg))
- ((6) (list->vector (map tast-show syntax-arg)))
- ((7) (list 'cons (tast-show (car syntax-arg))
- (tast-show (cdr syntax-arg))))
- ((9) (ast-arg syntax-arg))
- ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
- ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
- (map tast-show (cdr syntax-arg)))))
- ((13) (cons 'if (cons (tast-show (car syntax-arg))
- (cons (tast-show (cadr syntax-arg))
- (let ((alt (cddr syntax-arg)))
- (if (eqv? (ast-con alt) empty)
- '()
- (list (tast-show alt))))))))
- ((14) (list 'set! (tast-show (car syntax-arg))
- (tast-show (cdr syntax-arg))))
- ((15) (cons 'cond
- (map (lambda (cc)
- (let ((guard (car cc))
- (body (cdr cc)))
- (cons
- (if (eqv? (ast-con guard) empty)
- 'else
- (tast-show guard))
- (map tast-show body))))
- syntax-arg)))
- ((16) (cons 'case
- (cons (tast-show (car syntax-arg))
- (map (lambda (cc)
- (let ((data (car cc)))
- (if (and (pair? data)
- (eqv? (ast-con (car data)) empty))
- (cons 'else
- (map tast-show (cdr cc)))
- (cons (map datum-show data)
- (map tast-show (cdr cc))))))
- (cdr syntax-arg)))))
- ((17) (cons 'and (map tast-show syntax-arg)))
- ((18) (cons 'or (map tast-show syntax-arg)))
- ((19) (cons 'let
- (cons (map
- (lambda (vd e)
- (list (tast-show vd) (tast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tast-show (cdr syntax-arg)))))
- ((20) (cons 'let
- (cons (tast-show (car syntax-arg))
- (cons (map
- (lambda (vd e)
- (list (tast-show vd) (tast-show e)))
- (caadr syntax-arg)
- (cdadr syntax-arg))
- (map tast-show (cddr syntax-arg))))))
- ((21) (cons 'let*
- (cons (map
- (lambda (vd e)
- (list (tast-show vd) (tast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tast-show (cdr syntax-arg)))))
- ((22) (cons 'letrec
- (cons (map
- (lambda (vd e)
- (list (tast-show vd) (tast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tast-show (cdr syntax-arg)))))
- ((23) (cons 'begin
- (map tast-show syntax-arg)))
- ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
- ((25) (error 'tast-show "This can't happen: empty encountered!"))
- ((26) (list 'define
- (tast-show (car syntax-arg))
- (tast-show (cdr syntax-arg))))
- ((27) (cons 'define
- (cons
- (cons (tast-show (car syntax-arg))
- (tast-show (cadr syntax-arg)))
- (map tast-show (cddr syntax-arg)))))
- ((28) (cons 'begin
- (map tast-show syntax-arg)))
- (else (error 'tast-show "Unknown abstract syntax operator: ~s"
- syntax-op)))
- syntax-tvar)))
-
-;; tast*-show
-
-(define (tast*-show p)
- ;; shows a list of abstract syntax trees
- (map tast-show p))
-
-
-;; counters for tagging/untagging
-
-(define untag-counter 0)
-(define no-untag-counter 0)
-(define tag-counter 0)
-(define no-tag-counter 0)
-(define may-untag-counter 0)
-(define no-may-untag-counter 0)
-
-(define (reset-counters!)
- (set! untag-counter 0)
- (set! no-untag-counter 0)
- (set! tag-counter 0)
- (set! no-tag-counter 0)
- (set! may-untag-counter 0)
- (set! no-may-untag-counter 0))
-
-(define (counters-show)
- (list
- (cons tag-counter no-tag-counter)
- (cons untag-counter no-untag-counter)
- (cons may-untag-counter no-may-untag-counter)))
-
-
-;; tag-show
-
-(define (tag-show tvar-rep prog)
- ; display prog with tagging operation
- (if (eqv? tvar-rep dynamic)
- (begin
- (set! tag-counter (+ tag-counter 1))
- (list 'tag prog))
- (begin
- (set! no-tag-counter (+ no-tag-counter 1))
- (list 'no-tag prog))))
-
-
-;; untag-show
-
-(define (untag-show tvar-rep prog)
- ; display prog with untagging operation
- (if (eqv? tvar-rep dynamic)
- (begin
- (set! untag-counter (+ untag-counter 1))
- (list 'untag prog))
- (begin
- (set! no-untag-counter (+ no-untag-counter 1))
- (list 'no-untag prog))))
-
-(define (may-untag-show tvar-rep prog)
- ; display possible untagging in actual arguments
- (if (eqv? tvar-rep dynamic)
- (begin
- (set! may-untag-counter (+ may-untag-counter 1))
- (list 'may-untag prog))
- (begin
- (set! no-may-untag-counter (+ no-may-untag-counter 1))
- (list 'no-may-untag prog))))
-
-
-;; tag-ast-show
-
-(define (tag-ast-show ast)
- ;; converts typed and normalized abstract syntax tree to
- ;; a Scheme program with explicit tagging and untagging operations
- (let ((syntax-op (ast-con ast))
- (syntax-tvar (find! (ast-tvar ast)))
- (syntax-arg (ast-arg ast)))
- (case syntax-op
- ((0 1 2 3 4)
- (tag-show syntax-tvar syntax-arg))
- ((8 10) syntax-arg)
- ((29 31) '())
- ((30) (cons (tag-ast-show (car syntax-arg))
- (tag-ast-show (cdr syntax-arg))))
- ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
- (tag-ast-show (car syntax-arg)))
- (tag-ast-show (cdr syntax-arg))))
- ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
- ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
- ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
- (tag-ast-show (cdr syntax-arg)))))
- ((9) (ast-arg syntax-arg))
- ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
- (cons (untag-show proc-tvar
- (tag-ast-show (car syntax-arg)))
- (tag-ast-show (cdr syntax-arg)))))
- ((12) (tag-show syntax-tvar
- (cons 'lambda (cons (tag-ast-show (car syntax-arg))
- (map tag-ast-show (cdr syntax-arg))))))
- ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
- (cons 'if (cons (untag-show test-tvar
- (tag-ast-show (car syntax-arg)))
- (cons (tag-ast-show (cadr syntax-arg))
- (let ((alt (cddr syntax-arg)))
- (if (eqv? (ast-con alt) empty)
- '()
- (list (tag-ast-show alt)))))))))
- ((14) (list 'set! (tag-ast-show (car syntax-arg))
- (tag-ast-show (cdr syntax-arg))))
- ((15) (cons 'cond
- (map (lambda (cc)
- (let ((guard (car cc))
- (body (cdr cc)))
- (cons
- (if (eqv? (ast-con guard) empty)
- 'else
- (untag-show (find! (ast-tvar guard))
- (tag-ast-show guard)))
- (map tag-ast-show body))))
- syntax-arg)))
- ((16) (cons 'case
- (cons (tag-ast-show (car syntax-arg))
- (map (lambda (cc)
- (let ((data (car cc)))
- (if (and (pair? data)
- (eqv? (ast-con (car data)) empty))
- (cons 'else
- (map tag-ast-show (cdr cc)))
- (cons (map datum-show data)
- (map tag-ast-show (cdr cc))))))
- (cdr syntax-arg)))))
- ((17) (cons 'and (map
- (lambda (ast)
- (let ((bool-tvar (find! (ast-tvar ast))))
- (untag-show bool-tvar (tag-ast-show ast))))
- syntax-arg)))
- ((18) (cons 'or (map
- (lambda (ast)
- (let ((bool-tvar (find! (ast-tvar ast))))
- (untag-show bool-tvar (tag-ast-show ast))))
- syntax-arg)))
- ((19) (cons 'let
- (cons (map
- (lambda (vd e)
- (list (tag-ast-show vd) (tag-ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tag-ast-show (cdr syntax-arg)))))
- ((20) (cons 'let
- (cons (tag-ast-show (car syntax-arg))
- (cons (map
- (lambda (vd e)
- (list (tag-ast-show vd) (tag-ast-show e)))
- (caadr syntax-arg)
- (cdadr syntax-arg))
- (map tag-ast-show (cddr syntax-arg))))))
- ((21) (cons 'let*
- (cons (map
- (lambda (vd e)
- (list (tag-ast-show vd) (tag-ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tag-ast-show (cdr syntax-arg)))))
- ((22) (cons 'letrec
- (cons (map
- (lambda (vd e)
- (list (tag-ast-show vd) (tag-ast-show e)))
- (caar syntax-arg)
- (cdar syntax-arg))
- (map tag-ast-show (cdr syntax-arg)))))
- ((23) (cons 'begin
- (map tag-ast-show syntax-arg)))
- ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
- ((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
- ((26) (list 'define
- (tag-ast-show (car syntax-arg))
- (tag-ast-show (cdr syntax-arg))))
- ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg)))))
- (list 'define
- (tag-ast-show (car syntax-arg))
- (tag-show func-tvar
- (cons 'lambda
- (cons (tag-ast-show (cadr syntax-arg))
- (map tag-ast-show (cddr syntax-arg))))))))
- ((28) (cons 'begin
- (map tag-ast-show syntax-arg)))
- (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
- syntax-op)))))
-
-
-; tag-ast*-show
-
-(define (tag-ast*-show p)
- ; display list of commands/expressions with tagging/untagging
- ; operations
- (map tag-ast-show p))
-; ----------------------------------------------------------------------------
-; Top level type environment
-; ----------------------------------------------------------------------------
-
-
-; Needed packages: type management (monomorphic and polymorphic)
-
-;(load "typ-mgmt.ss")
-;(load "ptyp-mgm.ss")
-
-
-; type environment for miscellaneous
-
-(define misc-env
- (list
- (cons 'quote (forall (lambda (tv) tv)))
- (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
- (boolean)))))
- (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
- (boolean)))))
- (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
- (boolean)))))
- ))
-
-; type environment for input/output
-
-(define io-env
- (list
- (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic))
- (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean)))
- (cons 'read (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) dynamic))))
- (cons 'write (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) dynamic))))
- (cons 'display (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) dynamic))))
- (cons 'newline (procedure (null2) dynamic))
- (cons 'pretty-print (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) dynamic))))))
-
-
-; type environment for Booleans
-
-(define boolean-env
- (list
- (cons 'boolean? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- ;(cons #f (boolean))
- ; #f doesn't exist in Chez Scheme, but gets mapped to null!
- (cons #t (boolean))
- (cons 'not (procedure (convert-tvars (list (boolean))) (boolean)))
- ))
-
-
-; type environment for pairs and lists
-
-(define (list-type tv)
- (fix (lambda (tv2) (pair tv tv2))))
-
-(define list-env
- (list
- (cons 'pair? (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)))
- (boolean)))))
- (cons 'null? (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)))
- (boolean)))))
- (cons 'list? (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)))
- (boolean)))))
- (cons 'cons (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list tv1 tv2))
- (pair tv1 tv2)))))
- (cons 'car (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)))
- tv1))))
- (cons 'cdr (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)))
- tv2))))
- (cons 'set-car! (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)
- tv1))
- dynamic))))
- (cons 'set-cdr! (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars (list (pair tv1 tv2)
- tv2))
- dynamic))))
- (cons 'caar (forall3 (lambda (tv1 tv2 tv3)
- (procedure (convert-tvars
- (list (pair (pair tv1 tv2) tv3)))
- tv1))))
- (cons 'cdar (forall3 (lambda (tv1 tv2 tv3)
- (procedure (convert-tvars
- (list (pair (pair tv1 tv2) tv3)))
- tv2))))
-
- (cons 'cadr (forall3 (lambda (tv1 tv2 tv3)
- (procedure (convert-tvars
- (list (pair tv1 (pair tv2 tv3))))
- tv2))))
- (cons 'cddr (forall3 (lambda (tv1 tv2 tv3)
- (procedure (convert-tvars
- (list (pair tv1 (pair tv2 tv3))))
- tv3))))
- (cons 'caaar (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair (pair (pair tv1 tv2) tv3) tv4)))
- tv1))))
- (cons 'cdaar (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair (pair (pair tv1 tv2) tv3) tv4)))
- tv2))))
- (cons 'cadar (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
- tv2))))
- (cons 'cddar (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
- tv3))))
- (cons 'caadr (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair tv1 (pair (pair tv2 tv3) tv4))))
- tv2))))
- (cons 'cdadr (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair tv1 (pair (pair tv2 tv3) tv4))))
- tv3))))
- (cons 'caddr (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
- tv3))))
- (cons 'cdddr (forall4
- (lambda (tv1 tv2 tv3 tv4)
- (procedure (convert-tvars
- (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
- tv4))))
- (cons 'cadddr
- (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
- (procedure (convert-tvars
- (list (pair tv1
- (pair tv2
- (pair tv3
- (pair tv4 tv5))))))
- tv4))))
- (cons 'cddddr
- (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
- (procedure (convert-tvars
- (list (pair tv1
- (pair tv2
- (pair tv3
- (pair tv4 tv5))))))
- tv5))))
- (cons 'list (forall (lambda (tv)
- (procedure tv tv))))
- (cons 'length (forall (lambda (tv)
- (procedure (convert-tvars (list (list-type tv)))
- (number)))))
- (cons 'append (forall (lambda (tv)
- (procedure (convert-tvars (list (list-type tv)
- (list-type tv)))
- (list-type tv)))))
- (cons 'reverse (forall (lambda (tv)
- (procedure (convert-tvars (list (list-type tv)))
- (list-type tv)))))
- (cons 'list-ref (forall (lambda (tv)
- (procedure (convert-tvars (list (list-type tv)
- (number)))
- tv))))
- (cons 'memq (forall (lambda (tv)
- (procedure (convert-tvars (list tv
- (list-type tv)))
- (boolean)))))
- (cons 'memv (forall (lambda (tv)
- (procedure (convert-tvars (list tv
- (list-type tv)))
- (boolean)))))
- (cons 'member (forall (lambda (tv)
- (procedure (convert-tvars (list tv
- (list-type tv)))
- (boolean)))))
- (cons 'assq (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list tv1
- (list-type (pair tv1 tv2))))
- (pair tv1 tv2)))))
- (cons 'assv (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list tv1
- (list-type (pair tv1 tv2))))
- (pair tv1 tv2)))))
- (cons 'assoc (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list tv1
- (list-type (pair tv1 tv2))))
- (pair tv1 tv2)))))
- ))
-
-
-(define symbol-env
- (list
- (cons 'symbol? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq)))
- (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol)))
- ))
-
-(define number-env
- (list
- (cons 'number? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- (cons '+ (procedure (convert-tvars (list (number) (number))) (number)))
- (cons '- (procedure (convert-tvars (list (number) (number))) (number)))
- (cons '* (procedure (convert-tvars (list (number) (number))) (number)))
- (cons '/ (procedure (convert-tvars (list (number) (number))) (number)))
- (cons 'number->string (procedure (convert-tvars (list (number))) (charseq)))
- (cons 'string->number (procedure (convert-tvars (list (charseq))) (number)))
- ))
-
-(define char-env
- (list
- (cons 'char? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- (cons 'char->integer (procedure (convert-tvars (list (character)))
- (number)))
- (cons 'integer->char (procedure (convert-tvars (list (number)))
- (character)))
- ))
-
-(define string-env
- (list
- (cons 'string? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- ))
-
-(define vector-env
- (list
- (cons 'vector? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- (cons 'make-vector (forall (lambda (tv)
- (procedure (convert-tvars (list (number)))
- (array tv)))))
- (cons 'vector-length (forall (lambda (tv)
- (procedure (convert-tvars (list (array tv)))
- (number)))))
- (cons 'vector-ref (forall (lambda (tv)
- (procedure (convert-tvars (list (array tv)
- (number)))
- tv))))
- (cons 'vector-set! (forall (lambda (tv)
- (procedure (convert-tvars (list (array tv)
- (number)
- tv))
- dynamic))))
- ))
-
-(define procedure-env
- (list
- (cons 'procedure? (forall (lambda (tv)
- (procedure (convert-tvars (list tv)) (boolean)))))
- (cons 'map (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list (procedure (convert-tvars
- (list tv1)) tv2)
- (list-type tv1)))
- (list-type tv2)))))
- (cons 'foreach (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list (procedure (convert-tvars
- (list tv1)) tv2)
- (list-type tv1)))
- (list-type tv2)))))
- (cons 'call-with-current-continuation
- (forall2 (lambda (tv1 tv2)
- (procedure (convert-tvars
- (list (procedure
- (convert-tvars
- (list (procedure (convert-tvars
- (list tv1)) tv2)))
- tv2)))
- tv2))))
- ))
-
-
-; global top level environment
-
-(define (global-env)
- (append misc-env
- io-env
- boolean-env
- symbol-env
- number-env
- char-env
- string-env
- vector-env
- procedure-env
- list-env))
-
-(define dynamic-top-level-env (global-env))
-
-(define (init-dynamic-top-level-env!)
- (set! dynamic-top-level-env (global-env))
- '())
-
-(define (dynamic-top-level-env-show)
- ; displays the top level environment
- (map (lambda (binding)
- (cons (key-show (binding-key binding))
- (cons ': (tvar-show (binding-value binding)))))
- (env->list dynamic-top-level-env)))
-; ----------------------------------------------------------------------------
-; Dynamic type inference for Scheme
-; ----------------------------------------------------------------------------
-
-; Needed packages:
-
-(define (ic!) (init-global-constraints!))
-(define (pc) (glob-constr-show))
-(define (lc) (length global-constraints))
-(define (n!) (normalize-global-constraints!))
-(define (pt) (dynamic-top-level-env-show))
-(define (it!) (init-dynamic-top-level-env!))
-(define (io!) (set! tag-ops 0) (set! no-ops 0))
-(define (i!) (ic!) (it!) (io!) '())
-
-(define tag-ops 0)
-(define no-ops 0)
-
-
-(define doit
- (lambda ()
- (i!)
- (let ((foo (dynamic-parse-file "dynamic.scm")))
- (normalize-global-constraints!)
- (reset-counters!)
- (tag-ast*-show foo)
- (counters-show))))
-
-(let ((result (time (doit))))
- (if (not (equal? result '((330 . 339) (6 . 1895) (2306 . 344))))
- (error "wrong result" result) ) )
diff --git a/benchmarks/earley.scm b/benchmarks/earley.scm
deleted file mode 100644
index 163e57c5..00000000
--- a/benchmarks/earley.scm
+++ /dev/null
@@ -1,646 +0,0 @@
-;;; EARLEY -- Earley's parser, written by Marc Feeley.
-
-; (make-parser grammar lexer) is used to create a parser from the grammar
-; description `grammar' and the lexer function `lexer'.
-;
-; A grammar is a list of definitions. Each definition defines a non-terminal
-; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
-; A given non-terminal can only be defined once. The first non-terminal
-; defined is the grammar's goal. Each rule is a possibly empty list of
-; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
-; can be any scheme value. Note that all grammar symbols are treated as
-; non-terminals. This is fine though because the lexer will be outputing
-; non-terminals.
-;
-; The lexer defines what a token is and the mapping between tokens and
-; the grammar's non-terminals. It is a function of one argument, the input,
-; that returns the list of tokens corresponding to the input. Each token is
-; represented by a list. The first element is some `user-defined' information
-; associated with the token and the rest represents the token's class(es) (as a
-; list of non-terminals that this token corresponds to).
-;
-; The result of `make-parser' is a function that parses the single input it
-; is given into the grammar's goal. The result is a `parse' which can be
-; manipulated with the procedures: `parse->parsed?', `parse->trees'
-; and `parse->nb-trees' (see below).
-;
-; Let's assume that we want a parser for the grammar
-;
-; S -> x = E
-; E -> E + E | V
-; V -> V y |
-;
-; and that the input to the parser is a string of characters. Also, assume we
-; would like to map the characters `x', `y', `+' and `=' into the corresponding
-; non-terminals in the grammar. Such a parser could be created with
-;
-; (make-parser
-; '(
-; (s (x = e))
-; (e (e + e) (v))
-; (v (v y) ())
-; )
-; (lambda (str)
-; (map (lambda (char)
-; (list char ; user-info = the character itself
-; (case char
-; ((#\x) 'x)
-; ((#\y) 'y)
-; ((#\+) '+)
-; ((#\=) '=)
-; (else (fatal-error "lexer error")))))
-; (string->list str)))
-; )
-;
-; An alternative definition (that does not check for lexical errors) is
-;
-; (make-parser
-; '(
-; (s (#\x #\= e))
-; (e (e #\+ e) (v))
-; (v (v #\y) ())
-; )
-; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
-; )
-;
-; To help with the rest of the discussion, here are a few definitions:
-;
-; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
-; It indicates a point between two input tokens (0 = beginning, `n' = end).
-; For example, if `n' = 4, there are 5 input pointers:
-;
-; input token1 token2 token3 token4
-; input pointers 0 1 2 3 4
-;
-; A configuration indicates the extent to which a given rule is parsed (this
-; is the common `dot notation'). For simplicity, a configuration is
-; represented as an integer, with successive configurations in the same
-; rule associated with successive integers. It is assumed that the grammar
-; has been extended with rules to aid scanning. These rules are of the
-; form `nt ->', and there is one such rule for every non-terminal. Note
-; that these rules are special because they only apply when the corresponding
-; non-terminal is returned by the lexer.
-;
-; A configuration set is a configuration grouped with the set of input pointers
-; representing where the head non-terminal of the configuration was predicted.
-;
-; Here are the rules and configurations for the grammar given above:
-;
-; S -> . \
-; 0 |
-; x -> . |
-; 1 |
-; = -> . |
-; 2 |
-; E -> . |
-; 3 > special rules (for scanning)
-; + -> . |
-; 4 |
-; V -> . |
-; 5 |
-; y -> . |
-; 6 /
-; S -> . x . = . E .
-; 7 8 9 10
-; E -> . E . + . E .
-; 11 12 13 14
-; E -> . V .
-; 15 16
-; V -> . V . y .
-; 17 18 19
-; V -> .
-; 20
-;
-; Starters of the non-terminal `nt' are configurations that are leftmost
-; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
-; configurations that are rightmost in any rule for `nt'. Predictors of the
-; non-terminal `nt' are configurations that are directly to the left of `nt'
-; in any rule.
-;
-; For the grammar given above,
-;
-; Starters of V = (17 20)
-; Enders of V = (5 19 20)
-; Predictors of V = (15 17)
-
-(define (make-parser grammar lexer)
-
- (define (non-terminals grammar) ; return vector of non-terminals in grammar
-
- (define (add-nt nt nts)
- (if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
-
- (let def-loop ((defs grammar) (nts '()))
- (if (pair? defs)
- (let* ((def (car defs))
- (head (car def)))
- (let rule-loop ((rules (cdr def))
- (nts (add-nt head nts)))
- (if (pair? rules)
- (let ((rule (car rules)))
- (let loop ((l rule) (nts nts))
- (if (pair? l)
- (let ((nt (car l)))
- (loop (cdr l) (add-nt nt nts)))
- (rule-loop (cdr rules) nts))))
- (def-loop (cdr defs) nts))))
- (list->vector (reverse nts))))) ; goal non-terminal must be at index 0
-
- (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
- (let loop ((i (- (vector-length nts) 1)))
- (if (>= i 0)
- (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
- #f)))
-
- (define (nb-configurations grammar) ; return nb of configurations in grammar
- (let def-loop ((defs grammar) (nb-confs 0))
- (if (pair? defs)
- (let ((def (car defs)))
- (let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
- (if (pair? rules)
- (let ((rule (car rules)))
- (let loop ((l rule) (nb-confs nb-confs))
- (if (pair? l)
- (loop (cdr l) (+ nb-confs 1))
- (rule-loop (cdr rules) (+ nb-confs 1)))))
- (def-loop (cdr defs) nb-confs))))
- nb-confs)))
-
-; First, associate a numeric identifier to every non-terminal in the
-; grammar (with the goal non-terminal associated with 0).
-;
-; So, for the grammar given above we get:
-;
-; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
-
- (let* ((nts (non-terminals grammar)) ; id map = list of non-terms
- (nb-nts (vector-length nts)) ; the number of non-terms
- (nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
- (starters (make-vector nb-nts '())) ; starters for every non-term
- (enders (make-vector nb-nts '())) ; enders for every non-term
- (predictors (make-vector nb-nts '())) ; predictors for every non-term
- (steps (make-vector nb-confs #f)) ; what to do in a given conf
- (names (make-vector nb-confs #f))) ; name of rules
-
- (define (setup-tables grammar nts starters enders predictors steps names)
-
- (define (add-conf conf nt nts class)
- (let ((i (ind nt nts)))
- (vector-set! class i (cons conf (vector-ref class i)))))
-
- (let ((nb-nts (vector-length nts)))
-
- (let nt-loop ((i (- nb-nts 1)))
- (if (>= i 0)
- (begin
- (vector-set! steps i (- i nb-nts))
- (vector-set! names i (list (vector-ref nts i) 0))
- (vector-set! enders i (list i))
- (nt-loop (- i 1)))))
-
- (let def-loop ((defs grammar) (conf (vector-length nts)))
- (if (pair? defs)
- (let* ((def (car defs))
- (head (car def)))
- (let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
- (if (pair? rules)
- (let ((rule (car rules)))
- (vector-set! names conf (list head rule-num))
- (add-conf conf head nts starters)
- (let loop ((l rule) (conf conf))
- (if (pair? l)
- (let ((nt (car l)))
- (vector-set! steps conf (ind nt nts))
- (add-conf conf nt nts predictors)
- (loop (cdr l) (+ conf 1)))
- (begin
- (vector-set! steps conf (- (ind head nts) nb-nts))
- (add-conf conf head nts enders)
- (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
- (def-loop (cdr defs) conf))))))))
-
-; Now, for each non-terminal, compute the starters, enders and predictors and
-; the names and steps tables.
-
- (setup-tables grammar nts starters enders predictors steps names)
-
-; Build the parser description
-
- (let ((parser-descr (vector lexer
- nts
- starters
- enders
- predictors
- steps
- names)))
- (lambda (input)
-
- (define (ind nt nts) ; return index of non-terminal `nt' in `nts'
- (let loop ((i (- (vector-length nts) 1)))
- (if (>= i 0)
- (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
- #f)))
-
- (define (comp-tok tok nts) ; transform token to parsing format
- (let loop ((l1 (cdr tok)) (l2 '()))
- (if (pair? l1)
- (let ((i (ind (car l1) nts)))
- (if i
- (loop (cdr l1) (cons i l2))
- (loop (cdr l1) l2)))
- (cons (car tok) (reverse l2)))))
-
- (define (input->tokens input lexer nts)
- (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
-
- (define (make-states nb-toks nb-confs)
- (let ((states (make-vector (+ nb-toks 1) #f)))
- (let loop ((i nb-toks))
- (if (>= i 0)
- (let ((v (make-vector (+ nb-confs 1) #f)))
- (vector-set! v 0 -1)
- (vector-set! states i v)
- (loop (- i 1)))
- states))))
-
- (define (conf-set-get state conf)
- (vector-ref state (+ conf 1)))
-
- (define (conf-set-get* state state-num conf)
- (let ((conf-set (conf-set-get state conf)))
- (if conf-set
- conf-set
- (let ((conf-set (make-vector (+ state-num 6) #f)))
- (vector-set! conf-set 1 -3) ; old elems tail (points to head)
- (vector-set! conf-set 2 -1) ; old elems head
- (vector-set! conf-set 3 -1) ; new elems tail (points to head)
- (vector-set! conf-set 4 -1) ; new elems head
- (vector-set! state (+ conf 1) conf-set)
- conf-set))))
-
- (define (conf-set-merge-new! conf-set)
- (vector-set! conf-set
- (+ (vector-ref conf-set 1) 5)
- (vector-ref conf-set 4))
- (vector-set! conf-set 1 (vector-ref conf-set 3))
- (vector-set! conf-set 3 -1)
- (vector-set! conf-set 4 -1))
-
- (define (conf-set-head conf-set)
- (vector-ref conf-set 2))
-
- (define (conf-set-next conf-set i)
- (vector-ref conf-set (+ i 5)))
-
- (define (conf-set-member? state conf i)
- (let ((conf-set (vector-ref state (+ conf 1))))
- (if conf-set
- (conf-set-next conf-set i)
- #f)))
-
- (define (conf-set-adjoin state conf-set conf i)
- (let ((tail (vector-ref conf-set 3))) ; put new element at tail
- (vector-set! conf-set (+ i 5) -1)
- (vector-set! conf-set (+ tail 5) i)
- (vector-set! conf-set 3 i)
- (if (< tail 0)
- (begin
- (vector-set! conf-set 0 (vector-ref state 0))
- (vector-set! state 0 conf)))))
-
- (define (conf-set-adjoin* states state-num l i)
- (let ((state (vector-ref states state-num)))
- (let loop ((l1 l))
- (if (pair? l1)
- (let* ((conf (car l1))
- (conf-set (conf-set-get* state state-num conf)))
- (if (not (conf-set-next conf-set i))
- (begin
- (conf-set-adjoin state conf-set conf i)
- (loop (cdr l1)))
- (loop (cdr l1))))))))
-
- (define (conf-set-adjoin** states states* state-num conf i)
- (let ((state (vector-ref states state-num)))
- (if (conf-set-member? state conf i)
- (let* ((state* (vector-ref states* state-num))
- (conf-set* (conf-set-get* state* state-num conf)))
- (if (not (conf-set-next conf-set* i))
- (conf-set-adjoin state* conf-set* conf i))
- #t)
- #f)))
-
- (define (conf-set-union state conf-set conf other-set)
- (let loop ((i (conf-set-head other-set)))
- (if (>= i 0)
- (if (not (conf-set-next conf-set i))
- (begin
- (conf-set-adjoin state conf-set conf i)
- (loop (conf-set-next other-set i)))
- (loop (conf-set-next other-set i))))))
-
- (define (forw states state-num starters enders predictors steps nts)
-
- (define (predict state state-num conf-set conf nt starters enders)
-
- ; add configurations which start the non-terminal `nt' to the
- ; right of the dot
-
- (let loop1 ((l (vector-ref starters nt)))
- (if (pair? l)
- (let* ((starter (car l))
- (starter-set (conf-set-get* state state-num starter)))
- (if (not (conf-set-next starter-set state-num))
- (begin
- (conf-set-adjoin state starter-set starter state-num)
- (loop1 (cdr l)))
- (loop1 (cdr l))))))
-
- ; check for possible completion of the non-terminal `nt' to the
- ; right of the dot
-
- (let loop2 ((l (vector-ref enders nt)))
- (if (pair? l)
- (let ((ender (car l)))
- (if (conf-set-member? state ender state-num)
- (let* ((next (+ conf 1))
- (next-set (conf-set-get* state state-num next)))
- (conf-set-union state next-set next conf-set)
- (loop2 (cdr l)))
- (loop2 (cdr l)))))))
-
- (define (reduce states state state-num conf-set head preds)
-
- ; a non-terminal is now completed so check for reductions that
- ; are now possible at the configurations `preds'
-
- (let loop1 ((l preds))
- (if (pair? l)
- (let ((pred (car l)))
- (let loop2 ((i head))
- (if (>= i 0)
- (let ((pred-set (conf-set-get (vector-ref states i) pred)))
- (if pred-set
- (let* ((next (+ pred 1))
- (next-set (conf-set-get* state state-num next)))
- (conf-set-union state next-set next pred-set)))
- (loop2 (conf-set-next conf-set i)))
- (loop1 (cdr l))))))))
-
- (let ((state (vector-ref states state-num))
- (nb-nts (vector-length nts)))
- (let loop ()
- (let ((conf (vector-ref state 0)))
- (if (>= conf 0)
- (let* ((step (vector-ref steps conf))
- (conf-set (vector-ref state (+ conf 1)))
- (head (vector-ref conf-set 4)))
- (vector-set! state 0 (vector-ref conf-set 0))
- (conf-set-merge-new! conf-set)
- (if (>= step 0)
- (predict state state-num conf-set conf step starters enders)
- (let ((preds (vector-ref predictors (+ step nb-nts))))
- (reduce states state state-num conf-set head preds)))
- (loop)))))))
-
- (define (forward starters enders predictors steps nts toks)
- (let* ((nb-toks (vector-length toks))
- (nb-confs (vector-length steps))
- (states (make-states nb-toks nb-confs))
- (goal-starters (vector-ref starters 0)))
- (conf-set-adjoin* states 0 goal-starters 0) ; predict goal
- (forw states 0 starters enders predictors steps nts)
- (let loop ((i 0))
- (if (< i nb-toks)
- (let ((tok-nts (cdr (vector-ref toks i))))
- (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
- (forw states (+ i 1) starters enders predictors steps nts)
- (loop (+ i 1)))))
- states))
-
- (define (produce conf i j enders steps toks states states* nb-nts)
- (let ((prev (- conf 1)))
- (if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
- (let loop1 ((l (vector-ref enders (vector-ref steps prev))))
- (if (pair? l)
- (let* ((ender (car l))
- (ender-set (conf-set-get (vector-ref states j)
- ender)))
- (if ender-set
- (let loop2 ((k (conf-set-head ender-set)))
- (if (>= k 0)
- (begin
- (and (>= k i)
- (conf-set-adjoin** states states* k prev i)
- (conf-set-adjoin** states states* j ender k))
- (loop2 (conf-set-next ender-set k)))
- (loop1 (cdr l))))
- (loop1 (cdr l)))))))))
-
- (define (back states states* state-num enders steps nb-nts toks)
- (let ((state* (vector-ref states* state-num)))
- (let loop1 ()
- (let ((conf (vector-ref state* 0)))
- (if (>= conf 0)
- (let* ((conf-set (vector-ref state* (+ conf 1)))
- (head (vector-ref conf-set 4)))
- (vector-set! state* 0 (vector-ref conf-set 0))
- (conf-set-merge-new! conf-set)
- (let loop2 ((i head))
- (if (>= i 0)
- (begin
- (produce conf i state-num enders steps
- toks states states* nb-nts)
- (loop2 (conf-set-next conf-set i)))
- (loop1)))))))))
-
- (define (backward states enders steps nts toks)
- (let* ((nb-toks (vector-length toks))
- (nb-confs (vector-length steps))
- (nb-nts (vector-length nts))
- (states* (make-states nb-toks nb-confs))
- (goal-enders (vector-ref enders 0)))
- (let loop1 ((l goal-enders))
- (if (pair? l)
- (let ((conf (car l)))
- (conf-set-adjoin** states states* nb-toks conf 0)
- (loop1 (cdr l)))))
- (let loop2 ((i nb-toks))
- (if (>= i 0)
- (begin
- (back states states* i enders steps nb-nts toks)
- (loop2 (- i 1)))))
- states*))
-
- (define (parsed? nt i j nts enders states)
- (let ((nt* (ind nt nts)))
- (if nt*
- (let ((nb-nts (vector-length nts)))
- (let loop ((l (vector-ref enders nt*)))
- (if (pair? l)
- (let ((conf (car l)))
- (if (conf-set-member? (vector-ref states j) conf i)
- #t
- (loop (cdr l))))
- #f)))
- #f)))
-
- (define (deriv-trees conf i j enders steps names toks states nb-nts)
- (let ((name (vector-ref names conf)))
-
- (if name ; `conf' is at the start of a rule (either special or not)
- (if (< conf nb-nts)
- (list (list name (car (vector-ref toks i))))
- (list (list name)))
-
- (let ((prev (- conf 1)))
- (let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
- (l2 '()))
- (if (pair? l1)
- (let* ((ender (car l1))
- (ender-set (conf-set-get (vector-ref states j)
- ender)))
- (if ender-set
- (let loop2 ((k (conf-set-head ender-set)) (l2 l2))
- (if (>= k 0)
- (if (and (>= k i)
- (conf-set-member? (vector-ref states k)
- prev i))
- (let ((prev-trees
- (deriv-trees prev i k enders steps names
- toks states nb-nts))
- (ender-trees
- (deriv-trees ender k j enders steps names
- toks states nb-nts)))
- (let loop3 ((l3 ender-trees) (l2 l2))
- (if (pair? l3)
- (let ((ender-tree (list (car l3))))
- (let loop4 ((l4 prev-trees) (l2 l2))
- (if (pair? l4)
- (loop4 (cdr l4)
- (cons (append (car l4)
- ender-tree)
- l2))
- (loop3 (cdr l3) l2))))
- (loop2 (conf-set-next ender-set k) l2))))
- (loop2 (conf-set-next ender-set k) l2))
- (loop1 (cdr l1) l2)))
- (loop1 (cdr l1) l2)))
- l2))))))
-
- (define (deriv-trees* nt i j nts enders steps names toks states)
- (let ((nt* (ind nt nts)))
- (if nt*
- (let ((nb-nts (vector-length nts)))
- (let loop ((l (vector-ref enders nt*)) (trees '()))
- (if (pair? l)
- (let ((conf (car l)))
- (if (conf-set-member? (vector-ref states j) conf i)
- (loop (cdr l)
- (append (deriv-trees conf i j enders steps names
- toks states nb-nts)
- trees))
- (loop (cdr l) trees)))
- trees)))
- #f)))
-
- (define (nb-deriv-trees conf i j enders steps toks states nb-nts)
- (let ((prev (- conf 1)))
- (if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
- 1
- (let loop1 ((l (vector-ref enders (vector-ref steps prev)))
- (n 0))
- (if (pair? l)
- (let* ((ender (car l))
- (ender-set (conf-set-get (vector-ref states j)
- ender)))
- (if ender-set
- (let loop2 ((k (conf-set-head ender-set)) (n n))
- (if (>= k 0)
- (if (and (>= k i)
- (conf-set-member? (vector-ref states k)
- prev i))
- (let ((nb-prev-trees
- (nb-deriv-trees prev i k enders steps
- toks states nb-nts))
- (nb-ender-trees
- (nb-deriv-trees ender k j enders steps
- toks states nb-nts)))
- (loop2 (conf-set-next ender-set k)
- (+ n (* nb-prev-trees nb-ender-trees))))
- (loop2 (conf-set-next ender-set k) n))
- (loop1 (cdr l) n)))
- (loop1 (cdr l) n)))
- n)))))
-
- (define (nb-deriv-trees* nt i j nts enders steps toks states)
- (let ((nt* (ind nt nts)))
- (if nt*
- (let ((nb-nts (vector-length nts)))
- (let loop ((l (vector-ref enders nt*)) (nb-trees 0))
- (if (pair? l)
- (let ((conf (car l)))
- (if (conf-set-member? (vector-ref states j) conf i)
- (loop (cdr l)
- (+ (nb-deriv-trees conf i j enders steps
- toks states nb-nts)
- nb-trees))
- (loop (cdr l) nb-trees)))
- nb-trees)))
- #f)))
-
- (let* ((lexer (vector-ref parser-descr 0))
- (nts (vector-ref parser-descr 1))
- (starters (vector-ref parser-descr 2))
- (enders (vector-ref parser-descr 3))
- (predictors (vector-ref parser-descr 4))
- (steps (vector-ref parser-descr 5))
- (names (vector-ref parser-descr 6))
- (toks (input->tokens input lexer nts)))
-
- (vector nts
- starters
- enders
- predictors
- steps
- names
- toks
- (backward (forward starters enders predictors steps nts toks)
- enders steps nts toks)
- parsed?
- deriv-trees*
- nb-deriv-trees*))))))
-
-(define (parse->parsed? parse nt i j)
- (let* ((nts (vector-ref parse 0))
- (enders (vector-ref parse 2))
- (states (vector-ref parse 7))
- (parsed? (vector-ref parse 8)))
- (parsed? nt i j nts enders states)))
-
-(define (parse->trees parse nt i j)
- (let* ((nts (vector-ref parse 0))
- (enders (vector-ref parse 2))
- (steps (vector-ref parse 4))
- (names (vector-ref parse 5))
- (toks (vector-ref parse 6))
- (states (vector-ref parse 7))
- (deriv-trees* (vector-ref parse 9)))
- (deriv-trees* nt i j nts enders steps names toks states)))
-
-(define (parse->nb-trees parse nt i j)
- (let* ((nts (vector-ref parse 0))
- (enders (vector-ref parse 2))
- (steps (vector-ref parse 4))
- (toks (vector-ref parse 6))
- (states (vector-ref parse 7))
- (nb-deriv-trees* (vector-ref parse 10)))
- (nb-deriv-trees* nt i j nts enders steps toks states)))
-
-(define (test)
- (let ((p (make-parser '( (s (a) (s s)) )
- (lambda (l) (map (lambda (x) (list x x)) l)))))
- (let ((x (p '(a a a a a a a a a))))
- (length (parse->trees x 's 0 9)))))
-
-(time (test))
diff --git a/benchmarks/fft.scm b/benchmarks/fft.scm
deleted file mode 100644
index 53e02c07..00000000
--- a/benchmarks/fft.scm
+++ /dev/null
@@ -1,114 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: fft.sc
-;;; Description: FFT benchmark from the Gabriel tests.
-;;; Author: Harry Barrow
-;;; Created: 8-Apr-85
-;;; Modified: 6-May-85 09:29:22 (Bob Shaw)
-;;; 11-Aug-87 (Will Clinger)
-;;; 16-Nov-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define pi (atan 0 -1))
-
-;;; FFT -- This is an FFT benchmark written by Harry Barrow.
-;;; It tests a variety of floating point operations,
-;;; including array references.
-
-(define *re* (make-vector 1025 0.0))
-
-(define *im* (make-vector 1025 0.0))
-
-(define (fft areal aimag)
- (let ((ar areal) ;Qobi
- (ai aimag) ;Qobi
- (i 0)
- (j 0)
- (k 0)
- (m 0)
- (n 0)
- (le 0)
- (le1 0)
- (ip 0)
- (nv2 0)
- (nm1 0)
- (ur 0.0) ;Qobi
- (ui 0.0) ;Qobi
- (wr 0.0) ;Qobi
- (wi 0.0) ;Qobi
- (tr 0.0) ;Qobi
- (ti 0.0)) ;Qobi
- ;; initialize
- (set! ar areal)
- (set! ai aimag)
- (set! n (vector-length ar))
- (set! n (- n 1))
- (set! nv2 (quotient n 2))
- (set! nm1 (- n 1))
- (set! m 0) ;compute m = log(n)
- (set! i 1)
- (let loop ()
- (if (< i n)
- (begin (set! m (+ m 1))
- (set! i (+ i i))
- (loop))))
- (cond ((not (= n (let loop ((i m) (p 1)) ;Qobi
- (if (zero? i) p (loop (- i 1) (* 2 p))))))
- (display "array size not a power of two.")
- (newline)))
- ;; interchange elements in bit-reversed order
- (set! j 1)
- (set! i 1)
- (let l3 ()
- (cond ((< i j)
- (set! tr (vector-ref ar j))
- (set! ti (vector-ref ai j))
- (vector-set! ar j (vector-ref ar i))
- (vector-set! ai j (vector-ref ai i))
- (vector-set! ar i tr)
- (vector-set! ai i ti)))
- (set! k nv2)
- (let l6 ()
- (cond ((< k j)
- (set! j (- j k))
- (set! k (quotient k 2)) ;Qobi: was / but this violates R4RS
- (l6))))
- (set! j (+ j k))
- (set! i (+ i 1))
- (cond ((< i n) (l3))))
- ;; loop thru stages (syntax converted from old MACLISP style \bs)
- (do ((l 1 (+ l 1))) ((> l m))
- (set! le (let loop ((i l) (p 1)) ;Qobi
- (if (zero? i) p (loop (- i 1) (* 2 p)))))
- (set! le1 (quotient le 2))
- (set! ur 1.0)
- (set! ui 0.0)
- (set! wr (cos (/ pi le1)))
- (set! wi (sin (/ pi le1)))
- ;; loop thru butterflies
- (do ((j 1 (+ j 1))) ((> j le1))
- ;; do a butterfly
- (do ((i j (+ i le))) ((> i n))
- (set! ip (+ i le1))
- (set! tr (- (* (vector-ref ar ip) ur) (* (vector-ref ai ip) ui)))
- (set! ti (+ (* (vector-ref ar ip) ui) (* (vector-ref ai ip) ur)))
- (vector-set! ar ip (- (vector-ref ar i) tr))
- (vector-set! ai ip (- (vector-ref ai i) ti))
- (vector-set! ar i (+ (vector-ref ar i) tr))
- (vector-set! ai i (+ (vector-ref ai i) ti))))
- (set! tr (- (* ur wr) (* ui wi)))
- (set! ti (+ (* ur wi) (* ui wr)))
- (set! ur tr)
- (set! ui ti))
- #t))
-
-;;; the timer which does 10 calls on fft
-
-(define (fft-bench)
- (do ((ntimes 0 (+ ntimes 1))) ((= ntimes 10))
- (fft *re* *im*)))
-
-(time (fft-bench))
diff --git a/benchmarks/fib.scm b/benchmarks/fib.scm
deleted file mode 100644
index 22b4918d..00000000
--- a/benchmarks/fib.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-;;; fib.scm
-
-(define (fib n)
- (if (< n 2)
- n
- (+ (fib (- n 1)) (fib (- n 2))) ) )
-
-(time (print (fib 30)))
diff --git a/benchmarks/fibc.scm b/benchmarks/fibc.scm
deleted file mode 100644
index 017a2113..00000000
--- a/benchmarks/fibc.scm
+++ /dev/null
@@ -1,24 +0,0 @@
-;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig
-
-;;; fib with peano arithmetic (using numbers) with call/cc
-
-(define (add1 x) (+ x 1))
-(define (sub1 x) (- x 1))
-
-(define (addc x y k)
- (if (zero? y)
- (k x)
- (addc (add1 x) (sub1 y) k)))
-
-(define (fibc x c)
- (if (zero? x)
- (c 0)
- (if (zero? (sub1 x))
- (c 1)
- (addc (call-with-current-continuation (lambda (c) (fibc (sub1 x) c)))
- (call-with-current-continuation (lambda (c) (fibc (sub1 (sub1 x)) c)))
- c))))
-
-(let ((x (time (fibc 30 (lambda (n) n)))))
- (if (not (equal? x 832040))
- (error "wrong result" x) ) )
diff --git a/benchmarks/fprint.scm b/benchmarks/fprint.scm
deleted file mode 100644
index 4346edd3..00000000
--- a/benchmarks/fprint.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: fprint.sc
-;;; Description: FPRINT benchmark
-;;; Author: Richard Gabriel
-;;; Created: 11-Apr-85
-;;; Modified: 9-Jul-85 21:11:33 (Bob Shaw)
-;;; 24-Jul-87 (Will Clinger)
-;;; 16-Nov-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; FPRINT -- Benchmark to print to a file.
-
-(define test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
- mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
- ;; Qobi: changed 123456AB to AB123456 etc. since
- ;; Scheme->C can't READ original symbols
- wxyzab23 xyzabc34 ab123456 bc234567 cd345678
- de456789 ef567890 fg678901 gh789012 hi890123))
-
-(define (init-aux m n atoms)
- (cond ((= m 0) (car atoms))
- (else (do ((i n (- i 2)) (a '())) ((< i 1) a)
- (set! a (cons (car atoms) a))
- (set! atoms (cdr atoms))
- (set! a (cons (init-aux (- m 1) n atoms) a))))))
-
-(define (init m n atoms)
- (define (copy x) (if (pair? x) (cons (copy (car x)) (copy (cdr x))) x))
- (let ((atoms (copy atoms)))
- (do ((a atoms (cdr a))) ((null? (cdr a)) (set-cdr! a atoms)))
- (init-aux m n atoms)))
-
-(define test-pattern (init 8 8 test-atoms))
-
-(define (fprint)
- (call-with-output-file "fprint.tst"
- (lambda (stream)
- (newline stream)
- (write test-pattern stream)) ))
-
-;;; note: The INIT is not done multiple times.
-
-(time (fprint))
diff --git a/benchmarks/fread.scm b/benchmarks/fread.scm
deleted file mode 100644
index d326c4b6..00000000
--- a/benchmarks/fread.scm
+++ /dev/null
@@ -1,22 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: fread.sc
-;;; Description: FREAD benchmark
-;;; Author: Richard Gabriel
-;;; Created: 11-Apr-85
-;;; Modified: 11-Apr-85 20:39:09 (Bob Shaw)
-;;; 24-Jul-87 (Will Clinger)
-;;; 14-Jun-95 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; FREAD -- Benchmark to read from a file.
-;;; Requires the existence of FPRINT.TST which is created by FPRINT.
-
-(define (fread)
- (call-with-input-file "fprint.tst" (lambda (stream) (read stream))))
-
-(time (fread)
-)
diff --git a/benchmarks/hanoi.scm b/benchmarks/hanoi.scm
deleted file mode 100644
index 41dc0a0d..00000000
--- a/benchmarks/hanoi.scm
+++ /dev/null
@@ -1,13 +0,0 @@
-;;;; hanoi.scm
-
-(define hanoi
- (lambda (n)
- (letrec ((move-them
- (lambda (n from to helper)
- (if (> n 1)
- (begin
- (move-them (- n 1) from helper to)
- (move-them (- n 1) helper to from))))))
- (move-them n 0 1 2))))
-
-(time (do ((i 10 (- i 1))) ((zero? i)) (hanoi 20)))
diff --git a/benchmarks/lattice.scm b/benchmarks/lattice.scm
deleted file mode 100644
index 6bcb938c..00000000
--- a/benchmarks/lattice.scm
+++ /dev/null
@@ -1,217 +0,0 @@
-;;; LATTICE -- Obtained from Andrew Wright.
-;
-; 08/06/01 (felix): renamed "reverse!" to "reverse!2" because MZC doesn't like redefinitions.
-;
-; Given a comparison routine that returns one of
-; less
-; more
-; equal
-; uncomparable
-; return a new comparison routine that applies to sequences.
-(define lexico
- (lambda (base)
- (define lex-fixed
- (lambda (fixed lhs rhs)
- (define check
- (lambda (lhs rhs)
- (if (null? lhs)
- fixed
- (let ((probe
- (base (car lhs)
- (car rhs))))
- (if (or (eq? probe 'equal)
- (eq? probe fixed))
- (check (cdr lhs)
- (cdr rhs))
- 'uncomparable)))))
- (check lhs rhs)))
- (define lex-first
- (lambda (lhs rhs)
- (if (null? lhs)
- 'equal
- (let ((probe
- (base (car lhs)
- (car rhs))))
- (case probe
- ((less more)
- (lex-fixed probe
- (cdr lhs)
- (cdr rhs)))
- ((equal)
- (lex-first (cdr lhs)
- (cdr rhs)))
- ((uncomparable)
- 'uncomparable))))))
- lex-first))
-
-(define (make-lattice elem-list cmp-func)
- (cons elem-list cmp-func))
-
-(define lattice->elements car)
-
-(define lattice->cmp cdr)
-
-; Select elements of a list which pass some test.
-(define zulu-select
- (lambda (test lst)
- (define select-a
- (lambda (ac lst)
- (if (null? lst)
- (reverse!2 ac)
- (select-a
- (let ((head (car lst)))
- (if (test head)
- (cons head ac)
- ac))
- (cdr lst)))))
- (select-a '() lst)))
-
-(define reverse!2
- (letrec ((rotate
- (lambda (fo fum)
- (let ((next (cdr fo)))
- (set-cdr! fo fum)
- (if (null? next)
- fo
- (rotate next fo))))))
- (lambda (lst)
- (if (null? lst)
- '()
- (rotate lst '())))))
-
-; Select elements of a list which pass some test and map a function
-; over the result. Note, only efficiency prevents this from being the
-; composition of select and map.
-(define select-map
- (lambda (test func lst)
- (define select-a
- (lambda (ac lst)
- (if (null? lst)
- (reverse!2 ac)
- (select-a
- (let ((head (car lst)))
- (if (test head)
- (cons (func head)
- ac)
- ac))
- (cdr lst)))))
- (select-a '() lst)))
-
-
-
-; This version of map-and tail-recurses on the last test.
-(define map-and
- (lambda (proc lst)
- (if (null? lst)
- #t
- (letrec ((drudge
- (lambda (lst)
- (let ((rest (cdr lst)))
- (if (null? rest)
- (proc (car lst))
- (and (proc (car lst))
- (drudge rest)))))))
- (drudge lst)))))
-
-(define (maps-1 source target pas new)
- (let ((scmp (lattice->cmp source))
- (tcmp (lattice->cmp target)))
- (let ((less
- (select-map
- (lambda (p)
- (eq? 'less
- (scmp (car p) new)))
- cdr
- pas))
- (more
- (select-map
- (lambda (p)
- (eq? 'more
- (scmp (car p) new)))
- cdr
- pas)))
- (zulu-select
- (lambda (t)
- (and
- (map-and
- (lambda (t2)
- (memq (tcmp t2 t) '(less equal)))
- less)
- (map-and
- (lambda (t2)
- (memq (tcmp t2 t) '(more equal)))
- more)))
- (lattice->elements target)))))
-
-(define (maps-rest source target pas rest to-1 to-collect)
- (if (null? rest)
- (to-1 pas)
- (let ((next (car rest))
- (rest (cdr rest)))
- (to-collect
- (map
- (lambda (x)
- (maps-rest source target
- (cons
- (cons next x)
- pas)
- rest
- to-1
- to-collect))
- (maps-1 source target pas next))))))
-
-(define (maps source target)
- (make-lattice
- (maps-rest source
- target
- '()
- (lattice->elements source)
- (lambda (x) (list (map cdr x)))
- (lambda (x) (apply append x)))
- (lexico (lattice->cmp target))))
-
-(define (count-maps source target)
- (maps-rest source
- target
- '()
- (lattice->elements source)
- (lambda (x) 1)
- sum))
-
-(define (sum lst)
- (if (null? lst)
- 0
- (+ (car lst) (sum (cdr lst)))))
-
-(define (run)
- (let* ((l2
- (make-lattice '(low high)
- (lambda (lhs rhs)
- (case lhs
- ((low)
- (case rhs
- ((low)
- 'equal)
- ((high)
- 'less)
- (else
- (error 'make-lattice "base" rhs))))
- ((high)
- (case rhs
- ((low)
- 'more)
- ((high)
- 'equal)
- (else
- (error 'make-lattice "base" rhs))))
- (else
- (error 'make-lattice "base" lhs))))))
- (l3 (maps l2 l2))
- (l4 (maps l3 l3)))
- (count-maps l2 l2)
- (count-maps l3 l3)
- (count-maps l2 l3)
- (count-maps l3 l2)
- (count-maps l4 l4)))
-
-(time (run))
diff --git a/benchmarks/maze.scm b/benchmarks/maze.scm
deleted file mode 100644
index 3c5e1bf2..00000000
--- a/benchmarks/maze.scm
+++ /dev/null
@@ -1,726 +0,0 @@
-;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
-
-; 18/07/01 (felix): 100 iterations
-
-;------------------------------------------------------------------------------
-; Was file "rand.scm".
-
-; Minimal Standard Random Number Generator
-; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
-; better constants, as proposed by Park.
-; By Ozan Yigit
-
-;;; Rehacked by Olin 4/1995.
-
-(define (random-state n)
- (cons n #f))
-
-(define (rand state)
- (let ((seed (car state))
- (A 2813) ; 48271
- (M 8388607) ; 2147483647
- (Q 2787) ; 44488
- (R 2699)) ; 3399
- (let* ((hi (quotient seed Q))
- (lo (modulo seed Q))
- (test (- (* A lo) (* R hi)))
- (val (if (> test 0) test (+ test M))))
- (set-car! state val)
- val)))
-
-(define (random-int n state)
- (modulo (rand state) n))
-
-; poker test
-; seed 1
-; cards 0-9 inclusive (random 10)
-; five cards per hand
-; 10000 hands
-;
-; Poker Hand Example Probability Calculated
-; 5 of a kind (aaaaa) 0.0001 0
-; 4 of a kind (aaaab) 0.0045 0.0053
-; Full house (aaabb) 0.009 0.0093
-; 3 of a kind (aaabc) 0.072 0.0682
-; two pairs (aabbc) 0.108 0.1104
-; Pair (aabcd) 0.504 0.501
-; Bust (abcde) 0.3024 0.3058
-
-; (define (random n)
-; (let* ((M 2147483647)
-; (slop (modulo M n)))
-; (let loop ((r (rand)))
-; (if (> r slop)
-; (modulo r n)
-; (loop (rand))))))
-;
-; (define (rngtest)
-; (display "implementation ")
-; (srand 1)
-; (let loop ((n 0))
-; (if (< n 10000)
-; (begin
-; (rand)
-; (loop (1+ n)))))
-; (if (= *seed* 399268537)
-; (display "looks correct.")
-; (begin
-; (display "failed.")
-; (newline)
-; (display " current seed ") (display *seed*)
-; (newline)
-; (display " correct seed 399268537")))
-; (newline))
-
-;------------------------------------------------------------------------------
-; Was file "uf.scm".
-
-;;; Tarjan's amortised union-find data structure.
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; This data structure implements disjoint sets of elements.
-;;; Four operations are supported. The implementation is extremely
-;;; fast -- any sequence of N operations can be performed in time
-;;; so close to linear it's laughable how close it is. See your
-;;; intro data structures book for more. The operations are:
-;;;
-;;; - (base-set nelts) -> set
-;;; Returns a new set, of size NELTS.
-;;;
-;;; - (set-size s) -> integer
-;;; Returns the number of elements in set S.
-;;;
-;;; - (union! set1 set2)
-;;; Unions the two sets -- SET1 and SET2 are now considered the same set
-;;; by SET-EQUAL?.
-;;;
-;;; - (set-equal? set1 set2)
-;;; Returns true <==> the two sets are the same.
-
-;;; Representation: a set is a cons cell. Every set has a "representative"
-;;; cons cell, reached by chasing cdr links until we find the cons with
-;;; cdr = (). Set equality is determined by comparing representatives using
-;;; EQ?. A representative's car contains the number of elements in the set.
-
-;;; The speed of the algorithm comes because when we chase links to find
-;;; representatives, we collapse links by changing all the cells in the path
-;;; we followed to point directly to the representative, so that next time
-;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
-
-
-(define (base-set nelts) (cons nelts '()))
-
-;;; Sets are chained together through cdr links. Last guy in the chain
-;;; is the root of the set.
-
-(define (get-set-root s)
- (let lp ((r s)) ; Find the last pair
- (let ((next (cdr r))) ; in the list. That's
- (cond ((pair? next) (lp next)) ; the root r.
-
- (else
- (if (not (eq? r s)) ; Now zip down the list again,
- (let lp ((x s)) ; changing everyone's cdr to r.
- (let ((next (cdr x)))
- (cond ((not (eq? r next))
- (set-cdr! x r)
- (lp next))))))
- r))))) ; Then return r.
-
-(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
-
-(define (set-size s) (car (get-set-root s)))
-
-(define (union! s1 s2)
- (let* ((r1 (get-set-root s1))
- (r2 (get-set-root s2))
- (n1 (set-size r1))
- (n2 (set-size r2))
- (n (+ n1 n2)))
-
- (cond ((> n1 n2)
- (set-cdr! r2 r1)
- (set-car! r1 n))
- (else
- (set-cdr! r1 r2)
- (set-car! r2 n)))))
-
-;------------------------------------------------------------------------------
-; Was file "maze.scm".
-
-;;; Building mazes with union/find disjoint sets.
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; This is the algorithmic core of the maze constructor.
-;;; External dependencies:
-;;; - RANDOM-INT
-;;; - Union/find code
-;;; - bitwise logical functions
-
-; (define-record wall
-; owner ; Cell that owns this wall.
-; neighbor ; The other cell bordering this wall.
-; bit) ; Integer -- a bit identifying this wall in OWNER's cell.
-
-; (define-record cell
-; reachable ; Union/find set -- all reachable cells.
-; id ; Identifying info (e.g., the coords of the cell).
-; (walls -1) ; A bitset telling which walls are still standing.
-; (parent #f) ; For DFS spanning tree construction.
-; (mark #f)) ; For marking the solution path.
-
-(define (make-wall owner neighbor bit)
- (vector 'wall owner neighbor bit))
-
-(define (wall:owner o) (vector-ref o 1))
-(define (set-wall:owner o v) (vector-set! o 1 v))
-(define (wall:neighbor o) (vector-ref o 2))
-(define (set-wall:neighbor o v) (vector-set! o 2 v))
-(define (wall:bit o) (vector-ref o 3))
-(define (set-wall:bit o v) (vector-set! o 3 v))
-
-(define (make-cell reachable id)
- (vector 'cell reachable id -1 #f #f))
-
-(define (cell:reachable o) (vector-ref o 1))
-(define (set-cell:reachable o v) (vector-set! o 1 v))
-(define (cell:id o) (vector-ref o 2))
-(define (set-cell:id o v) (vector-set! o 2 v))
-(define (cell:walls o) (vector-ref o 3))
-(define (set-cell:walls o v) (vector-set! o 3 v))
-(define (cell:parent o) (vector-ref o 4))
-(define (set-cell:parent o v) (vector-set! o 4 v))
-(define (cell:mark o) (vector-ref o 5))
-(define (set-cell:mark o v) (vector-set! o 5 v))
-
-;;; Iterates in reverse order.
-
-(define (vector-for-each proc v)
- (let lp ((i (- (vector-length v) 1)))
- (cond ((>= i 0)
- (proc (vector-ref v i))
- (lp (- i 1))))))
-
-
-;;; Randomly permute a vector.
-
-(define (permute-vec! v random-state)
- (let lp ((i (- (vector-length v) 1)))
- (cond ((> i 1)
- (let ((elt-i (vector-ref v i))
- (j (random-int i random-state))) ; j in [0,i)
- (vector-set! v i (vector-ref v j))
- (vector-set! v j elt-i))
- (lp (- i 1)))))
- v)
-
-
-;;; This is the core of the algorithm.
-
-(define (dig-maze walls ncells)
- (call-with-current-continuation
- (lambda (quit)
- (vector-for-each
- (lambda (wall) ; For each wall,
- (let* ((c1 (wall:owner wall)) ; find the cells on
- (set1 (cell:reachable c1))
-
- (c2 (wall:neighbor wall)) ; each side of the wall
- (set2 (cell:reachable c2)))
-
- ;; If there is no path from c1 to c2, knock down the
- ;; wall and union the two sets of reachable cells.
- ;; If the new set of reachable cells is the whole set
- ;; of cells, quit.
- (if (not (set-equal? set1 set2))
- (let ((walls (cell:walls c1))
- (wall-mask (bitwise-not (wall:bit wall))))
- (union! set1 set2)
- (set-cell:walls c1 (bitwise-and walls wall-mask))
- (if (= (set-size set1) ncells) (quit #f))))))
- walls))))
-
-
-;;; Some simple DFS routines useful for determining path length
-;;; through the maze.
-
-;;; Build a DFS tree from ROOT.
-;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
-;;; We assume there are no loops in the maze; if this is incorrect, the
-;;; algorithm will diverge.
-
-(define (dfs-maze maze root do-children)
- (let search ((node root) (parent #f))
- (set-cell:parent node parent)
- (do-children (lambda (child)
- (if (not (eq? child parent))
- (search child node)))
- maze node)))
-
-;;; Move the root to NEW-ROOT.
-
-(define (reroot-maze new-root)
- (let lp ((node new-root) (new-parent #f))
- (let ((old-parent (cell:parent node)))
- (set-cell:parent node new-parent)
- (if old-parent (lp old-parent node)))))
-
-;;; How far from CELL to the root?
-
-(define (path-length cell)
- (do ((len 0 (+ len 1))
- (node (cell:parent cell) (cell:parent node)))
- ((not node) len)))
-
-;;; Mark the nodes from NODE back to root. Used to mark the winning path.
-
-(define (mark-path node)
- (let lp ((node node))
- (set-cell:mark node #t)
- (cond ((cell:parent node) => lp))))
-
-;------------------------------------------------------------------------------
-; Was file "harr.scm".
-
-;;; Hex arrays
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; External dependencies:
-;;; - define-record
-
-;;; ___ ___ ___
-;;; / \ / \ / \
-;;; ___/ A \___/ A \___/ A \___
-;;; / \ / \ / \ / \
-;;; / A \___/ A \___/ A \___/ A \
-;;; \ / \ / \ / \ /
-;;; \___/ \___/ \___/ \___/
-;;; / \ / \ / \ / \
-;;; / \___/ \___/ \___/ \
-;;; \ / \ / \ / \ /
-;;; \___/ \___/ \___/ \___/
-;;; / \ / \ / \ / \
-;;; / \___/ \___/ \___/ \
-;;; \ / \ / \ / \ /
-;;; \___/ \___/ \___/ \___/
-
-;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
-;;; element. Hexes are three wide and two high; e.g., to get from the center
-;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
-;;; respectively.
-;;;
-;;; Hex arrays are represented with a matrix, essentially made by shoving the
-;;; odd columns down a half-cell so things line up. The mapping is as follows:
-;;; Center coord row/column
-;;; ------------ ----------
-;;; (x, y) -> (y/2, x/3)
-;;; (3c, 2r + c&1) <- (r, c)
-
-
-; (define-record harr
-; nrows
-; ncols
-; elts)
-
-(define (make-harr nrows ncols elts)
- (vector 'harr nrows ncols elts))
-
-(define (harr:nrows o) (vector-ref o 1))
-(define (set-harr:nrows o v) (vector-set! o 1 v))
-(define (harr:ncols o) (vector-ref o 2))
-(define (set-harr:ncols o v) (vector-set! o 2 v))
-(define (harr:elts o) (vector-ref o 3))
-(define (set-harr:elts o v) (vector-set! o 3 v))
-
-(define (harr r c)
- (make-harr r c (make-vector (* r c))))
-
-
-
-(define (href ha x y)
- (let ((r (quotient y 2))
- (c (quotient x 3)))
- (vector-ref (harr:elts ha)
- (+ (* (harr:ncols ha) r) c))))
-
-(define (hset! ha x y val)
- (let ((r (quotient y 2))
- (c (quotient x 3)))
- (vector-set! (harr:elts ha)
- (+ (* (harr:ncols ha) r) c)
- val)))
-
-(define (href/rc ha r c)
- (vector-ref (harr:elts ha)
- (+ (* (harr:ncols ha) r) c)))
-
-;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
-;;; is the value returned by (PROC x y).
-
-(define (harr-tabulate nrows ncols proc)
- (let ((v (make-vector (* nrows ncols))))
-
- (do ((r (- nrows 1) (- r 1)))
- ((< r 0))
- (do ((c 0 (+ c 1))
- (i (* r ncols) (+ i 1)))
- ((= c ncols))
- (vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
-
- (make-harr nrows ncols v)))
-
-
-(define (harr-for-each proc harr)
- (vector-for-each proc (harr:elts harr)))
-
-;------------------------------------------------------------------------------
-; Was file "hex.scm".
-
-;;; Hexagonal hackery for maze generation.
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; External dependencies:
-;;; - cell and wall records
-;;; - Functional Postscript for HEXES->PATH
-;;; - logical functions for bit hacking
-;;; - hex array code.
-
-;;; To have the maze span (0,0) to (1,1):
-;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
-;;; (translate (point 2 1) maze))
-
-;;; Every elt of the hex array manages his SW, S, and SE wall.
-;;; Terminology: - An even column is one whose column index is even. That
-;;; means the first, third, ... columns (indices 0, 2, ...).
-;;; - An odd column is one whose column index is odd. That
-;;; means the second, fourth... columns (indices 1, 3, ...).
-;;; The even/odd flip-flop is confusing; be careful to keep it
-;;; straight. The *even* columns are the low ones. The *odd*
-;;; columns are the high ones.
-;;; _ _
-;;; _/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/
-;;; 0 1 2 3
-
-(define south-west 1)
-(define south 2)
-(define south-east 4)
-
-(define (gen-maze-array r c)
- (harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
-
-;;; This could be made more efficient.
-(define (make-wall-vec harr)
- (let* ((nrows (harr:nrows harr))
- (ncols (harr:ncols harr))
- (xmax (* 3 (- ncols 1)))
-
- ;; Accumulate walls.
- (walls '())
- (add-wall (lambda (o n b) ; owner neighbor bit
- (set! walls (cons (make-wall o n b) walls)))))
-
- ;; Do everything but the bottom row.
- (do ((x (* (- ncols 1) 3) (- x 3)))
- ((< x 0))
- (do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
- (- y 2)))
- ((<= y 1)) ; Don't do bottom row.
- (let ((hex (href harr x y)))
- (if (not (zero? x))
- (add-wall hex (href harr (- x 3) (- y 1)) south-west))
- (add-wall hex (href harr x (- y 2)) south)
- (if (< x xmax)
- (add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
-
- ;; Do the SE and SW walls of the odd columns on the bottom row.
- ;; If the rightmost bottom hex lies in an odd column, however,
- ;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
- (if (> ncols 1)
- (let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
- ;; Do rightmost odd col.
- (let ((rmoc-hex (href harr rmoc-x 1)))
- (if (< rmoc-x xmax) ; Not a corner -- do E wall.
- (add-wall rmoc-hex (href harr xmax 0) south-east))
- (add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
-
- (do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
- (- x 6)))
- ((< x 3)) ; 3 is X coord of leftmost odd column.
- (add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
- (add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
-
- (list->vector walls)))
-
-
-;;; Find the cell ctop from the top row, and the cell cbot from the bottom
-;;; row such that cbot is furthest from ctop.
-;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
-
-(define (pick-entrances harr)
- (dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
- (let ((nrows (harr:nrows harr))
- (ncols (harr:ncols harr)))
- (let tp-lp ((max-len -1)
- (entrance #f)
- (exit #f)
- (tcol (- ncols 1)))
- (if (< tcol 0) (vector entrance exit)
- (let ((top-cell (href/rc harr (- nrows 1) tcol)))
- (reroot-maze top-cell)
- (let ((result
- (let bt-lp ((max-len max-len)
- (entrance entrance)
- (exit exit)
- (bcol (- ncols 1)))
-; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
- (if (< bcol 0) (vector max-len entrance exit)
- (let ((this-len (path-length (href/rc harr 0 bcol))))
- (if (> this-len max-len)
- (bt-lp this-len tcol bcol (- bcol 1))
- (bt-lp max-len entrance exit (- bcol 1))))))))
- (let ((max-len (vector-ref result 0))
- (entrance (vector-ref result 1))
- (exit (vector-ref result 2)))
- (tp-lp max-len entrance exit (- tcol 1)))))))))
-
-
-
-;;; Apply PROC to each node reachable from CELL.
-(define (for-each-hex-child proc harr cell)
- (let* ((walls (cell:walls cell))
- (id (cell:id cell))
- (x (car id))
- (y (cdr id))
- (nr (harr:nrows harr))
- (nc (harr:ncols harr))
- (maxy (* 2 (- nr 1)))
- (maxx (* 3 (- nc 1))))
- (if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
- (if (not (bit-test walls south)) (proc (href harr x (- y 2))))
- (if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
-
- ;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
- (if (and (> x 0) ; Not in first column.
- (or (<= y maxy) ; Not on top row or
- (zero? (modulo x 6)))) ; not in an odd column.
- (let ((nw (href harr (- x 3) (+ y 1))))
- (if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
-
- ;; N neighbor, if there is one (we may be on top row).
- (if (< y maxy) ; Not on top row
- (let ((n (href harr x (+ y 2))))
- (if (not (bit-test (cell:walls n) south)) (proc n))))
-
- ;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
- (if (and (< x maxx) ; Not in last column.
- (or (<= y maxy) ; Not on top row or
- (zero? (modulo x 6)))) ; not in an odd column.
- (let ((ne (href harr (+ x 3) (+ y 1))))
- (if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
-
-
-
-;;; The top-level
-(define (make-maze nrows ncols)
- (let* ((cells (gen-maze-array nrows ncols))
- (walls (permute-vec! (make-wall-vec cells) (random-state 20))))
- (dig-maze walls (* nrows ncols))
- (let ((result (pick-entrances cells)))
- (let ((entrance (vector-ref result 0))
- (exit (vector-ref result 1)))
- (let* ((exit-cell (href/rc cells 0 exit))
- (walls (cell:walls exit-cell)))
- (reroot-maze (href/rc cells (- nrows 1) entrance))
- (mark-path exit-cell)
- (set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
- (vector cells entrance exit))))))
-
-
-(define (pmaze nrows ncols)
- (let ((result (make-maze nrows ncols)))
- (let ((cells (vector-ref result 0))
- (entrance (vector-ref result 1))
- (exit (vector-ref result 2)))
- (print-hexmaze cells entrance))))
-
-;------------------------------------------------------------------------------
-; Was file "hexprint.scm".
-
-;;; Print out a hex array with characters.
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; External dependencies:
-;;; - hex array code
-;;; - hex cell code
-
-;;; _ _
-;;; _/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/
-
-;;; Top part of top row looks like this:
-;;; _ _ _ _
-;;; _/ \_/ \/ \_/ \
-;;; /
-
-(define output #f) ; the list of all characters written out, in reverse order.
-
-(define (write-ch c)
- (set! output (cons c output)))
-
-(define (print-hexmaze harr entrance)
- (let* ((nrows (harr:nrows harr))
- (ncols (harr:ncols harr))
- (ncols2 (* 2 (quotient ncols 2))))
-
- ;; Print out the flat tops for the top row's odd cols.
- (do ((c 1 (+ c 2)))
- ((>= c ncols))
-; (display " ")
- (write-ch #\space)
- (write-ch #\space)
- (write-ch #\space)
- (write-ch (if (= c entrance) #\space #\_)))
-; (newline)
- (write-ch #\newline)
-
- ;; Print out the slanted tops for the top row's odd cols
- ;; and the flat tops for the top row's even cols.
- (write-ch #\space)
- (do ((c 0 (+ c 2)))
- ((>= c ncols2))
-; (format #t "~a/~a\\"
-; (if (= c entrance) #\space #\_)
-; (dot/space harr (- nrows 1) (+ c 1)))
- (write-ch (if (= c entrance) #\space #\_))
- (write-ch #\/)
- (write-ch (dot/space harr (- nrows 1) (+ c 1)))
- (write-ch #\\))
- (if (odd? ncols)
- (write-ch (if (= entrance (- ncols 1)) #\space #\_)))
-; (newline)
- (write-ch #\newline)
-
- (do ((r (- nrows 1) (- r 1)))
- ((< r 0))
-
- ;; Do the bottoms for row r's odd cols.
- (write-ch #\/)
- (do ((c 1 (+ c 2)))
- ((>= c ncols2))
- ;; The dot/space for the even col just behind c.
- (write-ch (dot/space harr r (- c 1)))
- (display-hexbottom (cell:walls (href/rc harr r c))))
-
- (cond ((odd? ncols)
- (write-ch (dot/space harr r (- ncols 1)))
- (write-ch #\\)))
-; (newline)
- (write-ch #\newline)
-
- ;; Do the bottoms for row r's even cols.
- (do ((c 0 (+ c 2)))
- ((>= c ncols2))
- (display-hexbottom (cell:walls (href/rc harr r c)))
- ;; The dot/space is for the odd col just after c, on row below.
- (write-ch (dot/space harr (- r 1) (+ c 1))))
-
- (cond ((odd? ncols)
- (display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
- ((not (zero? r)) (write-ch #\\)))
-; (newline)
- (write-ch #\newline))))
-
-(define (bit-test j bit)
- (not (zero? (bitwise-and j bit))))
-
-;;; Return a . if harr[r,c] is marked, otherwise a space.
-;;; We use the dot to mark the solution path.
-(define (dot/space harr r c)
- (if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
-
-;;; Print a \_/ hex bottom.
-(define (display-hexbottom hexwalls)
- (write-ch (if (bit-test hexwalls south-west) #\\ #\space))
- (write-ch (if (bit-test hexwalls south ) #\_ #\space))
- (write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
-
-;;; _ _
-;;; _/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \_/
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \
-;;; / \_/ \_/
-;;; \_/ \_/ \_/
-
-;------------------------------------------------------------------------------
-
-(define (run)
- (do ((i 100 (- i 1)))
- ((zero? i) (reverse output))
- (set! output '())
- (pmaze 20 7) ) )
-
-(let ((x (time (run))))
-; (for-each display x)
- (if (not (equal? x '
-(#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline
- #\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline
- #\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline
- #\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
- #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline
- #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
- #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline
- #\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline
- #\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline
- #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
- #\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline
- #\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline
- #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline
- #\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline
- #\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline
- #\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
- #\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline
- #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
- #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline
- #\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline
- #\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline
- #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline
- #\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline
- #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline
- #\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline
- #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
- #\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline
- #\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline
- #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
- #\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
- #\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline
- #\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
- #\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
- #\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline
- #\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline)))
-(error "wrong result") ) )
diff --git a/benchmarks/nbody.scm b/benchmarks/nbody.scm
deleted file mode 100644
index 78210f07..00000000
--- a/benchmarks/nbody.scm
+++ /dev/null
@@ -1,138 +0,0 @@
-;;; The Computer Language Benchmarks Game
-;;; http://shootout.alioth.debian.org/
-;;;
-;;; contributed by Anthony Borla
-;;; modified by Graham Fawcett
-
-;; define planetary masses, initial positions & velocity
-
-(define +pi+ 3.141592653589793)
-(define +days-per-year+ 365.24)
-
-(define +solar-mass+ (* 4 +pi+ +pi+))
-
-(define-record body x y z vx vy vz mass)
-
-(define *sun*
- (make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
-
-(define *jupiter*
- (make-body 4.84143144246472090
- -1.16032004402742839
- -1.03622044471123109e-1
- (* 1.66007664274403694e-3 +days-per-year+)
- (* 7.69901118419740425e-3 +days-per-year+)
- (* -6.90460016972063023e-5 +days-per-year+)
- (* 9.54791938424326609e-4 +solar-mass+)))
-
-(define *saturn*
- (make-body 8.34336671824457987
- 4.12479856412430479
- -4.03523417114321381e-1
- (* -2.76742510726862411e-3 +days-per-year+)
- (* 4.99852801234917238e-3 +days-per-year+)
- (* 2.30417297573763929e-5 +days-per-year+)
- (* 2.85885980666130812e-4 +solar-mass+)))
-
-(define *uranus*
- (make-body 1.28943695621391310e1
- -1.51111514016986312e1
- -2.23307578892655734e-1
- (* 2.96460137564761618e-03 +days-per-year+)
- (* 2.37847173959480950e-03 +days-per-year+)
- (* -2.96589568540237556e-05 +days-per-year+)
- (* 4.36624404335156298e-05 +solar-mass+)))
-
-(define *neptune*
- (make-body 1.53796971148509165e+01
- -2.59193146099879641e+01
- 1.79258772950371181e-01
- (* 2.68067772490389322e-03 +days-per-year+)
- (* 1.62824170038242295e-03 +days-per-year+)
- (* -9.51592254519715870e-05 +days-per-year+)
- (* 5.15138902046611451e-05 +solar-mass+)))
-
-;; -------------------------------
-(define (offset-momentum system)
- (let loop-i ((i system) (px 0.0) (py 0.0) (pz 0.0))
- (if (null? i)
- (begin
- (body-vx-set! (car system) (/ (- px) +solar-mass+))
- (body-vy-set! (car system) (/ (- py) +solar-mass+))
- (body-vz-set! (car system) (/ (- pz) +solar-mass+)))
- (loop-i (cdr i)
- (+ px (* (body-vx (car i)) (body-mass (car i))))
- (+ py (* (body-vy (car i)) (body-mass (car i))))
- (+ pz (* (body-vz (car i)) (body-mass (car i))))))))
-
-;; -------------------------------
-(define (energy system)
- (let loop-o ((o system) (e 0.0))
- (if (null? o)
- e
- (let ([e (+ e (* 0.5 (body-mass (car o))
- (+ (* (body-vx (car o)) (body-vx (car o)))
- (* (body-vy (car o)) (body-vy (car o)))
- (* (body-vz (car o)) (body-vz (car o))))))])
-
- (let loop-i ((i (cdr o)) (e e))
- (if (null? i)
- (loop-o (cdr o) e)
- (let* ((dx (- (body-x (car o)) (body-x (car i))))
- (dy (- (body-y (car o)) (body-y (car i))))
- (dz (- (body-z (car o)) (body-z (car i))))
- (distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
- (let ([e (- e (/ (* (body-mass (car o)) (body-mass (car i))) distance))])
- (loop-i (cdr i) e)))))))))
-
-;; -------------------------------
-(define (advance system dt)
- (let loop-o ((o system))
- (unless (null? o)
- (let loop-i ((i (cdr o)))
- (unless (null? i)
- (let* ((o1 (car o))
- (i1 (car i))
- (dx (- (body-x o1) (body-x i1)))
- (dy (- (body-y o1) (body-y i1)))
- (dz (- (body-z o1) (body-z i1)))
- (distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz))))
- (mag (/ dt (* distance distance distance)))
- (dxmag (* dx mag))
- (dymag (* dy mag))
- (dzmag (* dz mag))
- (om (body-mass o1))
- (im (body-mass i1)))
- (body-vx-set! o1 (- (body-vx o1) (* dxmag im)))
- (body-vy-set! o1 (- (body-vy o1) (* dymag im)))
- (body-vz-set! o1 (- (body-vz o1) (* dzmag im)))
- (body-vx-set! i1 (+ (body-vx i1) (* dxmag om)))
- (body-vy-set! i1 (+ (body-vy i1) (* dymag om)))
- (body-vz-set! i1 (+ (body-vz i1) (* dzmag om)))
- (loop-i (cdr i)))))
- (loop-o (cdr o))))
-
- (let loop-o ((o system))
- (unless (null? o)
- (let ([o1 (car o)])
- (body-x-set! o1 (+ (body-x o1) (* dt (body-vx o1))))
- (body-y-set! o1 (+ (body-y o1) (* dt (body-vy o1))))
- (body-z-set! o1 (+ (body-z o1) (* dt (body-vz o1))))
- (loop-o (cdr o))))))
-
-;; -------------------------------
-(define (main n)
- (let ((system (list *sun* *jupiter* *saturn* *uranus* *neptune*)))
-
- (offset-momentum system)
- (print-float (energy system))
-
- (do ((i 1 (+ i 1)))
- ((< n i))
- (advance system 0.01))
- (print-float (energy system))))
-
-(define print-float
- (foreign-lambda* void ((double f)) "printf(\"%2.9f\\n\", f);"))
-
-(time (main 100000))
diff --git a/benchmarks/nqueens.scm b/benchmarks/nqueens.scm
deleted file mode 100644
index 75df9ce2..00000000
--- a/benchmarks/nqueens.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;;; NQUEENS -- Compute number of solutions to 8-queens problem.
-
-(define trace? #f)
-
-(define (nqueens n)
-
- (define (dec-to n)
- (let loop ((i n) (l '()))
- (if (= i 0) l (loop (- i 1) (cons i l)))))
-
- (define (try x y z)
- (if (null? x)
- (if (null? y)
- (begin (if trace? (begin (write z) (newline))) 1)
- 0)
- (+ (if (ok? (car x) 1 z)
- (try (append (cdr x) y) '() (cons (car x) z))
- 0)
- (try (cdr x) (cons (car x) y) z))))
-
- (define (ok? row dist placed)
- (if (null? placed)
- #t
- (and (not (= (car placed) (+ row dist)))
- (not (= (car placed) (- row dist)))
- (ok? row (+ dist 1) (cdr placed)))))
-
- (try (dec-to n) '() '()))
-
-(time (do ((i 1000 (- 1 1))) ((zero? i)) (nqueens 10)))
diff --git a/benchmarks/others/Makefile b/benchmarks/others/Makefile
deleted file mode 100644
index a231e053..00000000
--- a/benchmarks/others/Makefile
+++ /dev/null
@@ -1,21 +0,0 @@
-.PHONY: all clean
-
-all: exception except setlongjmp except-fast except2
-
-clean:
- rm -f *.o except exception except-fast except2 setlongjmp
-
-exception: exception.cpp
- g++ $< -o $@ -O2
-
-except: except.scm
- csc $< -o $@ -O2 -d0
-
-except-fast: except.scm
- csc $< -o $@ -Ob
-
-except2: except2.scm
- csc $< -o $@ -Ob
-
-setlongjmp: setlongjmp.c
- gcc $< -o $@ -O2
diff --git a/benchmarks/others/except.scm b/benchmarks/others/except.scm
deleted file mode 100644
index 56c387d7..00000000
--- a/benchmarks/others/except.scm
+++ /dev/null
@@ -1,10 +0,0 @@
-(define n 0)
-
-(define (foo k)
- (set! n (+ n 1))
- (k 123))
-
-(let ((count (string->number (:optional (command-line-arguments) "10000"))))
- (do ((i count (- i 1)))
- ((zero? i) (print n))
- (call/cc (lambda (k) (foo k))) ) )
diff --git a/benchmarks/others/except2.scm b/benchmarks/others/except2.scm
deleted file mode 100644
index a83e0c2c..00000000
--- a/benchmarks/others/except2.scm
+++ /dev/null
@@ -1,10 +0,0 @@
-(define n 0)
-
-(define (foo k)
- (set! n (+ n 1))
- (##sys#direct-return k 123))
-
-(let ((count (string->number (:optional (command-line-arguments) "10000"))))
- (do ((i count (- i 1)))
- ((zero? i) (print n))
- (##sys#call-with-direct-continuation (lambda (k) (foo k))) ) )
diff --git a/benchmarks/others/exception.cpp b/benchmarks/others/exception.cpp
deleted file mode 100644
index a49f4ae5..00000000
--- a/benchmarks/others/exception.cpp
+++ /dev/null
@@ -1,25 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-
-static void foo()
-{
- throw 123;
-}
-
-int main(int argc, char *argv[])
-{
- int count = argc == 1 ? 10000 : atoi(argv[ 1 ]);
- int n = 0;
-
- for(int i = 0; i < count; ++i) {
- try {
- foo();
- }
- catch(...) {
- ++n;
- }
- }
-
- printf("%d\n", n);
- return 0;
-}
diff --git a/benchmarks/others/results.txt b/benchmarks/others/results.txt
deleted file mode 100644
index 8bd50f02..00000000
--- a/benchmarks/others/results.txt
+++ /dev/null
@@ -1,63 +0,0 @@
-Darwin o3215.o.pppool.de 8.0.0 Darwin Kernel Version 8.0.0: Sat Mar 26 14:15:22 PST 2005; root:xnu-792.obj~1/RELEASE_PPC Power Macintosh powerpc:
-%
-% time exception 1000000
-1000000
-
-real 0m32.497s
-user 0m22.000s
-sys 0m0.119s
-% time exception 1000000
-1000000
-
-real 0m28.155s
-user 0m21.985s
-sys 0m0.090s
-% time setlongjmp 1000000
-1000000
-
-real 0m5.516s
-user 0m1.269s
-sys 0m2.680s
-% time setlongjmp 1000000
-1000000
-
-real 0m4.993s
-user 0m1.239s
-sys 0m2.636s
-% time except 1000000
-1000000
-
-real 0m2.392s
-user 0m1.646s
-sys 0m0.078s
-% time except 1000000
-1000000
-
-real 0m2.208s
-user 0m1.652s
-sys 0m0.076s
-% time except-fast 1000000
-1000000
-
-real 0m1.374s
-user 0m1.034s
-sys 0m0.063s
-% time except-fast 1000000
-1000000
-
-real 0m1.364s
-user 0m1.033s
-sys 0m0.061s
-% time except2 1000000
-1000000
-
-real 0m0.419s
-user 0m0.283s
-sys 0m0.026s
-% time except2 1000000
-1000000
-
-real 0m0.404s
-user 0m0.285s
-sys 0m0.024s
-%
diff --git a/benchmarks/others/setlongjmp.c b/benchmarks/others/setlongjmp.c
deleted file mode 100644
index 355de55b..00000000
--- a/benchmarks/others/setlongjmp.c
+++ /dev/null
@@ -1,26 +0,0 @@
-#include <stdio.h>
-#include <stdlib.h>
-#include <setjmp.h>
-
-static int n = 0;
-static jmp_buf jb;
-
-static void foo()
-{
- ++n;
- longjmp(jb, 123);
-}
-
-int main(int argc, char *argv[])
-{
- int count = argc == 1 ? 10000 : atoi(argv[ 1 ]);
- int i;
-
- for(i = 0; i < count; ++i) {
- if(!setjmp(jb))
- foo();
- }
-
- printf("%d\n", n);
- return 0;
-}
diff --git a/benchmarks/puzzle.scm b/benchmarks/puzzle.scm
deleted file mode 100644
index 19bb73b8..00000000
--- a/benchmarks/puzzle.scm
+++ /dev/null
@@ -1,151 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: puzzle.sc
-;;; Description: PUZZLE benchmark
-;;; Author: Richard Gabriel, after Forrest Baskett
-;;; Created: 12-Apr-85
-;;; Modified: 12-Apr-85 14:20:23 (Bob Shaw)
-;;; 11-Aug-87 (Will Clinger)
-;;; 22-Jan-88 (Will Clinger)
-;;; 8-Oct-95 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (iota n)
- (do ((n n (- n 1)) (list '() (cons (- n 1) list))) ((zero? n) list)))
-
-;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
-
- (define size 511)
- (define classmax 3)
- (define typemax 12)
-
- (define *iii* 0)
- (define *kount* 0)
- (define *d* 8)
-
- (define *piececount* (make-vector (+ classmax 1) 0))
- (define *class* (make-vector (+ typemax 1) 0))
- (define *piecemax* (make-vector (+ typemax 1) 0))
- (define *puzzle* (make-vector (+ size 1)))
- (define *p* (make-vector (+ typemax 1)))
-
- (define (fit i j)
- (let ((end (vector-ref *piecemax* i)))
- (do ((k 0 (+ k 1)))
- ((or (> k end)
- (and (vector-ref (vector-ref *p* i) k)
- (vector-ref *puzzle* (+ j k))))
- (if (> k end) #t #f))))) ;Qobi: resist temptation to optimize
-
- (define (place i j)
- (let ((end (vector-ref *piecemax* i)))
- (do ((k 0 (+ k 1))) ((> k end))
- (cond ((vector-ref (vector-ref *p* i) k)
- (vector-set! *puzzle* (+ j k) #t)
- #t)))
- (vector-set! *piececount*
- (vector-ref *class* i)
- (- (vector-ref *piececount* (vector-ref *class* i)) 1))
- (do ((k j (+ k 1)))
- ((or (> k size) (not (vector-ref *puzzle* k)))
- ;;(newline)
- ;;(display "*Puzzle* filled")
- (if (> k size) 0 k)))))
-
- (define (puzzle-remove i j)
- (let ((end (vector-ref *piecemax* i)))
- (do ((k 0 (+ k 1))) ((> k end))
- (cond ((vector-ref (vector-ref *p* i) k)
- (vector-set! *puzzle* (+ j k) #f)
- #f)))
- (vector-set! *piececount*
- (vector-ref *class* i)
- (+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
-
- (define (trial j)
- (let ((k 0))
- (call-with-current-continuation
- (lambda (return)
- ;; Qobi: changed () to #F in the following
- (do ((i 0 (+ i 1))) ((> i typemax) (set! *kount* (+ *kount* 1)) #f)
- (cond ((not (zero? (vector-ref *piececount* (vector-ref *class* i))))
- (cond ((fit i j)
- (set! k (place i j))
- (cond ((or (trial k) (zero? k))
- ;;(trial-output (+ i 1) (+ k 1))
- (set! *kount* (+ *kount* 1))
- (return #t))
- (else (puzzle-remove i j))))))))))))
-
- (define (trial-output x y) ;Qobi: removed R3RS NUMBER->STRING
- (newline)
- (display "Piece ")
- (display x)
- (display " at ")
- (display y)
- (display "."))
-
- (define (definePiece iclass ii jj kk)
- (let ((index 0))
- (do ((i 0 (+ i 1))) ((> i ii))
- (do ((j 0 (+ j 1))) ((> j jj))
- (do ((k 0 (+ k 1))) ((> k kk))
- (set! index (+ i (* *d* (+ j (* *d* k)))))
- (vector-set! (vector-ref *p* *iii*) index #t))))
- (vector-set! *class* *iii* iclass)
- (vector-set! *piecemax* *iii* index)
- (cond ((not (= *iii* typemax)) (set! *iii* (+ *iii* 1))))))
-
- (define (start)
- (do ((m 0 (+ m 1))) ((> m size)) (vector-set! *puzzle* m #t))
- (do ((i 1 (+ i 1))) ((> i 5))
- (do ((j 1 (+ j 1))) ((> j 5))
- (do ((k 1 (+ k 1))) ((> k 5))
- (vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
- (do ((i 0 (+ i 1))) ((> i typemax))
- (do ((m 0 (+ m 1))) ((> m size))
- (vector-set! (vector-ref *p* i) m #f)))
- (set! *iii* 0)
- (definePiece 0 3 1 0)
- (definePiece 0 1 0 3)
- (definePiece 0 0 3 1)
- (definePiece 0 1 3 0)
- (definePiece 0 3 0 1)
- (definePiece 0 0 1 3)
-
- (definePiece 1 2 0 0)
- (definePiece 1 0 2 0)
- (definePiece 1 0 0 2)
-
- (definePiece 2 1 1 0)
- (definePiece 2 1 0 1)
- (definePiece 2 0 1 1)
-
- (definePiece 3 1 1 1)
-
- (vector-set! *piececount* 0 13)
- (vector-set! *piececount* 1 3)
- (vector-set! *piececount* 2 1)
- (vector-set! *piececount* 3 1)
- (let ((m (+ (* *d* (+ *d* 1)) 1))
- (n 0))
- (cond ((fit 0 m) (set! n (place 0 m)))
- (else (newline) (display "Error."))) ;Qobi: removed BEGIN
- (cond ((trial n) ;Qobi: removed BEGIN
- (newline)
- (display "Success in ")
- (write *kount*)
- (display " trials."))
- (else (newline) (display "Failure."))))) ;Qobi: removed BEGIN
-
- ;; Qobi: moved
- (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
- (iota (+ typemax 1)))
-
-(time
- (begin
- (start)
- (newline) ) ) ;Qobi: added
diff --git a/benchmarks/regex/benchmark.pl b/benchmarks/regex/benchmark.pl
deleted file mode 100644
index 261e0354..00000000
--- a/benchmarks/regex/benchmark.pl
+++ /dev/null
@@ -1,28 +0,0 @@
-#! /usr/bin/env perl
-
-use strict;
-
-sub bench ($$$) {
- my ($name, $sub, $n) = @_;
- my $start = times;
- for (my $i=0; $i<$n; $i++) { $sub->(); }
- print "$name: ".((times-$start)*1000)."\n";
-}
-
-open(IN, "< re-benchmarks.txt");
-while (<IN>) {
- next if /^\s*#/;
- my ($name, $pat, $str, $prefix, $compn, $execn) = split(/\t/);
- bench("$name: compile-time", sub {eval "/$pat/"}, $compn);
- my ($rx, $rxm, $str2);
- eval "\$rx = qr/$pat/";
- eval "\$rxm = qr/^$pat\$/";
- bench("$name: match-time", sub {$str =~ $rxm}, $execn);
- for (my $mult=1; $execn>=10; $mult*=10, $execn/=10) {
- $str2 = (($prefix x $mult).$str);
- bench("$name: search prefix x $mult", sub {$str2 =~ $rx}, $execn);
- }
-}
-close(IN);
-
-
diff --git a/benchmarks/regex/benchmark.scm b/benchmarks/regex/benchmark.scm
deleted file mode 100644
index 3d2106dc..00000000
--- a/benchmarks/regex/benchmark.scm
+++ /dev/null
@@ -1,58 +0,0 @@
-
-(use chicken extras regex data-structures srfi-13)
-(import irregex)
-
-(define-syntax time-expr
- (syntax-rules ()
- ((time-expr expr)
- (let ((start (nth-value 0 (cpu-time))))
- expr
- (- (nth-value 0 (cpu-time)) start)))))
-
-(define (string-replicate str reps)
- (let lp ((ls '()) (reps reps))
- (if (<= reps 0)
- (string-concatenate-reverse ls)
- (lp (cons str ls) (- reps 1)))))
-
-(define (run-bench name pat str prefix comp-count exec-count)
- (let-syntax
- ((bench (syntax-rules ()
- ((bench variation expr count)
- (let ((time-taken
- (time-expr (do ((i count (- i 1)))
- ((< i 0))
- expr))))
- (display name) (display ": ")
- (display variation) (display ": ")
- (write time-taken) (newline))))))
- (let ((comp-count (string->number comp-count))
- (exec-count (string->number exec-count)))
- ;; compile time
- (bench "compile-time" (string->irregex pat) comp-count)
- (let ((irx (string->irregex pat)))
- ;; match time
- (bench "match-time" (irregex-match irx str) exec-count)
- ;; search times
- (let lp ((mult 1) (reps exec-count))
- (cond
- ((>= reps 10)
- (let ((str (string-append (string-replicate prefix mult) str)))
- (bench (string-append "search prefix x " (number->string mult))
- (irregex-search irx str)
- reps)
- (lp (* mult 10) (quotient reps 10))))))))))
-
-(call-with-input-file "re-benchmarks.txt"
- (lambda (in)
- (let lp ()
- (let ((line (read-line in)))
- (cond
- ((eof-object? line))
- ((string-match "^\\s*#.*" line)
- (lp))
- (else
- (let ((ls (string-split line "\t")))
- (apply run-bench ls)
- (lp))))))))
-
diff --git a/benchmarks/regex/re-benchmarks.txt b/benchmarks/regex/re-benchmarks.txt
deleted file mode 100644
index b8f2acdb..00000000
--- a/benchmarks/regex/re-benchmarks.txt
+++ /dev/null
@@ -1,9 +0,0 @@
-char literal a a xxxxxxxxxx 1000 10000
-string literal abccb abccb xxxxxxxxxx 1000 10000
-ci string literal (?i:abccb) aBCcB xxxxxxxxxx 1000 10000
-best-case boyer-moore abcdefghijklmnopq abcdefghijklmnopq xxxxxxxxxx 1000 10000
-worst-case boyer-moore abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb bbbbbbbbbb 1000 10000
-alternation (?:asm|break|case|catch|const_cast|continue|default|delete|do|dynamic_cast|else|explicit|export|false|for|friend|goto|if|mutable|namespace|new|operator|private|protected|public|register|reinterpret_cast|return|sizeof|static_cast|switch|template|this|throw|true|try|typedef|typeid|typename|using|virtual|while) virtual aeiouaeiou 1 10000
-backtracker a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa x 100 100
-exponential dfa a[ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab] abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb b 1 100
-# backtracker + exponential dfa a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa[ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab] aaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbbbbbbbb b 1 100
diff --git a/benchmarks/scheme.scm b/benchmarks/scheme.scm
deleted file mode 100644
index 8b28b3f9..00000000
--- a/benchmarks/scheme.scm
+++ /dev/null
@@ -1,1082 +0,0 @@
-;;; SCHEME -- A Scheme interpreter evaluating a sorting routine, written by Marc Feeley.
-;
-; 08/06/01 (felix): renamed "macro?" to "macro?2" because MZC can't
-; handle redefinitions of primitives.
-; 18/07/01 (felix): 100 iterations
-;
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (scheme-eval expr)
- (let ((code (scheme-comp expr scheme-global-environment)))
- (code #f)))
-
-(define scheme-global-environment
- (cons '() ; environment chain
- '())) ; macros
-
-(define (scheme-add-macro name proc)
- (set-cdr! scheme-global-environment
- (cons (cons name proc) (cdr scheme-global-environment)))
- name)
-
-(define (scheme-error msg . args)
- (fatal-error msg args))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (lst->vector l)
- (let* ((n (length l))
- (v (make-vector n)))
- (let loop ((l l) (i 0))
- (if (pair? l)
- (begin
- (vector-set! v i (car l))
- (loop (cdr l) (+ i 1)))
- v))))
-
-(define (vector->lst v)
- (let loop ((l '()) (i (- (vector-length v) 1)))
- (if (< i 0)
- l
- (loop (cons (vector-ref v i) l) (- i 1)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define scheme-syntactic-keywords
- '(quote quasiquote unquote unquote-splicing
- lambda if set! cond => else and or
- case let let* letrec begin do define
- define-macro))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (push-frame frame env)
- (if (null? frame)
- env
- (cons (cons (car env) frame) (cdr env))))
-
-(define (lookup-var name env)
- (let loop1 ((chain (car env)) (up 0))
- (if (null? chain)
- name
- (let loop2 ((chain chain)
- (up up)
- (frame (cdr chain))
- (over 1))
- (cond ((null? frame)
- (loop1 (car chain) (+ up 1)))
- ((eq? (car frame) name)
- (cons up over))
- (else
- (loop2 chain up (cdr frame) (+ over 1))))))))
-
-(define (macro?2 name env)
- (assq name (cdr env)))
-
-(define (push-macro name proc env)
- (cons (car env) (cons (cons name proc) (cdr env))))
-
-(define (lookup-macro name env)
- (cdr (assq name (cdr env))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (variable x)
- (if (not (symbol? x))
- (scheme-error "Identifier expected" x))
- (if (memq x scheme-syntactic-keywords)
- (scheme-error "Variable name cannot be a syntactic keyword" x)))
-
-(define (shape form n)
- (let loop ((form form) (n n) (l form))
- (cond ((<= n 0))
- ((pair? l)
- (loop form (- n 1) (cdr l)))
- (else
- (scheme-error "Ill-constructed form" form)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (macro-expand expr env)
- (apply (lookup-macro (car expr) env) (cdr expr)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-var expr env)
- (variable expr)
- (gen-var-ref (lookup-var expr env)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-self-eval expr env)
- (gen-cst expr))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-quote expr env)
- (shape expr 2)
- (gen-cst (cadr expr)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-quasiquote expr env)
- (comp-quasiquotation (cadr expr) 1 env))
-
-(define (comp-quasiquotation form level env)
- (cond ((= level 0)
- (scheme-comp form env))
- ((pair? form)
- (cond
- ((eq? (car form) 'quasiquote)
- (comp-quasiquotation-list form (+ level 1) env))
- ((eq? (car form) 'unquote)
- (if (= level 1)
- (scheme-comp (cadr form) env)
- (comp-quasiquotation-list form (- level 1) env)))
- ((eq? (car form) 'unquote-splicing)
- (if (= level 1)
- (scheme-error "Ill-placed 'unquote-splicing'" form))
- (comp-quasiquotation-list form (- level 1) env))
- (else
- (comp-quasiquotation-list form level env))))
- ((vector? form)
- (gen-vector-form
- (comp-quasiquotation-list (vector->lst form) level env)))
- (else
- (gen-cst form))))
-
-(define (comp-quasiquotation-list l level env)
- (if (pair? l)
- (let ((first (car l)))
- (if (= level 1)
- (if (unquote-splicing? first)
- (begin
- (shape first 2)
- (gen-append-form (scheme-comp (cadr first) env)
- (comp-quasiquotation (cdr l) 1 env)))
- (gen-cons-form (comp-quasiquotation first level env)
- (comp-quasiquotation (cdr l) level env)))
- (gen-cons-form (comp-quasiquotation first level env)
- (comp-quasiquotation (cdr l) level env))))
- (comp-quasiquotation l level env)))
-
-(define (unquote-splicing? x)
- (if (pair? x)
- (if (eq? (car x) 'unquote-splicing) #t #f)
- #f))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-unquote expr env)
- (scheme-error "Ill-placed 'unquote'" expr))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-unquote-splicing expr env)
- (scheme-error "Ill-placed 'unquote-splicing'" expr))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-set! expr env)
- (shape expr 3)
- (variable (cadr expr))
- (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-lambda expr env)
- (shape expr 3)
- (let ((parms (cadr expr)))
- (let ((frame (parms->frame parms)))
- (let ((nb-vars (length frame))
- (code (comp-body (cddr expr) (push-frame frame env))))
- (if (rest-param? parms)
- (gen-lambda-rest nb-vars code)
- (gen-lambda nb-vars code))))))
-
-(define (parms->frame parms)
- (cond ((null? parms)
- '())
- ((pair? parms)
- (let ((x (car parms)))
- (variable x)
- (cons x (parms->frame (cdr parms)))))
- (else
- (variable parms)
- (list parms))))
-
-(define (rest-param? parms)
- (cond ((pair? parms)
- (rest-param? (cdr parms)))
- ((null? parms)
- #f)
- (else
- #t)))
-
-(define (comp-body body env)
-
- (define (letrec-defines vars vals body env)
- (if (pair? body)
-
- (let ((expr (car body)))
- (cond ((not (pair? expr))
- (letrec-defines* vars vals body env))
- ((macro?2 (car expr) env)
- (letrec-defines vars
- vals
- (cons (macro-expand expr env) (cdr body))
- env))
- (else
- (cond
- ((eq? (car expr) 'begin)
- (letrec-defines vars
- vals
- (append (cdr expr) (cdr body))
- env))
- ((eq? (car expr) 'define)
- (let ((x (definition-name expr)))
- (variable x)
- (letrec-defines (cons x vars)
- (cons (definition-value expr) vals)
- (cdr body)
- env)))
- ((eq? (car expr) 'define-macro)
- (let ((x (definition-name expr)))
- (letrec-defines vars
- vals
- (cdr body)
- (push-macro
- x
- (scheme-eval (definition-value expr))
- env))))
- (else
- (letrec-defines* vars vals body env))))))
-
- (scheme-error "Body must contain at least one evaluable expression")))
-
- (define (letrec-defines* vars vals body env)
- (if (null? vars)
- (comp-sequence body env)
- (comp-letrec-aux vars vals body env)))
-
- (letrec-defines '() '() body env))
-
-(define (definition-name expr)
- (shape expr 3)
- (let ((pattern (cadr expr)))
- (let ((name (if (pair? pattern) (car pattern) pattern)))
- (if (not (symbol? name))
- (scheme-error "Identifier expected" name))
- name)))
-
-(define (definition-value expr)
- (let ((pattern (cadr expr)))
- (if (pair? pattern)
- (cons 'lambda (cons (cdr pattern) (cddr expr)))
- (caddr expr))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-if expr env)
- (shape expr 3)
- (let ((code1 (scheme-comp (cadr expr) env))
- (code2 (scheme-comp (caddr expr) env)))
- (if (pair? (cdddr expr))
- (gen-if code1 code2 (scheme-comp (cadddr expr) env))
- (gen-when code1 code2))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-cond expr env)
- (comp-cond-aux (cdr expr) env))
-
-(define (comp-cond-aux clauses env)
- (if (pair? clauses)
- (let ((clause (car clauses)))
- (shape clause 1)
- (cond ((eq? (car clause) 'else)
- (shape clause 2)
- (comp-sequence (cdr clause) env))
- ((not (pair? (cdr clause)))
- (gen-or (scheme-comp (car clause) env)
- (comp-cond-aux (cdr clauses) env)))
- ((eq? (cadr clause) '=>)
- (shape clause 3)
- (gen-cond-send (scheme-comp (car clause) env)
- (scheme-comp (caddr clause) env)
- (comp-cond-aux (cdr clauses) env)))
- (else
- (gen-if (scheme-comp (car clause) env)
- (comp-sequence (cdr clause) env)
- (comp-cond-aux (cdr clauses) env)))))
- (gen-cst '())))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-and expr env)
- (let ((rest (cdr expr)))
- (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))
-
-(define (comp-and-aux l env)
- (let ((code (scheme-comp (car l) env))
- (rest (cdr l)))
- (if (pair? rest) (gen-and code (comp-and-aux rest env)) code)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-or expr env)
- (let ((rest (cdr expr)))
- (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))
-
-(define (comp-or-aux l env)
- (let ((code (scheme-comp (car l) env))
- (rest (cdr l)))
- (if (pair? rest) (gen-or code (comp-or-aux rest env)) code)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-case expr env)
- (shape expr 3)
- (gen-case (scheme-comp (cadr expr) env)
- (comp-case-aux (cddr expr) env)))
-
-(define (comp-case-aux clauses env)
- (if (pair? clauses)
- (let ((clause (car clauses)))
- (shape clause 2)
- (if (eq? (car clause) 'else)
- (gen-case-else (comp-sequence (cdr clause) env))
- (gen-case-clause (car clause)
- (comp-sequence (cdr clause) env)
- (comp-case-aux (cdr clauses) env))))
- (gen-case-else (gen-cst '()))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-let expr env)
- (shape expr 3)
- (let ((x (cadr expr)))
- (cond ((symbol? x)
- (shape expr 4)
- (let ((y (caddr expr)))
- (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr)))))
- (scheme-comp (cons (list 'letrec (list (list x proc)) x)
- (bindings->vals y))
- env))))
- ((pair? x)
- (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr)))
- (bindings->vals x))
- env))
- (else
- (comp-body (cddr expr) env)))))
-
-(define (bindings->vars bindings)
- (if (pair? bindings)
- (let ((binding (car bindings)))
- (shape binding 2)
- (let ((x (car binding)))
- (variable x)
- (cons x (bindings->vars (cdr bindings)))))
- '()))
-
-(define (bindings->vals bindings)
- (if (pair? bindings)
- (let ((binding (car bindings)))
- (cons (cadr binding) (bindings->vals (cdr bindings))))
- '()))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-let* expr env)
- (shape expr 3)
- (let ((bindings (cadr expr)))
- (if (pair? bindings)
- (scheme-comp (list 'let
- (list (car bindings))
- (cons 'let* (cons (cdr bindings) (cddr expr))))
- env)
- (comp-body (cddr expr) env))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-letrec expr env)
- (shape expr 3)
- (let ((bindings (cadr expr)))
- (comp-letrec-aux (bindings->vars bindings)
- (bindings->vals bindings)
- (cddr expr)
- env)))
-
-(define (comp-letrec-aux vars vals body env)
- (if (pair? vars)
- (let ((new-env (push-frame vars env)))
- (gen-letrec (comp-vals vals new-env)
- (comp-body body new-env)))
- (comp-body body env)))
-
-(define (comp-vals l env)
- (if (pair? l)
- (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
- '()))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-begin expr env)
- (shape expr 2)
- (comp-sequence (cdr expr) env))
-
-(define (comp-sequence exprs env)
- (if (pair? exprs)
- (comp-sequence-aux exprs env)
- (gen-cst '())))
-
-(define (comp-sequence-aux exprs env)
- (let ((code (scheme-comp (car exprs) env))
- (rest (cdr exprs)))
- (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-do expr env)
- (shape expr 3)
- (let ((bindings (cadr expr))
- (exit (caddr expr)))
- (shape exit 1)
- (let* ((vars (bindings->vars bindings))
- (new-env1 (push-frame '(#f) env))
- (new-env2 (push-frame vars new-env1)))
- (gen-letrec
- (list
- (gen-lambda
- (length vars)
- (gen-if
- (scheme-comp (car exit) new-env2)
- (comp-sequence (cdr exit) new-env2)
- (gen-sequence
- (comp-sequence (cdddr expr) new-env2)
- (gen-combination
- (gen-var-ref '(1 . 1))
- (comp-vals (bindings->steps bindings) new-env2))))))
- (gen-combination
- (gen-var-ref '(0 . 1))
- (comp-vals (bindings->vals bindings) new-env1))))))
-
-(define (bindings->steps bindings)
- (if (pair? bindings)
- (let ((binding (car bindings)))
- (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
- (bindings->steps (cdr bindings))))
- '()))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-define expr env)
- (shape expr 3)
- (let ((pattern (cadr expr)))
- (let ((x (if (pair? pattern) (car pattern) pattern)))
- (variable x)
- (gen-sequence
- (gen-var-set (lookup-var x env)
- (scheme-comp (if (pair? pattern)
- (cons 'lambda (cons (cdr pattern) (cddr expr)))
- (caddr expr))
- env))
- (gen-cst x)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-define-macro expr env)
- (let ((x (definition-name expr)))
- (gen-macro x (scheme-eval (definition-value expr)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (comp-combination expr env)
- (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))
-
-;------------------------------------------------------------------------------
-
-(define (gen-var-ref var)
- (if (pair? var)
- (gen-rte-ref (car var) (cdr var))
- (gen-glo-ref (scheme-global-var var))))
-
-(define (gen-rte-ref up over)
- (case up
- ((0) (gen-slot-ref-0 over))
- ((1) (gen-slot-ref-1 over))
- (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))
-
-(define (gen-slot-ref-0 i)
- (case i
- ((0) (lambda (rte) (vector-ref rte 0)))
- ((1) (lambda (rte) (vector-ref rte 1)))
- ((2) (lambda (rte) (vector-ref rte 2)))
- ((3) (lambda (rte) (vector-ref rte 3)))
- (else (lambda (rte) (vector-ref rte i)))))
-
-(define (gen-slot-ref-1 i)
- (case i
- ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
- ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
- ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
- ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
- (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))
-
-(define (gen-slot-ref-up-2 code)
- (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
-
-(define (gen-glo-ref i)
- (lambda (rte) (scheme-global-var-ref i)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-cst val)
- (case val
- ((()) (lambda (rte) '()))
- ((#f) (lambda (rte) #f))
- ((#t) (lambda (rte) #t))
- ((-2) (lambda (rte) -2))
- ((-1) (lambda (rte) -1))
- ((0) (lambda (rte) 0))
- ((1) (lambda (rte) 1))
- ((2) (lambda (rte) 2))
- (else (lambda (rte) val))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-append-form code1 code2)
- (lambda (rte) (append (code1 rte) (code2 rte))))
-
-(define (gen-cons-form code1 code2)
- (lambda (rte) (cons (code1 rte) (code2 rte))))
-
-(define (gen-vector-form code)
- (lambda (rte) (lst->vector (code rte))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-var-set var code)
- (if (pair? var)
- (gen-rte-set (car var) (cdr var) code)
- (gen-glo-set (scheme-global-var var) code)))
-
-(define (gen-rte-set up over code)
- (case up
- ((0) (gen-slot-set-0 over code))
- ((1) (gen-slot-set-1 over code))
- (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))
-
-(define (gen-slot-set-0 i code)
- (case i
- ((0) (lambda (rte) (vector-set! rte 0 (code rte))))
- ((1) (lambda (rte) (vector-set! rte 1 (code rte))))
- ((2) (lambda (rte) (vector-set! rte 2 (code rte))))
- ((3) (lambda (rte) (vector-set! rte 3 (code rte))))
- (else (lambda (rte) (vector-set! rte i (code rte))))))
-
-(define (gen-slot-set-1 i code)
- (case i
- ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
- ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
- ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
- ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
- (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))
-
-(define (gen-slot-set-n up i code)
- (case i
- ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
- ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
- ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
- ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
- (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))
-
-(define (gen-glo-set i code)
- (lambda (rte) (scheme-global-var-set! i (code rte))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-lambda-rest nb-vars body)
- (case nb-vars
- ((1) (gen-lambda-1-rest body))
- ((2) (gen-lambda-2-rest body))
- ((3) (gen-lambda-3-rest body))
- (else (gen-lambda-n-rest nb-vars body))))
-
-(define (gen-lambda-1-rest body)
- (lambda (rte)
- (lambda a
- (body (vector rte a)))))
-
-(define (gen-lambda-2-rest body)
- (lambda (rte)
- (lambda (a . b)
- (body (vector rte a b)))))
-
-(define (gen-lambda-3-rest body)
- (lambda (rte)
- (lambda (a b . c)
- (body (vector rte a b c)))))
-
-(define (gen-lambda-n-rest nb-vars body)
- (lambda (rte)
- (lambda (a b c . d)
- (let ((x (make-vector (+ nb-vars 1))))
- (vector-set! x 0 rte)
- (vector-set! x 1 a)
- (vector-set! x 2 b)
- (vector-set! x 3 c)
- (let loop ((n nb-vars) (x x) (i 4) (l d))
- (if (< i n)
- (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
- (vector-set! x i l)))
- (body x)))))
-
-(define (gen-lambda nb-vars body)
- (case nb-vars
- ((0) (gen-lambda-0 body))
- ((1) (gen-lambda-1 body))
- ((2) (gen-lambda-2 body))
- ((3) (gen-lambda-3 body))
- (else (gen-lambda-n nb-vars body))))
-
-(define (gen-lambda-0 body)
- (lambda (rte)
- (lambda ()
- (body rte))))
-
-(define (gen-lambda-1 body)
- (lambda (rte)
- (lambda (a)
- (body (vector rte a)))))
-
-(define (gen-lambda-2 body)
- (lambda (rte)
- (lambda (a b)
- (body (vector rte a b)))))
-
-(define (gen-lambda-3 body)
- (lambda (rte)
- (lambda (a b c)
- (body (vector rte a b c)))))
-
-(define (gen-lambda-n nb-vars body)
- (lambda (rte)
- (lambda (a b c . d)
- (let ((x (make-vector (+ nb-vars 1))))
- (vector-set! x 0 rte)
- (vector-set! x 1 a)
- (vector-set! x 2 b)
- (vector-set! x 3 c)
- (let loop ((n nb-vars) (x x) (i 4) (l d))
- (if (<= i n)
- (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
- (body x)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-sequence code1 code2)
- (lambda (rte) (code1 rte) (code2 rte)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-when code1 code2)
- (lambda (rte)
- (if (code1 rte)
- (code2 rte)
- '())))
-
-(define (gen-if code1 code2 code3)
- (lambda (rte)
- (if (code1 rte)
- (code2 rte)
- (code3 rte))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-cond-send code1 code2 code3)
- (lambda (rte)
- (let ((temp (code1 rte)))
- (if temp
- ((code2 rte) temp)
- (code3 rte)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-and code1 code2)
- (lambda (rte)
- (let ((temp (code1 rte)))
- (if temp
- (code2 rte)
- temp))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-or code1 code2)
- (lambda (rte)
- (let ((temp (code1 rte)))
- (if temp
- temp
- (code2 rte)))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-case code1 code2)
- (lambda (rte) (code2 rte (code1 rte))))
-
-(define (gen-case-clause datums code1 code2)
- (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key))))
-
-(define (gen-case-else code)
- (lambda (rte key) (code rte)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-letrec vals body)
- (let ((nb-vals (length vals)))
- (case nb-vals
- ((1) (gen-letrec-1 (car vals) body))
- ((2) (gen-letrec-2 (car vals) (cadr vals) body))
- ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body))
- (else (gen-letrec-n nb-vals vals body)))))
-
-(define (gen-letrec-1 val1 body)
- (lambda (rte)
- (let ((x (vector rte #f)))
- (vector-set! x 1 (val1 x))
- (body x))))
-
-(define (gen-letrec-2 val1 val2 body)
- (lambda (rte)
- (let ((x (vector rte #f #f)))
- (vector-set! x 1 (val1 x))
- (vector-set! x 2 (val2 x))
- (body x))))
-
-(define (gen-letrec-3 val1 val2 val3 body)
- (lambda (rte)
- (let ((x (vector rte #f #f #f)))
- (vector-set! x 1 (val1 x))
- (vector-set! x 2 (val2 x))
- (vector-set! x 3 (val3 x))
- (body x))))
-
-(define (gen-letrec-n nb-vals vals body)
- (lambda (rte)
- (let ((x (make-vector (+ nb-vals 1))))
- (vector-set! x 0 rte)
- (let loop ((x x) (i 1) (l vals))
- (if (pair? l)
- (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l)))))
- (body x))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-macro name proc)
- (lambda (rte) (scheme-add-macro name proc)))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (gen-combination oper args)
- (case (length args)
- ((0) (gen-combination-0 oper))
- ((1) (gen-combination-1 oper (car args)))
- ((2) (gen-combination-2 oper (car args) (cadr args)))
- ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args)))
- (else (gen-combination-n oper args))))
-
-(define (gen-combination-0 oper)
- (lambda (rte) ((oper rte))))
-
-(define (gen-combination-1 oper arg1)
- (lambda (rte) ((oper rte) (arg1 rte))))
-
-(define (gen-combination-2 oper arg1 arg2)
- (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte))))
-
-(define (gen-combination-3 oper arg1 arg2 arg3)
- (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
-
-(define (gen-combination-n oper args)
- (lambda (rte)
- (define (evaluate l rte)
- (if (pair? l)
- (cons ((car l) rte) (evaluate (cdr l) rte))
- '()))
- (apply (oper rte) (evaluate args rte))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (scheme-comp expr env)
- (cond ((symbol? expr)
- (comp-var expr env))
- ((not (pair? expr))
- (comp-self-eval expr env))
- ((macro?2 (car expr) env)
- (scheme-comp (macro-expand expr env) env))
- (else
- (cond
- ((eq? (car expr) 'quote) (comp-quote expr env))
- ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env))
- ((eq? (car expr) 'unquote) (comp-unquote expr env))
- ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env))
- ((eq? (car expr) 'set!) (comp-set! expr env))
- ((eq? (car expr) 'lambda) (comp-lambda expr env))
- ((eq? (car expr) 'if) (comp-if expr env))
- ((eq? (car expr) 'cond) (comp-cond expr env))
- ((eq? (car expr) 'and) (comp-and expr env))
- ((eq? (car expr) 'or) (comp-or expr env))
- ((eq? (car expr) 'case) (comp-case expr env))
- ((eq? (car expr) 'let) (comp-let expr env))
- ((eq? (car expr) 'let*) (comp-let* expr env))
- ((eq? (car expr) 'letrec) (comp-letrec expr env))
- ((eq? (car expr) 'begin) (comp-begin expr env))
- ((eq? (car expr) 'do) (comp-do expr env))
- ((eq? (car expr) 'define) (comp-define expr env))
- ((eq? (car expr) 'define-macro) (comp-define-macro expr env))
- (else (comp-combination expr env))))))
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (scheme-global-var name)
- (let ((x (assq name scheme-global-variables)))
- (if x
- x
- (let ((y (cons name '())))
- (set! scheme-global-variables (cons y scheme-global-variables))
- y))))
-
-(define (scheme-global-var-ref i)
- (cdr i))
-
-(define (scheme-global-var-set! i val)
- (set-cdr! i val)
- '())
-
-(define scheme-global-variables '())
-
-(define (def-proc name value)
- (scheme-global-var-set!
- (scheme-global-var name)
- value))
-
-(def-proc 'not (lambda (x) (not x)))
-(def-proc 'boolean? boolean?)
-(def-proc 'eqv? eqv?)
-(def-proc 'eq? eq?)
-(def-proc 'equal? equal?)
-(def-proc 'pair? pair?)
-(def-proc 'cons cons)
-(def-proc 'car (lambda (x) (car x)))
-(def-proc 'cdr (lambda (x) (cdr x)))
-(def-proc 'set-car! set-car!)
-(def-proc 'set-cdr! set-cdr!)
-(def-proc 'caar caar)
-(def-proc 'cadr cadr)
-(def-proc 'cdar cdar)
-(def-proc 'cddr cddr)
-(def-proc 'caaar caaar)
-(def-proc 'caadr caadr)
-(def-proc 'cadar cadar)
-(def-proc 'caddr caddr)
-(def-proc 'cdaar cdaar)
-(def-proc 'cdadr cdadr)
-(def-proc 'cddar cddar)
-(def-proc 'cdddr cdddr)
-(def-proc 'caaaar caaaar)
-(def-proc 'caaadr caaadr)
-(def-proc 'caadar caadar)
-(def-proc 'caaddr caaddr)
-(def-proc 'cadaar cadaar)
-(def-proc 'cadadr cadadr)
-(def-proc 'caddar caddar)
-(def-proc 'cadddr cadddr)
-(def-proc 'cdaaar cdaaar)
-(def-proc 'cdaadr cdaadr)
-(def-proc 'cdadar cdadar)
-(def-proc 'cdaddr cdaddr)
-(def-proc 'cddaar cddaar)
-(def-proc 'cddadr cddadr)
-(def-proc 'cdddar cdddar)
-(def-proc 'cddddr cddddr)
-(def-proc 'null? (lambda (x) (null? x)))
-(def-proc 'list? list?)
-(def-proc 'list list)
-(def-proc 'length length)
-(def-proc 'append append)
-(def-proc 'reverse reverse)
-(def-proc 'list-ref list-ref)
-(def-proc 'memq memq)
-(def-proc 'memv memv)
-(def-proc 'member member)
-(def-proc 'assq assq)
-(def-proc 'assv assv)
-(def-proc 'assoc assoc)
-(def-proc 'symbol? symbol?)
-(def-proc 'symbol->string symbol->string)
-(def-proc 'string->symbol string->symbol)
-(def-proc 'number? number?)
-(def-proc 'complex? complex?)
-(def-proc 'real? real?)
-(def-proc 'rational? rational?)
-(def-proc 'integer? integer?)
-(def-proc 'exact? exact?)
-(def-proc 'inexact? inexact?)
-;(def-proc '= =)
-;(def-proc '< <)
-;(def-proc '> >)
-;(def-proc '<= <=)
-;(def-proc '>= >=)
-;(def-proc 'zero? zero?)
-;(def-proc 'positive? positive?)
-;(def-proc 'negative? negative?)
-;(def-proc 'odd? odd?)
-;(def-proc 'even? even?)
-(def-proc 'max max)
-(def-proc 'min min)
-;(def-proc '+ +)
-;(def-proc '* *)
-;(def-proc '- -)
-(def-proc '/ /)
-(def-proc 'abs abs)
-;(def-proc 'quotient quotient)
-;(def-proc 'remainder remainder)
-;(def-proc 'modulo modulo)
-(def-proc 'gcd gcd)
-(def-proc 'lcm lcm)
-;(def-proc 'numerator numerator)
-;(def-proc 'denominator denominator)
-(def-proc 'floor floor)
-(def-proc 'ceiling ceiling)
-(def-proc 'truncate truncate)
-(def-proc 'round round)
-;(def-proc 'rationalize rationalize)
-(def-proc 'exp exp)
-(def-proc 'log log)
-(def-proc 'sin sin)
-(def-proc 'cos cos)
-(def-proc 'tan tan)
-(def-proc 'asin asin)
-(def-proc 'acos acos)
-(def-proc 'atan atan)
-(def-proc 'sqrt sqrt)
-(def-proc 'expt expt)
-;(def-proc 'make-rectangular make-rectangular)
-;(def-proc 'make-polar make-polar)
-;(def-proc 'real-part real-part)
-;(def-proc 'imag-part imag-part)
-;(def-proc 'magnitude magnitude)
-;(def-proc 'angle angle)
-(def-proc 'exact->inexact exact->inexact)
-(def-proc 'inexact->exact inexact->exact)
-(def-proc 'number->string number->string)
-(def-proc 'string->number string->number)
-(def-proc 'char? char?)
-(def-proc 'char=? char=?)
-(def-proc 'char<? char<?)
-(def-proc 'char>? char>?)
-(def-proc 'char<=? char<=?)
-(def-proc 'char>=? char>=?)
-(def-proc 'char-ci=? char-ci=?)
-(def-proc 'char-ci<? char-ci<?)
-(def-proc 'char-ci>? char-ci>?)
-(def-proc 'char-ci<=? char-ci<=?)
-(def-proc 'char-ci>=? char-ci>=?)
-(def-proc 'char-alphabetic? char-alphabetic?)
-(def-proc 'char-numeric? char-numeric?)
-(def-proc 'char-whitespace? char-whitespace?)
-(def-proc 'char-lower-case? char-lower-case?)
-(def-proc 'char->integer char->integer)
-(def-proc 'integer->char integer->char)
-(def-proc 'char-upcase char-upcase)
-(def-proc 'char-downcase char-downcase)
-(def-proc 'string? string?)
-(def-proc 'make-string make-string)
-(def-proc 'string string)
-(def-proc 'string-length string-length)
-(def-proc 'string-ref string-ref)
-(def-proc 'string-set! string-set!)
-(def-proc 'string=? string=?)
-(def-proc 'string<? string<?)
-(def-proc 'string>? string>?)
-(def-proc 'string<=? string<=?)
-(def-proc 'string>=? string>=?)
-(def-proc 'string-ci=? string-ci=?)
-(def-proc 'string-ci<? string-ci<?)
-(def-proc 'string-ci>? string-ci>?)
-(def-proc 'string-ci<=? string-ci<=?)
-(def-proc 'string-ci>=? string-ci>=?)
-(def-proc 'substring substring)
-(def-proc 'string-append string-append)
-(def-proc 'vector? vector?)
-(def-proc 'make-vector make-vector)
-(def-proc 'vector vector)
-(def-proc 'vector-length vector-length)
-(def-proc 'vector-ref vector-ref)
-(def-proc 'vector-set! vector-set!)
-(def-proc 'procedure? procedure?)
-(def-proc 'apply apply)
-(def-proc 'map map)
-(def-proc 'for-each for-each)
-(def-proc 'call-with-current-continuation call-with-current-continuation)
-(def-proc 'call-with-input-file call-with-input-file)
-(def-proc 'call-with-output-file call-with-output-file)
-(def-proc 'input-port? input-port?)
-(def-proc 'output-port? output-port?)
-(def-proc 'current-input-port current-input-port)
-(def-proc 'current-output-port current-output-port)
-(def-proc 'open-input-file open-input-file)
-(def-proc 'open-output-file open-output-file)
-(def-proc 'close-input-port close-input-port)
-(def-proc 'close-output-port close-output-port)
-(def-proc 'eof-object? eof-object?)
-(def-proc 'read read)
-(def-proc 'read-char read-char)
-(def-proc 'peek-char peek-char)
-(def-proc 'write write)
-(def-proc 'display display)
-(def-proc 'newline newline)
-(def-proc 'write-char write-char)
-
-; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-(define (run)
- (let ((result #f))
- (do ((i 100 (- i 1)))
- ((zero? i) result)
- (set! result
- (scheme-eval
- '(let ()
-
- (define (sort-list obj pred)
-
- (define (loop l)
- (if (and (pair? l) (pair? (cdr l)))
- (split l '() '())
- l))
-
- (define (split l one two)
- (if (pair? l)
- (split (cdr l) two (cons (car l) one))
- (merge (loop one) (loop two))))
-
- (define (merge one two)
- (cond ((null? one) two)
- ((pred (car two) (car one))
- (cons (car two)
- (merge (cdr two) one)))
- (else
- (cons (car one)
- (merge (cdr one) two)))))
-
- (loop obj))
-
- (sort-list '("one" "two" "three" "four" "five" "six"
- "seven" "eight" "nine" "ten" "eleven" "twelve")
- string<?)))))))
-
-(let ((r (time (run))))
- (if (not (equal? r '("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two")))
- (error "wrong result" r) ) )
-
diff --git a/benchmarks/tak.scm b/benchmarks/tak.scm
deleted file mode 100644
index 48d2e40d..00000000
--- a/benchmarks/tak.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-;;;; tak.scm
-
-
-(define (tak x y z)
- (if (not (< y x))
- z
- (tak (tak (- x 1) y z)
- (tak (- y 1) z x)
- (tak (- z 1) x y) ) ) )
-
-(time (do ((i 100 (- i 1))) ((zero? i)) (tak 18 12 6)))
diff --git a/benchmarks/takl.scm b/benchmarks/takl.scm
deleted file mode 100644
index e467756a..00000000
--- a/benchmarks/takl.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;;;; takl.scm
-
-
-(define (listn n)
- (if (= 0 n)
- '()
- (cons n (listn (- n 1)))) )
-
-(define 18l (listn 18))
-(define 12l (listn 12))
-(define 6l (listn 6))
-
-(define (mas x y z)
- (if (not (shorterp y x))
- z
- (mas (mas (cdr x)
- y z)
- (mas (cdr y)
- z x)
- (mas (cdr z)
- x y))))
-
-(define (shorterp x y)
- (and (pair? y)
- (or (null? x)
- (shorterp (cdr x)
- (cdr y)))) )
-
-(time (do ((i 10 (- i 1))) ((zero? i)) (mas 18l 12l 6l)))
-
diff --git a/benchmarks/takr.scm b/benchmarks/takr.scm
deleted file mode 100644
index 7f378f82..00000000
--- a/benchmarks/takr.scm
+++ /dev/null
@@ -1,507 +0,0 @@
-;;; takr.scm
-
-
-(define (tak0 x y z)
- (cond ((not (< y x)) z)
- (else (tak1 (tak37 (- x 1) y z)
- (tak11 (- y 1) z x)
- (tak17 (- z 1) x y)))))
-(define (tak1 x y z)
- (cond ((not (< y x)) z)
- (else (tak2 (tak74 (- x 1) y z)
- (tak22 (- y 1) z x)
- (tak34 (- z 1) x y)))))
-(define (tak2 x y z)
- (cond ((not (< y x)) z)
- (else (tak3 (tak11 (- x 1) y z)
- (tak33 (- y 1) z x)
- (tak51 (- z 1) x y)))))
-(define (tak3 x y z)
- (cond ((not (< y x)) z)
- (else (tak4 (tak48 (- x 1) y z)
- (tak44 (- y 1) z x)
- (tak68 (- z 1) x y)))))
-(define (tak4 x y z)
- (cond ((not (< y x)) z)
- (else (tak5 (tak85 (- x 1) y z)
- (tak55 (- y 1) z x)
- (tak85 (- z 1) x y)))))
-(define (tak5 x y z)
- (cond ((not (< y x)) z)
- (else (tak6 (tak22 (- x 1) y z)
- (tak66 (- y 1) z x)
- (tak2 (- z 1) x y)))))
-(define (tak6 x y z)
- (cond ((not (< y x)) z)
- (else (tak7 (tak59 (- x 1) y z)
- (tak77 (- y 1) z x)
- (tak19 (- z 1) x y)))))
-(define (tak7 x y z)
- (cond ((not (< y x)) z)
- (else (tak8 (tak96 (- x 1) y z)
- (tak88 (- y 1) z x)
- (tak36 (- z 1) x y)))))
-(define (tak8 x y z)
- (cond ((not (< y x)) z)
- (else (tak9 (tak33 (- x 1) y z)
- (tak99 (- y 1) z x)
- (tak53 (- z 1) x y)))))
-(define (tak9 x y z)
- (cond ((not (< y x)) z)
- (else (tak10 (tak70 (- x 1) y z)
- (tak10 (- y 1) z x)
- (tak70 (- z 1) x y)))))
-(define (tak10 x y z)
- (cond ((not (< y x)) z)
- (else (tak11 (tak7 (- x 1) y z)
- (tak21 (- y 1) z x)
- (tak87 (- z 1) x y)))))
-(define (tak11 x y z)
- (cond ((not (< y x)) z)
- (else (tak12 (tak44 (- x 1) y z)
- (tak32 (- y 1) z x)
- (tak4 (- z 1) x y)))))
-(define (tak12 x y z)
- (cond ((not (< y x)) z)
- (else (tak13 (tak81 (- x 1) y z)
- (tak43 (- y 1) z x)
- (tak21 (- z 1) x y)))))
-
-(define (tak13 x y z)
- (cond ((not (< y x)) z)
- (else (tak14 (tak18 (- x 1) y z)
- (tak54 (- y 1) z x)
- (tak38 (- z 1) x y)))))
-(define (tak14 x y z)
- (cond ((not (< y x)) z)
- (else (tak15 (tak55 (- x 1) y z)
- (tak65 (- y 1) z x)
- (tak55 (- z 1) x y)))))
-(define (tak15 x y z)
- (cond ((not (< y x)) z)
- (else (tak16 (tak92 (- x 1) y z)
- (tak76 (- y 1) z x)
- (tak72 (- z 1) x y)))))
-(define (tak16 x y z)
- (cond ((not (< y x)) z)
- (else (tak17 (tak29 (- x 1) y z)
- (tak87 (- y 1) z x)
- (tak89 (- z 1) x y)))))
-(define (tak17 x y z)
- (cond ((not (< y x)) z)
- (else (tak18 (tak66 (- x 1) y z)
- (tak98 (- y 1) z x)
- (tak6 (- z 1) x y)))))
-(define (tak18 x y z)
- (cond ((not (< y x)) z)
- (else (tak19 (tak3 (- x 1) y z)
- (tak9 (- y 1) z x)
- (tak23 (- z 1) x y)))))
-(define (tak19 x y z)
- (cond ((not (< y x)) z)
- (else (tak20 (tak40 (- x 1) y z)
- (tak20 (- y 1) z x)
- (tak40 (- z 1) x y)))))
-(define (tak20 x y z)
- (cond ((not (< y x)) z)
- (else (tak21 (tak77 (- x 1) y z)
- (tak31 (- y 1) z x)
- (tak57 (- z 1) x y)))))
-(define (tak21 x y z)
- (cond ((not (< y x)) z)
- (else (tak22 (tak14 (- x 1) y z)
- (tak42 (- y 1) z x)
- (tak74 (- z 1) x y)))))
-(define (tak22 x y z)
- (cond ((not (< y x)) z)
- (else (tak23 (tak51 (- x 1) y z)
- (tak53 (- y 1) z x)
- (tak91 (- z 1) x y)))))
-(define (tak23 x y z)
- (cond ((not (< y x)) z)
- (else (tak24 (tak88 (- x 1) y z)
- (tak64 (- y 1) z x)
- (tak8 (- z 1) x y)))))
-(define (tak24 x y z)
- (cond ((not (< y x)) z)
- (else (tak25 (tak25 (- x 1) y z)
- (tak75 (- y 1) z x)
- (tak25 (- z 1) x y)))))
-(define (tak25 x y z)
- (cond ((not (< y x)) z)
- (else (tak26 (tak62 (- x 1) y z)
- (tak86 (- y 1) z x)
- (tak42 (- z 1) x y)))))
-(define (tak26 x y z)
- (cond ((not (< y x)) z)
- (else (tak27 (tak99 (- x 1) y z)
- (tak97 (- y 1) z x)
- (tak59 (- z 1) x y)))))
-(define (tak27 x y z)
- (cond ((not (< y x)) z)
- (else (tak28 (tak36 (- x 1) y z)
- (tak8 (- y 1) z x)
- (tak76 (- z 1) x y)))))
-(define (tak28 x y z)
- (cond ((not (< y x)) z)
- (else (tak29 (tak73 (- x 1) y z)
- (tak19 (- y 1) z x)
- (tak93 (- z 1) x y)))))
-(define (tak29 x y z)
- (cond ((not (< y x)) z)
- (else (tak30 (tak10 (- x 1) y z)
- (tak30 (- y 1) z x)
- (tak10 (- z 1) x y)))))
-(define (tak30 x y z)
- (cond ((not (< y x)) z)
- (else (tak31 (tak47 (- x 1) y z)
- (tak41 (- y 1) z x)
- (tak27 (- z 1) x y)))))
-(define (tak31 x y z)
- (cond ((not (< y x)) z)
- (else (tak32 (tak84 (- x 1) y z)
- (tak52 (- y 1) z x)
- (tak44 (- z 1) x y)))))
-(define (tak32 x y z)
- (cond ((not (< y x)) z)
- (else (tak33 (tak21 (- x 1) y z)
- (tak63 (- y 1) z x)
- (tak61 (- z 1) x y)))))
-(define (tak33 x y z)
- (cond ((not (< y x)) z)
- (else (tak34 (tak58 (- x 1) y z)
- (tak74 (- y 1) z x)
- (tak78 (- z 1) x y)))))
-(define (tak34 x y z)
- (cond ((not (< y x)) z)
- (else (tak35 (tak95 (- x 1) y z)
- (tak85 (- y 1) z x)
- (tak95 (- z 1) x y)))))
-(define (tak35 x y z)
- (cond ((not (< y x)) z)
- (else (tak36 (tak32 (- x 1) y z)
- (tak96 (- y 1) z x)
- (tak12 (- z 1) x y)))))
-(define (tak36 x y z)
- (cond ((not (< y x)) z)
- (else (tak37 (tak69 (- x 1) y z)
- (tak7 (- y 1) z x)
- (tak29 (- z 1) x y)))))
-(define (tak37 x y z)
- (cond ((not (< y x)) z)
- (else (tak38 (tak6 (- x 1) y z)
- (tak18 (- y 1) z x)
- (tak46 (- z 1) x y)))))
-(define (tak38 x y z)
- (cond ((not (< y x)) z)
- (else (tak39 (tak43 (- x 1) y z)
- (tak29 (- y 1) z x)
- (tak63 (- z 1) x y)))))
-(define (tak39 x y z)
- (cond ((not (< y x)) z)
- (else (tak40 (tak80 (- x 1) y z)
- (tak40 (- y 1) z x)
- (tak80 (- z 1) x y)))))
-(define (tak40 x y z)
- (cond ((not (< y x)) z)
- (else (tak41 (tak17 (- x 1) y z)
- (tak51 (- y 1) z x)
- (tak97 (- z 1) x y)))))
-(define (tak41 x y z)
- (cond ((not (< y x)) z)
- (else (tak42 (tak54 (- x 1) y z)
- (tak62 (- y 1) z x)
- (tak14 (- z 1) x y)))))
-(define (tak42 x y z)
- (cond ((not (< y x)) z)
- (else (tak43 (tak91 (- x 1) y z)
- (tak73 (- y 1) z x)
- (tak31 (- z 1) x y)))))
-(define (tak43 x y z)
- (cond ((not (< y x)) z)
- (else (tak44 (tak28 (- x 1) y z)
- (tak84 (- y 1) z x)
- (tak48 (- z 1) x y)))))
-(define (tak44 x y z)
- (cond ((not (< y x)) z)
- (else (tak45 (tak65 (- x 1) y z)
- (tak95 (- y 1) z x)
- (tak65 (- z 1) x y)))))
-(define (tak45 x y z)
- (cond ((not (< y x)) z)
- (else (tak46 (tak2 (- x 1) y z)
- (tak6 (- y 1) z x)
- (tak82 (- z 1) x y)))))
-(define (tak46 x y z)
- (cond ((not (< y x)) z)
- (else (tak47 (tak39 (- x 1) y z)
- (tak17 (- y 1) z x)
- (tak99 (- z 1) x y)))))
-(define (tak47 x y z)
- (cond ((not (< y x)) z)
- (else (tak48 (tak76 (- x 1) y z)
- (tak28 (- y 1) z x)
- (tak16 (- z 1) x y)))))
-(define (tak48 x y z)
- (cond ((not (< y x)) z)
- (else (tak49 (tak13 (- x 1) y z)
- (tak39 (- y 1) z x)
- (tak33 (- z 1) x y)))))
-(define (tak49 x y z)
- (cond ((not (< y x)) z)
- (else (tak50 (tak50 (- x 1) y z)
- (tak50 (- y 1) z x)
- (tak50 (- z 1) x y)))))
-(define (tak50 x y z)
- (cond ((not (< y x)) z)
- (else (tak51 (tak87 (- x 1) y z)
- (tak61 (- y 1) z x)
- (tak67 (- z 1) x y)))))
-(define (tak51 x y z)
- (cond ((not (< y x)) z)
- (else (tak52 (tak24 (- x 1) y z)
- (tak72 (- y 1) z x)
- (tak84 (- z 1) x y)))))
-(define (tak52 x y z)
- (cond ((not (< y x)) z)
- (else (tak53 (tak61 (- x 1) y z)
- (tak83 (- y 1) z x)
- (tak1 (- z 1) x y)))))
-(define (tak53 x y z)
- (cond ((not (< y x)) z)
- (else (tak54 (tak98 (- x 1) y z)
- (tak94 (- y 1) z x)
- (tak18 (- z 1) x y)))))
-(define (tak54 x y z)
- (cond ((not (< y x)) z)
- (else (tak55 (tak35 (- x 1) y z)
- (tak5 (- y 1) z x)
- (tak35 (- z 1) x y)))))
-(define (tak55 x y z)
- (cond ((not (< y x)) z)
- (else (tak56 (tak72 (- x 1) y z)
- (tak16 (- y 1) z x)
- (tak52 (- z 1) x y)))))
-(define (tak56 x y z)
- (cond ((not (< y x)) z)
- (else (tak57 (tak9 (- x 1) y z)
- (tak27 (- y 1) z x)
- (tak69 (- z 1) x y)))))
-(define (tak57 x y z)
- (cond ((not (< y x)) z)
- (else (tak58 (tak46 (- x 1) y z)
- (tak38 (- y 1) z x)
- (tak86 (- z 1) x y)))))
-(define (tak58 x y z)
- (cond ((not (< y x)) z)
- (else (tak59 (tak83 (- x 1) y z)
- (tak49 (- y 1) z x)
- (tak3 (- z 1) x y)))))
-(define (tak59 x y z)
- (cond ((not (< y x)) z)
- (else (tak60 (tak20 (- x 1) y z)
- (tak60 (- y 1) z x)
- (tak20 (- z 1) x y)))))
-(define (tak60 x y z)
- (cond ((not (< y x)) z)
- (else (tak61 (tak57 (- x 1) y z)
- (tak71 (- y 1) z x)
- (tak37 (- z 1) x y)))))
-(define (tak61 x y z)
- (cond ((not (< y x)) z)
- (else (tak62 (tak94 (- x 1) y z)
- (tak82 (- y 1) z x)
- (tak54 (- z 1) x y)))))
-(define (tak62 x y z)
- (cond ((not (< y x)) z)
- (else (tak63 (tak31 (- x 1) y z)
- (tak93 (- y 1) z x)
- (tak71 (- z 1) x y)))))
-(define (tak63 x y z)
- (cond ((not (< y x)) z)
- (else (tak64 (tak68 (- x 1) y z)
- (tak4 (- y 1) z x)
- (tak88 (- z 1) x y)))))
-(define (tak64 x y z)
- (cond ((not (< y x)) z)
- (else (tak65 (tak5 (- x 1) y z)
- (tak15 (- y 1) z x)
- (tak5 (- z 1) x y)))))
-(define (tak65 x y z)
- (cond ((not (< y x)) z)
- (else (tak66 (tak42 (- x 1) y z)
- (tak26 (- y 1) z x)
- (tak22 (- z 1) x y)))))
-(define (tak66 x y z)
- (cond ((not (< y x)) z)
- (else (tak67 (tak79 (- x 1) y z)
- (tak37 (- y 1) z x)
- (tak39 (- z 1) x y)))))
-(define (tak67 x y z)
- (cond ((not (< y x)) z)
- (else (tak68 (tak16 (- x 1) y z)
- (tak48 (- y 1) z x)
- (tak56 (- z 1) x y)))))
-(define (tak68 x y z)
- (cond ((not (< y x)) z)
- (else (tak69 (tak53 (- x 1) y z)
- (tak59 (- y 1) z x)
- (tak73 (- z 1) x y)))))
-(define (tak69 x y z)
- (cond ((not (< y x)) z)
- (else (tak70 (tak90 (- x 1) y z)
- (tak70 (- y 1) z x)
- (tak90 (- z 1) x y)))))
-(define (tak70 x y z)
- (cond ((not (< y x)) z)
- (else (tak71 (tak27 (- x 1) y z)
- (tak81 (- y 1) z x)
- (tak7 (- z 1) x y)))))
-(define (tak71 x y z)
- (cond ((not (< y x)) z)
- (else (tak72 (tak64 (- x 1) y z)
- (tak92 (- y 1) z x)
- (tak24 (- z 1) x y)))))
-(define (tak72 x y z)
- (cond ((not (< y x)) z)
- (else (tak73 (tak1 (- x 1) y z)
- (tak3 (- y 1) z x)
- (tak41 (- z 1) x y)))))
-(define (tak73 x y z)
- (cond ((not (< y x)) z)
- (else (tak74 (tak38 (- x 1) y z)
- (tak14 (- y 1) z x)
- (tak58 (- z 1) x y)))))
-(define (tak74 x y z)
- (cond ((not (< y x)) z)
- (else (tak75 (tak75 (- x 1) y z)
- (tak25 (- y 1) z x)
- (tak75 (- z 1) x y)))))
-(define (tak75 x y z)
- (cond ((not (< y x)) z)
- (else (tak76 (tak12 (- x 1) y z)
- (tak36 (- y 1) z x)
- (tak92 (- z 1) x y)))))
-(define (tak76 x y z)
- (cond ((not (< y x)) z)
- (else (tak77 (tak49 (- x 1) y z)
- (tak47 (- y 1) z x)
- (tak9 (- z 1) x y)))))
-(define (tak77 x y z)
- (cond ((not (< y x)) z)
- (else (tak78 (tak86 (- x 1) y z)
- (tak58 (- y 1) z x)
- (tak26 (- z 1) x y)))))
-(define (tak78 x y z)
- (cond ((not (< y x)) z)
- (else (tak79 (tak23 (- x 1) y z)
- (tak69 (- y 1) z x)
- (tak43 (- z 1) x y)))))
-(define (tak79 x y z)
- (cond ((not (< y x)) z)
- (else (tak80 (tak60 (- x 1) y z)
- (tak80 (- y 1) z x)
- (tak60 (- z 1) x y)))))
-(define (tak80 x y z)
- (cond ((not (< y x)) z)
- (else (tak81 (tak97 (- x 1) y z)
- (tak91 (- y 1) z x)
- (tak77 (- z 1) x y)))))
-(define (tak81 x y z)
- (cond ((not (< y x)) z)
- (else (tak82 (tak34 (- x 1) y z)
- (tak2 (- y 1) z x)
- (tak94 (- z 1) x y)))))
-(define (tak82 x y z)
- (cond ((not (< y x)) z)
- (else (tak83 (tak71 (- x 1) y z)
- (tak13 (- y 1) z x)
- (tak11 (- z 1) x y)))))
-(define (tak83 x y z)
- (cond ((not (< y x)) z)
- (else (tak84 (tak8 (- x 1) y z)
- (tak24 (- y 1) z x)
- (tak28 (- z 1) x y)))))
-(define (tak84 x y z)
- (cond ((not (< y x)) z)
- (else (tak85 (tak45 (- x 1) y z)
- (tak35 (- y 1) z x)
- (tak45 (- z 1) x y)))))
-(define (tak85 x y z)
- (cond ((not (< y x)) z)
- (else (tak86 (tak82 (- x 1) y z)
- (tak46 (- y 1) z x)
- (tak62 (- z 1) x y)))))
-(define (tak86 x y z)
- (cond ((not (< y x)) z)
- (else (tak87 (tak19 (- x 1) y z)
- (tak57 (- y 1) z x)
- (tak79 (- z 1) x y)))))
-(define (tak87 x y z)
- (cond ((not (< y x)) z)
- (else (tak88 (tak56 (- x 1) y z)
- (tak68 (- y 1) z x)
- (tak96 (- z 1) x y)))))
-(define (tak88 x y z)
- (cond ((not (< y x)) z)
- (else (tak89 (tak93 (- x 1) y z)
- (tak79 (- y 1) z x)
- (tak13 (- z 1) x y)))))
-(define (tak89 x y z)
- (cond ((not (< y x)) z)
- (else (tak90 (tak30 (- x 1) y z)
- (tak90 (- y 1) z x)
- (tak30 (- z 1) x y)))))
-(define (tak90 x y z)
- (cond ((not (< y x)) z)
- (else (tak91 (tak67 (- x 1) y z)
- (tak1 (- y 1) z x)
- (tak47 (- z 1) x y)))))
-(define (tak91 x y z)
- (cond ((not (< y x)) z)
- (else (tak92 (tak4 (- x 1) y z)
- (tak12 (- y 1) z x)
- (tak64 (- z 1) x y)))))
-(define (tak92 x y z)
- (cond ((not (< y x)) z)
- (else (tak93 (tak41 (- x 1) y z)
- (tak23 (- y 1) z x)
- (tak81 (- z 1) x y)))))
-(define (tak93 x y z)
- (cond ((not (< y x)) z)
- (else (tak94 (tak78 (- x 1) y z)
- (tak34 (- y 1) z x)
- (tak98 (- z 1) x y)))))
-(define (tak94 x y z)
- (cond ((not (< y x)) z)
- (else (tak95 (tak15 (- x 1) y z)
- (tak45 (- y 1) z x)
- (tak15 (- z 1) x y)))))
-(define (tak95 x y z)
- (cond ((not (< y x)) z)
- (else (tak96 (tak52 (- x 1) y z)
- (tak56 (- y 1) z x)
- (tak32 (- z 1) x y)))))
-(define (tak96 x y z)
- (cond ((not (< y x)) z)
- (else (tak97 (tak89 (- x 1) y z)
- (tak67 (- y 1) z x)
- (tak49 (- z 1) x y)))))
-(define (tak97 x y z)
- (cond ((not (< y x)) z)
- (else (tak98 (tak26 (- x 1) y z)
- (tak78 (- y 1) z x)
- (tak66 (- z 1) x y)))))
-(define (tak98 x y z)
- (cond ((not (< y x)) z)
- (else (tak99 (tak63 (- x 1) y z)
- (tak89 (- y 1) z x)
- (tak83 (- z 1) x y)))))
-(define (tak99 x y z)
- (cond ((not (< y x)) z)
- (else (tak0 (tak0 (- x 1) y z)
- (tak0 (- y 1) z x)
- (tak0 (- z 1) x y)))))
-
-(time (do ((i 100 (- i 1))) ((zero? i)) (tak0 18 12 6)))
-
diff --git a/benchmarks/traverse.scm b/benchmarks/traverse.scm
deleted file mode 100644
index fe9d5099..00000000
--- a/benchmarks/traverse.scm
+++ /dev/null
@@ -1,145 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: traverse.sc
-;;; Description: TRAVERSE benchmark
-;;; Author: Richard Gabriel
-;;; Created: 12-Apr-85
-;;; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
-;;; 9-Aug-87 (Will Clinger)
-;;; 20-Nov-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
-
-(define (make-node)
- (let ((node (make-vector 11 '())))
- (vector-set! node 0 'node)
- (vector-set! node 3 (snb))
- (vector-set! node 4 #f) ;Qobi
- (vector-set! node 5 #f) ;Qobi
- (vector-set! node 6 #f) ;Qobi
- (vector-set! node 7 #f) ;Qobi
- (vector-set! node 8 #f) ;Qobi
- (vector-set! node 9 #f) ;Qobi
- (vector-set! node 10 #f) ;Qobi
- node))
-
- (define (node-parents node) (vector-ref node 1))
- (define (node-sons node) (vector-ref node 2))
- (define (node-sn node) (vector-ref node 3))
- (define (node-entry1 node) (vector-ref node 4))
- (define (node-entry2 node) (vector-ref node 5))
- (define (node-entry3 node) (vector-ref node 6))
- (define (node-entry4 node) (vector-ref node 7))
- (define (node-entry5 node) (vector-ref node 8))
- (define (node-entry6 node) (vector-ref node 9))
- (define (node-mark node) (vector-ref node 10))
-
- (define (node-parents-set! node v) (vector-set! node 1 v))
- (define (node-sons-set! node v) (vector-set! node 2 v))
- (define (node-sn-set! node v) (vector-set! node 3 v))
- (define (node-entry1-set! node v) (vector-set! node 4 v))
- (define (node-entry2-set! node v) (vector-set! node 5 v))
- (define (node-entry3-set! node v) (vector-set! node 6 v))
- (define (node-entry4-set! node v) (vector-set! node 7 v))
- (define (node-entry5-set! node v) (vector-set! node 8 v))
- (define (node-entry6-set! node v) (vector-set! node 9 v))
- (define (node-mark-set! node v) (vector-set! node 10 v))
-
- (define *sn* 0)
- (define *rand* 21)
- (define *count* 0)
- (define *marker* #f)
- (define *root* '())
-
- (define (snb)
- (set! *sn* (+ 1 *sn*))
- *sn*)
-
- (define (seed)
- (set! *rand* 21)
- *rand*)
-
- (define (traverse-random)
- (set! *rand* (remainder (* *rand* 17) 251))
- *rand*)
-
- (define (traverse-remove n q)
- (cond ((eq? (cdr (car q)) (car q)) (let ((x (caar q))) (set-car! q '()) x))
- ((zero? n)
- (let ((x (caar q)))
- (do ((p (car q) (cdr p)))
- ((eq? (cdr p) (car q))
- (set-cdr! p (cdr (car q)))
- (set-car! q p)))
- x))
- (else (do ((n n (- n 1)) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p)))
- ((zero? n) (let ((x (car q))) (set-cdr! q p) x))))))
-
- (define (traverse-select n q)
- (do ((n n (- n 1)) (q (car q) (cdr q))) ((zero? n) (car q))))
-
- (define (add a q)
- (cond ((null? q) `(,(let ((x `(,a))) (set-cdr! x x) x)))
- ((null? (car q))
- (let ((x `(,a)))
- (set-cdr! x x)
- (set-car! q x)
- q))
- ;; the CL version had a useless set-car! in the next line (wc)
- (else (set-cdr! (car q) `(,a . ,(cdr (car q)))) q)))
-
- (define (create-structure n)
- (let ((a `(,(make-node))))
- (do ((m (- n 1) (- m 1)) (p a))
- ((zero? m)
- (set! a `(,(begin (set-cdr! p a) p)))
- (do ((unused a) (used (add (traverse-remove 0 a) '())) (x 0) (y 0))
- ((null? (car unused)) (find-root (traverse-select 0 used) n))
- (set! x (traverse-remove (remainder (traverse-random) n) unused))
- (set! y (traverse-select (remainder (traverse-random) n) used))
- (add x used)
- (node-sons-set! y `(,x . ,(node-sons y)))
- (node-parents-set! x `(,y . ,(node-parents x))) ))
- (set! a (cons (make-node) a)))))
-
- (define (find-root node n)
- (do ((n n (- n 1))) ((or (zero? n) (null? (node-parents node))) node)
- (set! node (car (node-parents node)))))
-
- (define (travers node mark)
- (cond ((eq? (node-mark node) mark) #f)
- (else (node-mark-set! node mark)
- (set! *count* (+ 1 *count*))
- (node-entry1-set! node (not (node-entry1 node)))
- (node-entry2-set! node (not (node-entry2 node)))
- (node-entry3-set! node (not (node-entry3 node)))
- (node-entry4-set! node (not (node-entry4 node)))
- (node-entry5-set! node (not (node-entry5 node)))
- (node-entry6-set! node (not (node-entry6 node)))
- (do ((sons (node-sons node) (cdr sons))) ((null? sons) #f)
- (travers (car sons) mark)))))
-
- (define (traverse root)
- (let ((*count* 0))
- (travers root (begin (set! *marker* (not *marker*)) *marker*))
- *count*))
-
- (define (init-traverse) ; Changed from defmacro to defun \bs
- (set! *root* (create-structure 100))
- #f)
-
- (define (run-traverse) ; Changed from defmacro to defun \bs
- (do ((i 50 (- i 1))) ((zero? i))
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)))
-
-(init-traverse)
-
-(time (run-traverse))
diff --git a/benchmarks/travinit.scm b/benchmarks/travinit.scm
deleted file mode 100644
index 7a853bf1..00000000
--- a/benchmarks/travinit.scm
+++ /dev/null
@@ -1,143 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; File: traverse-init.sc
-;;; Description: TRAVERSE benchmark
-;;; Author: Richard Gabriel
-;;; Created: 12-Apr-85
-;;; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
-;;; 9-Aug-87 (Will Clinger)
-;;; 20-Nov-94 (Qobi)
-;;; 31-Mar-98 (Qobi)
-;;; 26-Mar-00 (flw)
-;;; Language: Scheme
-;;; Status: Public Domain
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
-
-(define (make-node)
- (let ((node (make-vector 11 '())))
- (vector-set! node 0 'node)
- (vector-set! node 3 (snb))
- (vector-set! node 4 #f) ;Qobi
- (vector-set! node 5 #f) ;Qobi
- (vector-set! node 6 #f) ;Qobi
- (vector-set! node 7 #f) ;Qobi
- (vector-set! node 8 #f) ;Qobi
- (vector-set! node 9 #f) ;Qobi
- (vector-set! node 10 #f) ;Qobi
- node))
-
- (define (node-parents node) (vector-ref node 1))
- (define (node-sons node) (vector-ref node 2))
- (define (node-sn node) (vector-ref node 3))
- (define (node-entry1 node) (vector-ref node 4))
- (define (node-entry2 node) (vector-ref node 5))
- (define (node-entry3 node) (vector-ref node 6))
- (define (node-entry4 node) (vector-ref node 7))
- (define (node-entry5 node) (vector-ref node 8))
- (define (node-entry6 node) (vector-ref node 9))
- (define (node-mark node) (vector-ref node 10))
-
- (define (node-parents-set! node v) (vector-set! node 1 v))
- (define (node-sons-set! node v) (vector-set! node 2 v))
- (define (node-sn-set! node v) (vector-set! node 3 v))
- (define (node-entry1-set! node v) (vector-set! node 4 v))
- (define (node-entry2-set! node v) (vector-set! node 5 v))
- (define (node-entry3-set! node v) (vector-set! node 6 v))
- (define (node-entry4-set! node v) (vector-set! node 7 v))
- (define (node-entry5-set! node v) (vector-set! node 8 v))
- (define (node-entry6-set! node v) (vector-set! node 9 v))
- (define (node-mark-set! node v) (vector-set! node 10 v))
-
- (define *sn* 0)
- (define *rand* 21)
- (define *count* 0)
- (define *marker* #f)
- (define *root* '())
-
- (define (snb)
- (set! *sn* (+ 1 *sn*))
- *sn*)
-
- (define (seed)
- (set! *rand* 21)
- *rand*)
-
- (define (traverse-random)
- (set! *rand* (remainder (* *rand* 17) 251))
- *rand*)
-
- (define (traverse-remove n q)
- (cond ((eq? (cdr (car q)) (car q)) (let ((x (caar q))) (set-car! q '()) x))
- ((zero? n)
- (let ((x (caar q)))
- (do ((p (car q) (cdr p)))
- ((eq? (cdr p) (car q))
- (set-cdr! p (cdr (car q)))
- (set-car! q p)))
- x))
- (else (do ((n n (- n 1)) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p)))
- ((zero? n) (let ((x (car q))) (set-cdr! q p) x))))))
-
- (define (traverse-select n q)
- (do ((n n (- n 1)) (q (car q) (cdr q))) ((zero? n) (car q))))
-
- (define (add a q)
- (cond ((null? q) `(,(let ((x `(,a))) (set-cdr! x x) x)))
- ((null? (car q))
- (let ((x `(,a)))
- (set-cdr! x x)
- (set-car! q x)
- q))
- ;; the CL version had a useless set-car! in the next line (wc)
- (else (set-cdr! (car q) `(,a . ,(cdr (car q)))) q)))
-
- (define (create-structure n)
- (let ((a `(,(make-node))))
- (do ((m (- n 1) (- m 1)) (p a))
- ((zero? m)
- (set! a `(,(begin (set-cdr! p a) p)))
- (do ((unused a) (used (add (traverse-remove 0 a) '())) (x 0) (y 0))
- ((null? (car unused)) (find-root (traverse-select 0 used) n))
- (set! x (traverse-remove (remainder (traverse-random) n) unused))
- (set! y (traverse-select (remainder (traverse-random) n) used))
- (add x used)
- (node-sons-set! y `(,x . ,(node-sons y)))
- (node-parents-set! x `(,y . ,(node-parents x))) ))
- (set! a (cons (make-node) a)))))
-
- (define (find-root node n)
- (do ((n n (- n 1))) ((or (zero? n) (null? (node-parents node))) node)
- (set! node (car (node-parents node)))))
-
- (define (travers node mark)
- (cond ((eq? (node-mark node) mark) #f)
- (else (node-mark-set! node mark)
- (set! *count* (+ 1 *count*))
- (node-entry1-set! node (not (node-entry1 node)))
- (node-entry2-set! node (not (node-entry2 node)))
- (node-entry3-set! node (not (node-entry3 node)))
- (node-entry4-set! node (not (node-entry4 node)))
- (node-entry5-set! node (not (node-entry5 node)))
- (node-entry6-set! node (not (node-entry6 node)))
- (do ((sons (node-sons node) (cdr sons))) ((null? sons) #f)
- (travers (car sons) mark)))))
-
- (define (traverse root)
- (let ((*count* 0))
- (travers root (begin (set! *marker* (not *marker*)) *marker*))
- *count*))
-
- (define (init-traverse) ; Changed from defmacro to defun \bs
- (set! *root* (create-structure 100))
- #f)
-
- (define (run-traverse) ; Changed from defmacro to defun \bs
- (do ((i 50 (- i 1))) ((zero? i))
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)
- (traverse *root*)))
-
-(time (init-traverse))
diff --git a/benchmarks/triangl.scm b/benchmarks/triangl.scm
deleted file mode 100644
index 7935c2d3..00000000
--- a/benchmarks/triangl.scm
+++ /dev/null
@@ -1,57 +0,0 @@
-;;; TRIANGL -- Board game benchmark.
-
-(define *board*
- (list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1)))
-
-(define *sequence*
- (list->vector '(0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
-
-(define *a*
- (list->vector '(1 2 4 3 5 6 1 3 6 2 5 4 11 12
- 13 7 8 4 4 7 11 8 12 13 6 10
- 15 9 14 13 13 14 15 9 10
- 6 6)))
-
-(define *b*
- (list->vector '(2 4 7 5 8 9 3 6 10 5 9 8
- 12 13 14 8 9 5 2 4 7 5 8
- 9 3 6 10 5 9 8 12 13 14
- 8 9 5 5)))
-
-(define *c*
- (list->vector '(4 7 11 8 12 13 6 10 15 9 14 13
- 13 14 15 9 10 6 1 2 4 3 5 6 1
- 3 6 2 5 4 11 12 13 7 8 4 4)))
-
-(define *answer* '())
-
-(define (attempt i depth)
- (cond ((= depth 14)
- (set! *answer*
- (cons (cdr (vector->list *sequence*)) *answer*))
- #t)
- ((and (= 1 (vector-ref *board* (vector-ref *a* i)))
- (= 1 (vector-ref *board* (vector-ref *b* i)))
- (= 0 (vector-ref *board* (vector-ref *c* i))))
- (vector-set! *board* (vector-ref *a* i) 0)
- (vector-set! *board* (vector-ref *b* i) 0)
- (vector-set! *board* (vector-ref *c* i) 1)
- (vector-set! *sequence* depth i)
- (do ((j 0 (+ j 1))
- (depth (+ depth 1)))
- ((or (= j 36) (attempt j depth)) #f))
- (vector-set! *board* (vector-ref *a* i) 1)
- (vector-set! *board* (vector-ref *b* i) 1)
- (vector-set! *board* (vector-ref *c* i) 0) #f)
- (else #f)))
-
-(define (test)
- (set! *answer* '())
- (attempt 22 1)
- (car *answer*))
-
-(let ((result (time (test))))
- (if (not (equal? result
- '(22 34 31 15 7 1 20 17 25 6 5 13 32)))
- (error "wrong result" result) ) )
-
diff --git a/distribution/manifest b/distribution/manifest
index 97505e2e..ca3d97c4 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -8,48 +8,6 @@ README
config-arch.sh
banner.scm
batch-driver.scm
-benchmarks/0.scm
-benchmarks/cscbench.scm
-benchmarks/nbody.scm
-benchmarks/binarytrees.scm
-benchmarks/boyer.scm
-benchmarks/browse.scm
-benchmarks/conform.scm
-benchmarks/cpstak.scm
-benchmarks/ctak.scm
-benchmarks/dderiv.scm
-benchmarks/deriv.scm
-benchmarks/destructive.scm
-benchmarks/div-iter.scm
-benchmarks/div-rec.scm
-benchmarks/dynamic.scm
-benchmarks/earley.scm
-benchmarks/fft.scm
-benchmarks/fib.scm
-benchmarks/fibc.scm
-benchmarks/fprint.scm
-benchmarks/fread.scm
-benchmarks/hanoi.scm
-benchmarks/lattice.scm
-benchmarks/maze.scm
-benchmarks/nqueens.scm
-benchmarks/others/Makefile
-benchmarks/others/except.scm
-benchmarks/others/except2.scm
-benchmarks/others/exception.cpp
-benchmarks/others/results.txt
-benchmarks/others/setlongjmp.c
-benchmarks/puzzle.scm
-benchmarks/scheme.scm
-benchmarks/tak.scm
-benchmarks/takl.scm
-benchmarks/takr.scm
-benchmarks/traverse.scm
-benchmarks/travinit.scm
-benchmarks/triangl.scm
-benchmarks/regex/benchmark.pl
-benchmarks/regex/re-benchmarks.txt
-benchmarks/regex/benchmark.scm
batch-driver.c
c-backend.c
c-platform.c
@@ -107,8 +65,6 @@ buildversion
c-backend.scm
c-platform.scm
chicken-ffi-syntax.scm
-chicken-primitive-object-inlines.scm
-chicken-thread-object-inlines.scm
chicken-profile.1
chicken-profile.scm
chicken.1
@@ -130,8 +86,6 @@ files.scm
chicken-bug.1
chicken-bug.scm
chicken-bug.c
-hen.el
-scheme-complete.el
html/Accessing external objects.html
html/Acknowledgements.html
html/Basic mode of operation.html
@@ -245,6 +199,7 @@ tests/re-tests.txt
tests/lolevel-tests.scm
tests/feeley-dynwind.scm
tests/compiler-syntax-tests.scm
+tests/silex.scm
tweaks.scm
utils.scm
apply-hack.x86.S
diff --git a/tests/fft.scm b/tests/fft.scm
new file mode 100644
index 00000000..787fcebb
--- /dev/null
+++ b/tests/fft.scm
@@ -0,0 +1,2071 @@
+(declare (standard-bindings)
+ (extended-bindings)
+ (block)
+ (not safe)
+ )
+
+;;; All the following redefinitions are *ignored* by the Gambit compiler
+;;; because of the declarations above.
+
+(cond-expand
+ (chicken
+ (begin
+ (use srfi-4)
+ (define-syntax defalias
+ (syntax-rules ()
+ ((_ one two)
+ (define-syntax one
+ (syntax-rules ()
+ ((_ . args) (two . args)))))))
+ (defalias fixnum->flonum exact->inexact)
+ (defalias fxodd? odd?)
+ (defalias fxeven? even?)
+ (defalias fxarithmetic-shift-right fxshr)
+ (defalias fxarithmetic-shift-left fxshl)
+ (defalias fl* fp*)
+ (defalias fl/ fp/)
+ (defalias fl+ fp+)
+ (defalias fl- fp-)
+ (defalias flsqrt sqrt)))
+ (else))
+
+(cond-expand
+ ((and chicken (not unboxed))
+ (begin
+ (defalias make-f64vector make-vector)
+ (defalias f64vector vector)
+ (defalias f64vector-set! vector-set!)
+ (defalias f64vector-ref vector-ref)
+ (defalias list->f64vector list->vector)
+ (defalias f64vector-length vector-length)) )
+ (else) )
+
+;;; end of *ignored* definitions
+
+(define lut-table-size 512)
+(define lut-table-size^2 262144)
+(define lut-table-size^3 134217728)
+(define log-lut-table-size 9)
+
+(define low-lut
+ (list->f64vector '(1. 0.
+ .7071067811865476 .7071067811865476
+ .9238795325112867 .3826834323650898
+ .3826834323650898 .9238795325112867
+ .9807852804032304 .19509032201612828
+ .5555702330196022 .8314696123025452
+ .8314696123025452 .5555702330196022
+ .19509032201612828 .9807852804032304
+ .9951847266721969 .0980171403295606
+ .6343932841636455 .773010453362737
+ .881921264348355 .47139673682599764
+ .2902846772544624 .9569403357322088
+ .9569403357322088 .2902846772544624
+ .47139673682599764 .881921264348355
+ .773010453362737 .6343932841636455
+ .0980171403295606 .9951847266721969
+ .9987954562051724 .049067674327418015
+ .6715589548470184 .7409511253549591
+ .9039892931234433 .4275550934302821
+ .33688985339222005 .9415440651830208
+ .970031253194544 .2429801799032639
+ .5141027441932218 .8577286100002721
+ .8032075314806449 .5956993044924334
+ .14673047445536175 .989176509964781
+ .989176509964781 .14673047445536175
+ .5956993044924334 .8032075314806449
+ .8577286100002721 .5141027441932218
+ .2429801799032639 .970031253194544
+ .9415440651830208 .33688985339222005
+ .4275550934302821 .9039892931234433
+ .7409511253549591 .6715589548470184
+ .049067674327418015 .9987954562051724
+ .9996988186962042 .024541228522912288
+ .6895405447370669 .7242470829514669
+ .9142097557035307 .40524131400498986
+ .35989503653498817 .9329927988347388
+ .9757021300385286 .2191012401568698
+ .5349976198870973 .8448535652497071
+ .8175848131515837 .5758081914178453
+ .17096188876030122 .9852776423889412
+ .99247953459871 .1224106751992162
+ .6152315905806268 .7883464276266062
+ .8700869911087115 .49289819222978404
+ .26671275747489837 .9637760657954398
+ .9495281805930367 .31368174039889146
+ .4496113296546066 .8932243011955153
+ .7572088465064846 .6531728429537768
+ .07356456359966743 .9972904566786902
+ .9972904566786902 .07356456359966743
+ .6531728429537768 .7572088465064846
+ .8932243011955153 .4496113296546066
+ .31368174039889146 .9495281805930367
+ .9637760657954398 .26671275747489837
+ .49289819222978404 .8700869911087115
+ .7883464276266062 .6152315905806268
+ .1224106751992162 .99247953459871
+ .9852776423889412 .17096188876030122
+ .5758081914178453 .8175848131515837
+ .8448535652497071 .5349976198870973
+ .2191012401568698 .9757021300385286
+ .9329927988347388 .35989503653498817
+ .40524131400498986 .9142097557035307
+ .7242470829514669 .6895405447370669
+ .024541228522912288 .9996988186962042
+ .9999247018391445 .012271538285719925
+ .6983762494089728 .7157308252838187
+ .9191138516900578 .3939920400610481
+ .37131719395183754 .9285060804732156
+ .9783173707196277 .20711137619221856
+ .5453249884220465 .8382247055548381
+ .8245893027850253 .5657318107836132
+ .18303988795514095 .9831054874312163
+ .9939069700023561 .11022220729388306
+ .6248594881423863 .7807372285720945
+ .8760700941954066 .4821837720791228
+ .2785196893850531 .9604305194155658
+ .9533060403541939 .3020059493192281
+ .46053871095824 .8876396204028539
+ .765167265622459 .6438315428897915
+ .0857973123444399 .996312612182778
+ .9981181129001492 .06132073630220858
+ .6624157775901718 .7491363945234594
+ .8986744656939538 .43861623853852766
+ .3253102921622629 .9456073253805213
+ .9669764710448521 .25486565960451457
+ .5035383837257176 .8639728561215867
+ .7958369046088836 .6055110414043255
+ .1345807085071262 .99090263542778
+ .9873014181578584 .15885814333386145
+ .5857978574564389 .8104571982525948
+ .8513551931052652 .524589682678469
+ .2310581082806711 .9729399522055602
+ .937339011912575 .34841868024943456
+ .4164295600976372 .9091679830905224
+ .7326542716724128 .680600997795453
+ .03680722294135883 .9993223845883495
+ .9993223845883495 .03680722294135883
+ .680600997795453 .7326542716724128
+ .9091679830905224 .4164295600976372
+ .34841868024943456 .937339011912575
+ .9729399522055602 .2310581082806711
+ .524589682678469 .8513551931052652
+ .8104571982525948 .5857978574564389
+ .15885814333386145 .9873014181578584
+ .99090263542778 .1345807085071262
+ .6055110414043255 .7958369046088836
+ .8639728561215867 .5035383837257176
+ .25486565960451457 .9669764710448521
+ .9456073253805213 .3253102921622629
+ .43861623853852766 .8986744656939538
+ .7491363945234594 .6624157775901718
+ .06132073630220858 .9981181129001492
+ .996312612182778 .0857973123444399
+ .6438315428897915 .765167265622459
+ .8876396204028539 .46053871095824
+ .3020059493192281 .9533060403541939
+ .9604305194155658 .2785196893850531
+ .4821837720791228 .8760700941954066
+ .7807372285720945 .6248594881423863
+ .11022220729388306 .9939069700023561
+ .9831054874312163 .18303988795514095
+ .5657318107836132 .8245893027850253
+ .8382247055548381 .5453249884220465
+ .20711137619221856 .9783173707196277
+ .9285060804732156 .37131719395183754
+ .3939920400610481 .9191138516900578
+ .7157308252838187 .6983762494089728
+ .012271538285719925 .9999247018391445
+ .9999811752826011 .006135884649154475
+ .7027547444572253 .7114321957452164
+ .9215140393420419 .3883450466988263
+ .37700741021641826 .9262102421383114
+ .9795697656854405 .2011046348420919
+ .5504579729366048 .83486287498638
+ .8280450452577558 .560661576197336
+ .18906866414980622 .9819638691095552
+ .9945645707342554 .10412163387205457
+ .629638238914927 .7768884656732324
+ .8790122264286335 .47679923006332214
+ .2844075372112718 .9587034748958716
+ .9551411683057707 .29615088824362384
+ .4659764957679662 .8847970984309378
+ .7691033376455796 .6391244448637757
+ .09190895649713272 .9957674144676598
+ .9984755805732948 .05519524434968994
+ .6669999223036375 .745057785441466
+ .901348847046022 .43309381885315196
+ .33110630575987643 .9435934581619604
+ .9685220942744173 .24892760574572018
+ .508830142543107 .8608669386377673
+ .799537269107905 .600616479383869
+ .14065823933284924 .9900582102622971
+ .9882575677307495 .15279718525844344
+ .5907597018588743 .8068475535437992
+ .8545579883654005 .5193559901655896
+ .2370236059943672 .9715038909862518
+ .9394592236021899 .3426607173119944
+ .4220002707997997 .9065957045149153
+ .7368165688773699 .6760927035753159
+ .04293825693494082 .9990777277526454
+ .9995294175010931 .030674803176636626
+ .6850836677727004 .7284643904482252
+ .9117060320054299 .41084317105790397
+ .3541635254204904 .9351835099389476
+ .9743393827855759 .22508391135979283
+ .5298036246862947 .8481203448032972
+ .8140363297059484 .5808139580957645
+ .16491312048996992 .9863080972445987
+ .9917097536690995 .12849811079379317
+ .6103828062763095 .7921065773002124
+ .8670462455156926 .49822766697278187
+ .2607941179152755 .9653944416976894
+ .9475855910177411 .3195020308160157
+ .44412214457042926 .8959662497561851
+ .7531867990436125 .6578066932970786
+ .06744391956366406 .9977230666441916
+ .9968202992911657 .07968243797143013
+ .6485144010221124 .7612023854842618
+ .8904487232447579 .45508358712634384
+ .30784964004153487 .9514350209690083
+ .9621214042690416 .272621355449949
+ .48755016014843594 .8730949784182901
+ .7845565971555752 .6200572117632892
+ .11631863091190477 .9932119492347945
+ .984210092386929 .17700422041214875
+ .5707807458869673 .8211025149911046
+ .8415549774368984 .5401714727298929
+ .21311031991609136 .9770281426577544
+ .9307669610789837 .36561299780477385
+ .39962419984564684 .9166790599210427
+ .7200025079613817 .693971460889654
+ .01840672990580482 .9998305817958234
+ .9998305817958234 .01840672990580482
+ .693971460889654 .7200025079613817
+ .9166790599210427 .39962419984564684
+ .36561299780477385 .9307669610789837
+ .9770281426577544 .21311031991609136
+ .5401714727298929 .8415549774368984
+ .8211025149911046 .5707807458869673
+ .17700422041214875 .984210092386929
+ .9932119492347945 .11631863091190477
+ .6200572117632892 .7845565971555752
+ .8730949784182901 .48755016014843594
+ .272621355449949 .9621214042690416
+ .9514350209690083 .30784964004153487
+ .45508358712634384 .8904487232447579
+ .7612023854842618 .6485144010221124
+ .07968243797143013 .9968202992911657
+ .9977230666441916 .06744391956366406
+ .6578066932970786 .7531867990436125
+ .8959662497561851 .44412214457042926
+ .3195020308160157 .9475855910177411
+ .9653944416976894 .2607941179152755
+ .49822766697278187 .8670462455156926
+ .7921065773002124 .6103828062763095
+ .12849811079379317 .9917097536690995
+ .9863080972445987 .16491312048996992
+ .5808139580957645 .8140363297059484
+ .8481203448032972 .5298036246862947
+ .22508391135979283 .9743393827855759
+ .9351835099389476 .3541635254204904
+ .41084317105790397 .9117060320054299
+ .7284643904482252 .6850836677727004
+ .030674803176636626 .9995294175010931
+ .9990777277526454 .04293825693494082
+ .6760927035753159 .7368165688773699
+ .9065957045149153 .4220002707997997
+ .3426607173119944 .9394592236021899
+ .9715038909862518 .2370236059943672
+ .5193559901655896 .8545579883654005
+ .8068475535437992 .5907597018588743
+ .15279718525844344 .9882575677307495
+ .9900582102622971 .14065823933284924
+ .600616479383869 .799537269107905
+ .8608669386377673 .508830142543107
+ .24892760574572018 .9685220942744173
+ .9435934581619604 .33110630575987643
+ .43309381885315196 .901348847046022
+ .745057785441466 .6669999223036375
+ .05519524434968994 .9984755805732948
+ .9957674144676598 .09190895649713272
+ .6391244448637757 .7691033376455796
+ .8847970984309378 .4659764957679662
+ .29615088824362384 .9551411683057707
+ .9587034748958716 .2844075372112718
+ .47679923006332214 .8790122264286335
+ .7768884656732324 .629638238914927
+ .10412163387205457 .9945645707342554
+ .9819638691095552 .18906866414980622
+ .560661576197336 .8280450452577558
+ .83486287498638 .5504579729366048
+ .2011046348420919 .9795697656854405
+ .9262102421383114 .37700741021641826
+ .3883450466988263 .9215140393420419
+ .7114321957452164 .7027547444572253
+ .006135884649154475 .9999811752826011
+ .9999952938095762 .003067956762965976
+ .7049340803759049 .7092728264388657
+ .9227011283338785 .38551605384391885
+ .37984720892405116 .9250492407826776
+ .9801821359681174 .1980984107179536
+ .5530167055800276 .8331701647019132
+ .829761233794523 .5581185312205561
+ .19208039704989244 .9813791933137546
+ .9948793307948056 .10106986275482782
+ .6320187359398091 .7749531065948739
+ .8804708890521608 .47410021465055
+ .2873474595447295 .9578264130275329
+ .9560452513499964 .29321916269425863
+ .46868882203582796 .8833633386657316
+ .7710605242618138 .6367618612362842
+ .094963495329639 .9954807554919269
+ .9986402181802653 .052131704680283324
+ .6692825883466361 .7430079521351217
+ .9026733182372588 .4303264813400826
+ .3339996514420094 .9425731976014469
+ .9692812353565485 .24595505033579462
+ .5114688504379704 .8593018183570084
+ .8013761717231402 .5981607069963423
+ .14369503315029444 .9896220174632009
+ .9887216919603238 .1497645346773215
+ .5932322950397998 .8050313311429635
+ .8561473283751945 .5167317990176499
+ .2400030224487415 .9707721407289504
+ .9405060705932683 .33977688440682685
+ .4247796812091088 .9052967593181188
+ .7388873244606151 .673829000378756
+ .04600318213091463 .9989412931868569
+ .9996188224951786 .027608145778965743
+ .6873153408917592 .726359155084346
+ .9129621904283982 .4080441628649787
+ .35703096123343003 .9340925504042589
+ .9750253450669941 .22209362097320354
+ .532403127877198 .8464909387740521
+ .8158144108067338 .5783137964116556
+ .16793829497473117 .9857975091675675
+ .9920993131421918 .12545498341154623
+ .6128100824294097 .79023022143731
+ .8685707059713409 .49556526182577254
+ .2637546789748314 .9645897932898128
+ .9485613499157303 .31659337555616585
+ .4468688401623742 .8945994856313827
+ .7552013768965365 .6554928529996153
+ .07050457338961387 .9975114561403035
+ .997060070339483 .07662386139203149
+ .6508466849963809 .7592091889783881
+ .8918407093923427 .4523495872337709
+ .3107671527496115 .9504860739494817
+ .9629532668736839 .2696683255729151
+ .49022648328829116 .8715950866559511
+ .7864552135990858 .617647307937804
+ .11936521481099137 .9928504144598651
+ .9847485018019042 .17398387338746382
+ .5732971666980422 .819347520076797
+ .8432082396418454 .5375870762956455
+ .21610679707621952 .9763697313300211
+ .9318842655816681 .3627557243673972
+ .40243465085941843 .9154487160882678
+ .7221281939292153 .6917592583641577
+ .021474080275469508 .9997694053512153
+ .9998823474542126 .015339206284988102
+ .696177131491463 .7178700450557317
+ .9179007756213905 .3968099874167103
+ .3684668299533723 .9296408958431812
+ .9776773578245099 .2101118368804696
+ .5427507848645159 .8398937941959995
+ .8228497813758263 .5682589526701316
+ .18002290140569951 .9836624192117303
+ .9935641355205953 .11327095217756435
+ .62246127937415 .7826505961665757
+ .8745866522781761 .4848692480007911
+ .27557181931095814 .9612804858113206
+ .9523750127197659 .30492922973540243
+ .45781330359887723 .8890483558546646
+ .7631884172633813 .6461760129833164
+ .08274026454937569 .9965711457905548
+ .997925286198596 .06438263092985747
+ .6601143420674205 .7511651319096864
+ .8973245807054183 .44137126873171667
+ .32240767880106985 .9466009130832835
+ .9661900034454125 .257831102162159
+ .5008853826112408 .8655136240905691
+ .7939754775543372 .6079497849677736
+ .13154002870288312 .9913108598461154
+ .9868094018141855 .16188639378011183
+ .5833086529376983 .8122505865852039
+ .8497417680008524 .5271991347819014
+ .22807208317088573 .973644249650812
+ .9362656671702783 .35129275608556715
+ .41363831223843456 .9104412922580672
+ .7305627692278276 .6828455463852481
+ .03374117185137759 .9994306045554617
+ .9992047586183639 .03987292758773981
+ .6783500431298615 .7347388780959635
+ .9078861164876663 .41921688836322396
+ .34554132496398904 .9384035340631081
+ .9722264970789363 .23404195858354343
+ .5219752929371544 .8529606049303636
+ .808656181588175 .5882815482226453
+ .15582839765426523 .9877841416445722
+ .9904850842564571 .13762012158648604
+ .6030665985403482 .7976908409433912
+ .8624239561110405 .5061866453451553
+ .25189781815421697 .9677538370934755
+ .9446048372614803 .32820984357909255
+ .4358570799222555 .9000158920161603
+ .7471006059801801 .6647109782033449
+ .05825826450043576 .9983015449338929
+ .996044700901252 .0888535525825246
+ .6414810128085832 .7671389119358204
+ .8862225301488806 .4632597835518602
+ .2990798263080405 .9542280951091057
+ .9595715130819845 .281464937925758
+ .479493757660153 .8775452902072612
+ .778816512381476 .6272518154951441
+ .10717242495680884 .9942404494531879
+ .9825393022874412 .18605515166344666
+ .5631993440138341 .8263210628456635
+ .836547727223512 .5478940591731002
+ .20410896609281687 .9789481753190622
+ .9273625256504011 .374164062971458
+ .39117038430225387 .9203182767091106
+ .7135848687807936 .7005687939432483
+ .00920375478205982 .9999576445519639
+ .9999576445519639 .00920375478205982
+ .7005687939432483 .7135848687807936
+ .9203182767091106 .39117038430225387
+ .374164062971458 .9273625256504011
+ .9789481753190622 .20410896609281687
+ .5478940591731002 .836547727223512
+ .8263210628456635 .5631993440138341
+ .18605515166344666 .9825393022874412
+ .9942404494531879 .10717242495680884
+ .6272518154951441 .778816512381476
+ .8775452902072612 .479493757660153
+ .281464937925758 .9595715130819845
+ .9542280951091057 .2990798263080405
+ .4632597835518602 .8862225301488806
+ .7671389119358204 .6414810128085832
+ .0888535525825246 .996044700901252
+ .9983015449338929 .05825826450043576
+ .6647109782033449 .7471006059801801
+ .9000158920161603 .4358570799222555
+ .32820984357909255 .9446048372614803
+ .9677538370934755 .25189781815421697
+ .5061866453451553 .8624239561110405
+ .7976908409433912 .6030665985403482
+ .13762012158648604 .9904850842564571
+ .9877841416445722 .15582839765426523
+ .5882815482226453 .808656181588175
+ .8529606049303636 .5219752929371544
+ .23404195858354343 .9722264970789363
+ .9384035340631081 .34554132496398904
+ .41921688836322396 .9078861164876663
+ .7347388780959635 .6783500431298615
+ .03987292758773981 .9992047586183639
+ .9994306045554617 .03374117185137759
+ .6828455463852481 .7305627692278276
+ .9104412922580672 .41363831223843456
+ .35129275608556715 .9362656671702783
+ .973644249650812 .22807208317088573
+ .5271991347819014 .8497417680008524
+ .8122505865852039 .5833086529376983
+ .16188639378011183 .9868094018141855
+ .9913108598461154 .13154002870288312
+ .6079497849677736 .7939754775543372
+ .8655136240905691 .5008853826112408
+ .257831102162159 .9661900034454125
+ .9466009130832835 .32240767880106985
+ .44137126873171667 .8973245807054183
+ .7511651319096864 .6601143420674205
+ .06438263092985747 .997925286198596
+ .9965711457905548 .08274026454937569
+ .6461760129833164 .7631884172633813
+ .8890483558546646 .45781330359887723
+ .30492922973540243 .9523750127197659
+ .9612804858113206 .27557181931095814
+ .4848692480007911 .8745866522781761
+ .7826505961665757 .62246127937415
+ .11327095217756435 .9935641355205953
+ .9836624192117303 .18002290140569951
+ .5682589526701316 .8228497813758263
+ .8398937941959995 .5427507848645159
+ .2101118368804696 .9776773578245099
+ .9296408958431812 .3684668299533723
+ .3968099874167103 .9179007756213905
+ .7178700450557317 .696177131491463
+ .015339206284988102 .9998823474542126
+ .9997694053512153 .021474080275469508
+ .6917592583641577 .7221281939292153
+ .9154487160882678 .40243465085941843
+ .3627557243673972 .9318842655816681
+ .9763697313300211 .21610679707621952
+ .5375870762956455 .8432082396418454
+ .819347520076797 .5732971666980422
+ .17398387338746382 .9847485018019042
+ .9928504144598651 .11936521481099137
+ .617647307937804 .7864552135990858
+ .8715950866559511 .49022648328829116
+ .2696683255729151 .9629532668736839
+ .9504860739494817 .3107671527496115
+ .4523495872337709 .8918407093923427
+ .7592091889783881 .6508466849963809
+ .07662386139203149 .997060070339483
+ .9975114561403035 .07050457338961387
+ .6554928529996153 .7552013768965365
+ .8945994856313827 .4468688401623742
+ .31659337555616585 .9485613499157303
+ .9645897932898128 .2637546789748314
+ .49556526182577254 .8685707059713409
+ .79023022143731 .6128100824294097
+ .12545498341154623 .9920993131421918
+ .9857975091675675 .16793829497473117
+ .5783137964116556 .8158144108067338
+ .8464909387740521 .532403127877198
+ .22209362097320354 .9750253450669941
+ .9340925504042589 .35703096123343003
+ .4080441628649787 .9129621904283982
+ .726359155084346 .6873153408917592
+ .027608145778965743 .9996188224951786
+ .9989412931868569 .04600318213091463
+ .673829000378756 .7388873244606151
+ .9052967593181188 .4247796812091088
+ .33977688440682685 .9405060705932683
+ .9707721407289504 .2400030224487415
+ .5167317990176499 .8561473283751945
+ .8050313311429635 .5932322950397998
+ .1497645346773215 .9887216919603238
+ .9896220174632009 .14369503315029444
+ .5981607069963423 .8013761717231402
+ .8593018183570084 .5114688504379704
+ .24595505033579462 .9692812353565485
+ .9425731976014469 .3339996514420094
+ .4303264813400826 .9026733182372588
+ .7430079521351217 .6692825883466361
+ .052131704680283324 .9986402181802653
+ .9954807554919269 .094963495329639
+ .6367618612362842 .7710605242618138
+ .8833633386657316 .46868882203582796
+ .29321916269425863 .9560452513499964
+ .9578264130275329 .2873474595447295
+ .47410021465055 .8804708890521608
+ .7749531065948739 .6320187359398091
+ .10106986275482782 .9948793307948056
+ .9813791933137546 .19208039704989244
+ .5581185312205561 .829761233794523
+ .8331701647019132 .5530167055800276
+ .1980984107179536 .9801821359681174
+ .9250492407826776 .37984720892405116
+ .38551605384391885 .9227011283338785
+ .7092728264388657 .7049340803759049
+ .003067956762965976 .9999952938095762
+ )))
+
+(define med-lut
+ (list->f64vector '(1. 0.
+ .9999999999820472 5.9921124526424275e-6
+ .9999999999281892 1.1984224905069707e-5
+ .9999999998384257 1.7976337357066685e-5
+ .9999999997127567 2.396844980841822e-5
+ .9999999995511824 2.9960562258909154e-5
+ .9999999993537025 3.5952674708324344e-5
+ .9999999991203175 4.1944787156448635e-5
+ .9999999988510269 4.793689960306688e-5
+ .9999999985458309 5.3929012047963936e-5
+ .9999999982047294 5.992112449092465e-5
+ .9999999978277226 6.591323693173387e-5
+ .9999999974148104 7.190534937017645e-5
+ .9999999969659927 7.789746180603723e-5
+ .9999999964812697 8.388957423910108e-5
+ .9999999959606412 8.988168666915283e-5
+ .9999999954041073 9.587379909597734e-5
+ .999999994811668 1.0186591151935948e-4
+ .9999999941833233 1.0785802393908407e-4
+ .9999999935190732 1.1385013635493597e-4
+ .9999999928189177 1.1984224876670004e-4
+ .9999999920828567 1.2583436117416112e-4
+ .9999999913108903 1.3182647357710405e-4
+ .9999999905030187 1.3781858597531374e-4
+ .9999999896592414 1.4381069836857496e-4
+ .9999999887795589 1.498028107566726e-4
+ .9999999878639709 1.5579492313939151e-4
+ .9999999869124775 1.6178703551651655e-4
+ .9999999859250787 1.6777914788783258e-4
+ .9999999849017744 1.737712602531244e-4
+ .9999999838425648 1.797633726121769e-4
+ .9999999827474497 1.8575548496477492e-4
+ .9999999816164293 1.9174759731070332e-4
+ .9999999804495034 1.9773970964974692e-4
+ .9999999792466722 2.037318219816906e-4
+ .9999999780079355 2.0972393430631923e-4
+ .9999999767332933 2.1571604662341763e-4
+ .9999999754227459 2.2170815893277063e-4
+ .9999999740762929 2.2770027123416315e-4
+ .9999999726939346 2.3369238352737996e-4
+ .9999999712756709 2.3968449581220595e-4
+ .9999999698215016 2.45676608088426e-4
+ .9999999683314271 2.5166872035582493e-4
+ .9999999668054471 2.5766083261418755e-4
+ .9999999652435617 2.636529448632988e-4
+ .9999999636457709 2.696450571029434e-4
+ .9999999620120748 2.756371693329064e-4
+ .9999999603424731 2.8162928155297243e-4
+ .9999999586369661 2.876213937629265e-4
+ .9999999568955537 2.936135059625534e-4
+ .9999999551182358 2.99605618151638e-4
+ .9999999533050126 3.055977303299651e-4
+ .9999999514558838 3.115898424973196e-4
+ .9999999495708498 3.1758195465348636e-4
+ .9999999476499103 3.235740667982502e-4
+ .9999999456930654 3.2956617893139595e-4
+ .9999999437003151 3.3555829105270853e-4
+ .9999999416716594 3.4155040316197275e-4
+ .9999999396070982 3.475425152589734e-4
+ .9999999375066316 3.535346273434955e-4
+ .9999999353702598 3.595267394153237e-4
+ .9999999331979824 3.6551885147424295e-4
+ .9999999309897996 3.7151096352003814e-4
+ .9999999287457114 3.7750307555249406e-4
+ .9999999264657179 3.8349518757139556e-4
+ .9999999241498189 3.8948729957652753e-4
+ .9999999217980144 3.954794115676748e-4
+ .9999999194103046 4.0147152354462224e-4
+ .9999999169866894 4.0746363550715466e-4
+ .9999999145271687 4.134557474550569e-4
+ .9999999120317428 4.194478593881139e-4
+ .9999999095004113 4.2543997130611036e-4
+ .9999999069331744 4.314320832088313e-4
+ .9999999043300322 4.3742419509606144e-4
+ .9999999016909845 4.4341630696758576e-4
+ .9999998990160315 4.4940841882318896e-4
+ .9999998963051729 4.55400530662656e-4
+ .999999893558409 4.613926424857717e-4
+ .9999998907757398 4.673847542923209e-4
+ .9999998879571651 4.7337686608208844e-4
+ .9999998851026849 4.793689778548592e-4
+ .9999998822122994 4.8536108961041806e-4
+ .9999998792860085 4.913532013485497e-4
+ .9999998763238122 4.973453130690393e-4
+ .9999998733257104 5.033374247716714e-4
+ .9999998702917032 5.09329536456231e-4
+ .9999998672217907 5.153216481225028e-4
+ .9999998641159727 5.213137597702719e-4
+ .9999998609742493 5.27305871399323e-4
+ .9999998577966206 5.332979830094408e-4
+ .9999998545830864 5.392900946004105e-4
+ .9999998513336468 5.452822061720168e-4
+ .9999998480483018 5.512743177240444e-4
+ .9999998447270514 5.572664292562783e-4
+ .9999998413698955 5.632585407685033e-4
+ .9999998379768343 5.692506522605043e-4
+ .9999998345478677 5.752427637320661e-4
+ .9999998310829956 5.812348751829735e-4
+ .9999998275822183 5.872269866130116e-4
+ .9999998240455354 5.93219098021965e-4
+ .9999998204729471 5.992112094096185e-4
+ .9999998168644535 6.052033207757572e-4
+ .9999998132200545 6.111954321201659e-4
+ .99999980953975 6.171875434426292e-4
+ .9999998058235401 6.231796547429323e-4
+ .9999998020714248 6.291717660208597e-4
+ .9999997982834041 6.351638772761965e-4
+ .9999997944594781 6.411559885087275e-4
+ .9999997905996466 6.471480997182375e-4
+ .9999997867039097 6.531402109045114e-4
+ .9999997827722674 6.591323220673341e-4
+ .9999997788047197 6.651244332064902e-4
+ .9999997748012666 6.711165443217649e-4
+ .9999997707619082 6.771086554129428e-4
+ .9999997666866443 6.83100766479809e-4
+ .9999997625754748 6.89092877522148e-4
+ .9999997584284002 6.950849885397449e-4
+ .9999997542454201 7.010770995323844e-4
+ .9999997500265345 7.070692104998515e-4
+ .9999997457717437 7.130613214419311e-4
+ .9999997414810473 7.190534323584079e-4
+ .9999997371544456 7.250455432490666e-4
+ .9999997327919384 7.310376541136925e-4
+ .9999997283935259 7.3702976495207e-4
+ .999999723959208 7.430218757639842e-4
+ .9999997194889846 7.490139865492199e-4
+ .9999997149828559 7.55006097307562e-4
+ .9999997104408218 7.609982080387952e-4
+ .9999997058628822 7.669903187427045e-4
+ .9999997012490373 7.729824294190747e-4
+ .9999996965992869 7.789745400676906e-4
+ .9999996919136313 7.849666506883372e-4
+ .99999968719207 7.909587612807992e-4
+ .9999996824346035 7.969508718448614e-4
+ .9999996776412315 8.029429823803089e-4
+ .9999996728119542 8.089350928869263e-4
+ .9999996679467715 8.149272033644986e-4
+ .9999996630456833 8.209193138128106e-4
+ .9999996581086897 8.269114242316472e-4
+ .9999996531357909 8.329035346207931e-4
+ .9999996481269865 8.388956449800333e-4
+ .9999996430822767 8.448877553091527e-4
+ .9999996380016616 8.508798656079359e-4
+ .999999632885141 8.56871975876168e-4
+ .9999996277327151 8.628640861136338e-4
+ .9999996225443838 8.68856196320118e-4
+ .9999996173201471 8.748483064954056e-4
+ .999999612060005 8.808404166392814e-4
+ .9999996067639574 8.868325267515304e-4
+ .9999996014320045 8.928246368319371e-4
+ .9999995960641462 8.988167468802867e-4
+ .9999995906603825 9.048088568963639e-4
+ .9999995852207133 9.108009668799535e-4
+ .9999995797451389 9.167930768308405e-4
+ .9999995742336589 9.227851867488095e-4
+ .9999995686862736 9.287772966336457e-4
+ .9999995631029829 9.347694064851338e-4
+ .9999995574837868 9.407615163030585e-4
+ .9999995518286853 9.467536260872047e-4
+ .9999995461376784 9.527457358373575e-4
+ .9999995404107661 9.587378455533015e-4
+ .9999995346479484 9.647299552348216e-4
+ .9999995288492254 9.707220648817027e-4
+ .9999995230145969 9.767141744937296e-4
+ .9999995171440631 9.827062840706872e-4
+ .9999995112376238 9.886983936123602e-4
+ .9999995052952791 9.946905031185337e-4
+ .9999994993170291 .0010006826125889925
+ .9999994933028736 .0010066747220235214
+ .9999994872528128 .001012666831421905
+ .9999994811668466 .0010186589407839286
+ .999999475044975 .0010246510501093766
+ .9999994688871979 .0010306431593980344
+ .9999994626935156 .0010366352686496862
+ .9999994564639277 .0010426273778641173
+ .9999994501984345 .0010486194870411127
+ .999999443897036 .0010546115961804568
+ .999999437559732 .0010606037052819344
+ .9999994311865227 .0010665958143453308
+ .9999994247774079 .0010725879233704307
+ .9999994183323877 .0010785800323570187
+ .9999994118514622 .0010845721413048801
+ .9999994053346313 .0010905642502137994
+ .9999993987818949 .0010965563590835613
+ .9999993921932533 .0011025484679139511
+ .9999993855687062 .0011085405767047535
+ .9999993789082536 .0011145326854557532
+ .9999993722118957 .001120524794166735
+ .9999993654796325 .0011265169028374842
+ .9999993587114638 .0011325090114677853
+ .9999993519073898 .001138501120057423
+ .9999993450674104 .0011444932286061825
+ .9999993381915255 .0011504853371138485
+ .9999993312797354 .0011564774455802057
+ .9999993243320398 .0011624695540050393
+ .9999993173484387 .001168461662388134
+ .9999993103289324 .0011744537707292742
+ .9999993032735206 .0011804458790282454
+ .9999992961822035 .0011864379872848323
+ .9999992890549809 .0011924300954988195
+ .999999281891853 .001198422203669992
+ .9999992746928197 .0012044143117981348
+ .999999267457881 .0012104064198830327
+ .999999260187037 .0012163985279244702
+ .9999992528802875 .0012223906359222325
+ .9999992455376326 .0012283827438761045
+ .9999992381590724 .0012343748517858707
+ .9999992307446068 .0012403669596513162
+ .9999992232942359 .001246359067472226
+ .9999992158079595 .0012523511752483847
+ .9999992082857777 .001258343282979577
+ .9999992007276906 .001264335390665588
+ .999999193133698 .0012703274983062026
+ .9999991855038001 .0012763196059012057
+ .9999991778379967 .001282311713450382
+ .9999991701362881 .0012883038209535163
+ .999999162398674 .0012942959284103935
+ .9999991546251547 .0013002880358207985
+ .9999991468157298 .001306280143184516
+ .9999991389703996 .001312272250501331
+ .999999131089164 .0013182643577710285
+ .999999123172023 .0013242564649933932
+ .9999991152189767 .0013302485721682098
+ .9999991072300249 .001336240679295263
+ .9999990992051678 .0013422327863743383
+ .9999990911444054 .0013482248934052201
+ .9999990830477375 .0013542170003876934
+ .9999990749151643 .001360209107321543
+ .9999990667466857 .0013662012142065536
+ .9999990585423016 .0013721933210425101
+ .9999990503020123 .0013781854278291975
+ .9999990420258176 .0013841775345664006
+ .9999990337137175 .0013901696412539043
+ .999999025365712 .0013961617478914935
+ .999999016981801 .0014021538544789526
+ .9999990085619848 .001408145961016067
+ .9999990001062631 .0014141380675026214
+ .9999989916146361 .0014201301739384005
+ .9999989830871038 .0014261222803231893
+ .9999989745236659 .0014321143866567725
+ .9999989659243228 .001438106492938935
+ .9999989572890743 .0014440985991694619
+ .9999989486179204 .0014500907053481378
+ .9999989399108612 .0014560828114747475
+ .9999989311678965 .0014620749175490758
+ .9999989223890265 .001468067023570908
+ .9999989135742512 .0014740591295400284
+ .9999989047235704 .0014800512354562223
+ .9999988958369843 .0014860433413192743
+ .9999988869144928 .0014920354471289693
+ .9999988779560959 .0014980275528850922
+ .9999988689617937 .0015040196585874275
+ .9999988599315861 .0015100117642357607
+ .999998850865473 .0015160038698298762
+ .9999988417634548 .001521995975369559
+ .999998832625531 .0015279880808545937
+ .9999988234517019 .0015339801862847657
+ .9999988142419675 .0015399722916598592
+ .9999988049963277 .0015459643969796596
+ .9999987957147825 .0015519565022439512
+ .9999987863973319 .0015579486074525195
+ .9999987770439759 .001563940712605149
+ .9999987676547146 .0015699328177016243
+ .999998758229548 .0015759249227417307
+ .9999987487684759 .0015819170277252528
+ .9999987392714985 .0015879091326519755
+ .9999987297386157 .0015939012375216837
+ .9999987201698276 .0015998933423341623
+ .9999987105651341 .001605885447089196
+ .9999987009245352 .0016118775517865696
+ .999998691248031 .0016178696564260683
+ .9999986815356214 .0016238617610074765
+ .9999986717873064 .0016298538655305794
+ .9999986620030861 .0016358459699951618
+ .9999986521829605 .0016418380744010084
+ .9999986423269294 .0016478301787479041
+ .999998632434993 .0016538222830356339
+ .9999986225071512 .0016598143872639823
+ .999998612543404 .0016658064914327345
+ .9999986025437515 .0016717985955416754
+ .9999985925081937 .0016777906995905894
+ .9999985824367305 .0016837828035792617
+ .9999985723293618 .0016897749075074774
+ .999998562186088 .0016957670113750207
+ .9999985520069086 .0017017591151816769
+ .9999985417918239 .0017077512189272307
+ .999998531540834 .001713743322611467
+ .9999985212539385 .0017197354262341706
+ .9999985109311378 .0017257275297951264
+ .9999985005724317 .0017317196332941192
+ .9999984901778203 .0017377117367309341
+ .9999984797473034 .0017437038401053556
+ .9999984692808812 .0017496959434171687
+ .9999984587785538 .0017556880466661582
+ .9999984482403208 .001761680149852109
+ .9999984376661826 .0017676722529748061
+ .999998427056139 .0017736643560340342
+ .99999841641019 .001779656459029578
+ .9999984057283358 .0017856485619612225
+ .9999983950105761 .0017916406648287528
+ .999998384256911 .0017976327676319532
+ .9999983734673407 .001803624870370609
+ .9999983626418649 .0018096169730445048
+ .9999983517804839 .0018156090756534257
+ .9999983408831975 .0018216011781971562
+ .9999983299500057 .0018275932806754815
+ .9999983189809085 .0018335853830881864
+ .999998307975906 .0018395774854350557
+ .9999982969349982 .001845569587715874
+ .9999982858581851 .0018515616899304264
+ .9999982747454665 .001857553792078498
+ .9999982635968426 .001863545894159873
+ .9999982524123134 .0018695379961743367
+ .9999982411918789 .001875530098121674
+ .9999982299355389 .0018815222000016696
+ .9999982186432936 .0018875143018141083
+ .999998207315143 .0018935064035587748
+ .999998195951087 .0018994985052354545
+ .9999981845511257 .0019054906068439318
+ .9999981731152591 .0019114827083839918
+ .999998161643487 .001917474809855419
+ .9999981501358096 .0019234669112579987
+ .999998138592227 .0019294590125915154
+ .9999981270127389 .0019354511138557542
+ .9999981153973455 .0019414432150504997
+ .9999981037460468 .0019474353161755369
+ .9999980920588427 .001953427417230651
+ .9999980803357332 .001959419518215626
+ .9999980685767185 .0019654116191302473
+ .9999980567817984 .0019714037199743
+ .9999980449509729 .0019773958207475683
+ .9999980330842422 .0019833879214498375
+ .999998021181606 .001989380022080892
+ .9999980092430646 .0019953721226405176
+ .9999979972686177 .002001364223128498
+ .9999979852582656 .002007356323544619
+ .9999979732120081 .002013348423888665
+ .9999979611298453 .002019340524160421
+ .9999979490117771 .0020253326243596715
+ .9999979368578036 .0020313247244862017
+ .9999979246679247 .002037316824539796
+ .9999979124421405 .00204330892452024
+ .999997900180451 .002049301024427318
+ .9999978878828562 .0020552931242608153
+ .9999978755493559 .002061285224020516
+ .9999978631799504 .0020672773237062057
+ .9999978507746395 .002073269423317669
+ .9999978383334234 .0020792615228546903
+ .9999978258563018 .002085253622317055
+ .999997813343275 .0020912457217045484
+ .9999978007943428 .002097237821016954
+ .9999977882095052 .0021032299202540577
+ .9999977755887623 .0021092220194156444
+ .9999977629321142 .0021152141185014984
+ .9999977502395607 .0021212062175114043
+ .9999977375111019 .002127198316445148
+ .9999977247467376 .0021331904153025134
+ .9999977119464681 .002139182514083286
+ .9999976991102932 .0021451746127872503
+ .9999976862382131 .002151166711414191
+ .9999976733302276 .0021571588099638934
+ .9999976603863368 .0021631509084361423
+ .9999976474065406 .002169143006830722
+ .9999976343908391 .002175135105147418
+ .9999976213392323 .0021811272033860148
+ .9999976082517201 .002187119301546297
+ .9999975951283027 .00219311139962805
+ .9999975819689799 .0021991034976310588
+ .9999975687737518 .0022050955955551076
+ .9999975555426184 .0022110876933999816
+ .9999975422755796 .0022170797911654654
+ .9999975289726355 .002223071888851344
+ .9999975156337861 .0022290639864574026
+ .9999975022590314 .0022350560839834253
+ .9999974888483714 .002241048181429198
+ .999997475401806 .0022470402787945045
+ .9999974619193353 .00225303237607913
+ .9999974484009593 .0022590244732828596
+ .9999974348466779 .0022650165704054784
+ .9999974212564913 .0022710086674467703
+ .9999974076303992 .002277000764406521
+ .9999973939684019 .002282992861284515
+ .9999973802704993 .0022889849580805368
+ .9999973665366915 .0022949770547943723
+ .9999973527669782 .0023009691514258054
+ .9999973389613596 .002306961247974621
+ .9999973251198357 .0023129533444406045
+ .9999973112424065 .0023189454408235406
+ .999997297329072 .0023249375371232135
+ .9999972833798322 .002330929633339409
+ .999997269394687 .0023369217294719113
+ .9999972553736366 .0023429138255205055
+ .9999972413166809 .0023489059214849765
+ .9999972272238198 .002354898017365109
+ .9999972130950534 .0023608901131606883
+ .9999971989303816 .0023668822088714985
+ .9999971847298047 .0023728743044973246
+ .9999971704933224 .0023788664000379523
+ .9999971562209347 .0023848584954931653
+ .9999971419126418 .0023908505908627493
+ .9999971275684435 .0023968426861464883
+ .99999711318834 .002402834781344168
+ .9999970987723311 .0024088268764555732
+ .9999970843204169 .002414818971480488
+ .9999970698325974 .002420811066418698
+ .9999970553088726 .0024268031612699878
+ .9999970407492426 .002432795256034142
+ .9999970261537071 .002438787350710946
+ .9999970115222664 .002444779445300184
+ .9999969968549204 .0024507715398016418
+ .9999969821516691 .002456763634215103
+ .9999969674125124 .002462755728540353
+ .9999969526374506 .0024687478227771774
+ .9999969378264834 .00247473991692536
+ .9999969229796108 .002480732010984686
+ .999996908096833 .0024867241049549406
+ .9999968931781499 .002492716198835908
+ .9999968782235614 .0024987082926273734
+ .9999968632330677 .002504700386329122
+ .9999968482066687 .002510692479940938
+ .9999968331443644 .0025166845734626068
+ .9999968180461547 .0025226766668939127
+ .9999968029120399 .002528668760234641
+ .9999967877420196 .002534660853484576
+ .9999967725360941 .0025406529466435036
+ .9999967572942633 .002546645039711208
+ .9999967420165272 .002552637132687474
+ .9999967267028858 .002558629225572086
+ .9999967113533391 .0025646213183648297
+ .9999966959678871 .0025706134110654896
+ .9999966805465298 .002576605503673851
+ .9999966650892672 .0025825975961896977
+ .9999966495960994 .0025885896886128153
+ .9999966340670262 .0025945817809429885
+ .9999966185020478 .0026005738731800024
+ .9999966029011641 .0026065659653236417
+ .999996587264375 .002612558057373691
+ .9999965715916808 .002618550149329935
+ .9999965558830811 .0026245422411921592
+ .9999965401385762 .002630534332960148
+ .9999965243581661 .002636526424633687
+ .9999965085418506 .0026425185162125596
+ .9999964926896299 .0026485106076965517
+ .9999964768015038 .0026545026990854484
+ .9999964608774725 .0026604947903790337
+ .9999964449175359 .0026664868815770926
+ .999996428921694 .0026724789726794104
+ .9999964128899468 .002678471063685772
+ .9999963968222944 .0026844631545959617
+ .9999963807187366 .002690455245409765
+ .9999963645792737 .002696447336126966
+ .9999963484039053 .00270243942674735
+ .9999963321926317 .002708431517270702
+ .9999963159454529 .0027144236076968066
+ .9999962996623687 .0027204156980254485
+ .9999962833433793 .002726407788256413
+ .9999962669884847 .002732399878389485
+ .9999962505976846 .0027383919684244484
+ .9999962341709794 .002744384058361089
+ .9999962177083689 .0027503761481991913
+ .999996201209853 .0027563682379385403
+ .9999961846754319 .0027623603275789207
+ .9999961681051056 .0027683524171201175
+ .999996151498874 .002774344506561915
+ .9999961348567371 .002780336595904099
+ .9999961181786949 .0027863286851464537
+ .9999961014647475 .0027923207742887642
+ .9999960847148948 .0027983128633308155
+ .9999960679291368 .002804304952272392
+ .9999960511074735 .002810297041113279
+ .9999960342499049 .0028162891298532606
+ .9999960173564312 .0028222812184921227
+ .9999960004270521 .002828273307029649
+ .9999959834617678 .002834265395465626
+ .9999959664605781 .0028402574837998367
+ .9999959494234832 .002846249572032067
+ .9999959323504831 .0028522416601621014
+ .9999959152415777 .002858233748189725
+ .999995898096767 .002864225836114723
+ .9999958809160512 .0028702179239368793
+ .9999958636994299 .0028762100116559793
+ .9999958464469034 .0028822020992718077
+ .9999958291584717 .0028881941867841495
+ .9999958118341348 .0028941862741927895
+ .9999957944738925 .0029001783614975127
+ .999995777077745 .002906170448698104
+ .9999957596456922 .0029121625357943475
+ .9999957421777342 .002918154622786029
+ .999995724673871 .0029241467096729327
+ .9999957071341024 .002930138796454844
+ .9999956895584287 .0029361308831315474
+ .9999956719468496 .0029421229697028273
+ .9999956542993652 .0029481150561684695
+ .9999956366159757 .0029541071425282584
+ .9999956188966809 .002960099228781979
+ .9999956011414808 .002966091314929416
+ .9999955833503754 .002972083400970354
+ .9999955655233649 .0029780754869045785
+ .9999955476604491 .0029840675727318736
+ .999995529761628 .002990059658452025
+ .9999955118269016 .0029960517440648163
+ .99999549385627 .0030020438295700336
+ .9999954758497331 .0030080359149674612
+ .999995457807291 .003014028000256884
+ .9999954397289438 .003020020085438087
+ .9999954216146911 .0030260121705108552
+ .9999954034645333 .003032004255474973
+ .9999953852784702 .003037996340330225
+ .9999953670565019 .003043988425076397
+ .9999953487986284 .003049980509713273
+ .9999953305048496 .0030559725942406386
+ .9999953121751655 .003061964678658278
+ )))
+
+
+(define high-lut
+ (list->f64vector '(1. 0.
+ .9999999999999999 1.1703344634137277e-8
+ .9999999999999998 2.3406689268274554e-8
+ .9999999999999993 3.5110033902411824e-8
+ .9999999999999989 4.6813378536549095e-8
+ .9999999999999983 5.851672317068635e-8
+ .9999999999999976 7.022006780482361e-8
+ .9999999999999967 8.192341243896085e-8
+ .9999999999999957 9.362675707309808e-8
+ .9999999999999944 1.0533010170723531e-7
+ .9999999999999931 1.170334463413725e-7
+ .9999999999999917 1.287367909755097e-7
+ .9999999999999901 1.4044013560964687e-7
+ .9999999999999885 1.5214348024378403e-7
+ .9999999999999866 1.6384682487792116e-7
+ .9999999999999846 1.7555016951205827e-7
+ .9999999999999825 1.8725351414619535e-7
+ .9999999999999802 1.989568587803324e-7
+ .9999999999999778 2.1066020341446942e-7
+ .9999999999999752 2.2236354804860645e-7
+ .9999999999999726 2.3406689268274342e-7
+ .9999999999999698 2.4577023731688034e-7
+ .9999999999999668 2.5747358195101726e-7
+ .9999999999999638 2.6917692658515413e-7
+ .9999999999999606 2.8088027121929094e-7
+ .9999999999999571 2.9258361585342776e-7
+ .9999999999999537 3.042869604875645e-7
+ .99999999999995 3.159903051217012e-7
+ .9999999999999463 3.276936497558379e-7
+ .9999999999999424 3.3939699438997453e-7
+ .9999999999999384 3.5110033902411114e-7
+ .9999999999999342 3.6280368365824763e-7
+ .9999999999999298 3.7450702829238413e-7
+ .9999999999999254 3.8621037292652057e-7
+ .9999999999999208 3.979137175606569e-7
+ .9999999999999161 4.0961706219479325e-7
+ .9999999999999113 4.2132040682892953e-7
+ .9999999999999063 4.330237514630657e-7
+ .9999999999999011 4.447270960972019e-7
+ .9999999999998959 4.5643044073133796e-7
+ .9999999999998904 4.68133785365474e-7
+ .9999999999998849 4.7983712999961e-7
+ .9999999999998792 4.915404746337459e-7
+ .9999999999998733 5.032438192678817e-7
+ .9999999999998674 5.149471639020175e-7
+ .9999999999998613 5.266505085361531e-7
+ .9999999999998551 5.383538531702888e-7
+ .9999999999998487 5.500571978044243e-7
+ .9999999999998422 5.617605424385598e-7
+ .9999999999998356 5.734638870726952e-7
+ .9999999999998288 5.851672317068305e-7
+ .9999999999998219 5.968705763409657e-7
+ .9999999999998148 6.085739209751009e-7
+ .9999999999998076 6.202772656092359e-7
+ .9999999999998003 6.319806102433709e-7
+ .9999999999997928 6.436839548775058e-7
+ .9999999999997853 6.553872995116406e-7
+ .9999999999997775 6.670906441457753e-7
+ .9999999999997696 6.7879398877991e-7
+ .9999999999997616 6.904973334140445e-7
+ .9999999999997534 7.02200678048179e-7
+ .9999999999997452 7.139040226823132e-7
+ .9999999999997368 7.256073673164475e-7
+ .9999999999997282 7.373107119505817e-7
+ .9999999999997194 7.490140565847157e-7
+ .9999999999997107 7.607174012188497e-7
+ .9999999999997017 7.724207458529835e-7
+ .9999999999996926 7.841240904871172e-7
+ .9999999999996834 7.958274351212508e-7
+ .9999999999996739 8.075307797553844e-7
+ .9999999999996644 8.192341243895178e-7
+ .9999999999996547 8.309374690236511e-7
+ .999999999999645 8.426408136577842e-7
+ .9999999999996351 8.543441582919173e-7
+ .999999999999625 8.660475029260503e-7
+ .9999999999996148 8.777508475601831e-7
+ .9999999999996044 8.894541921943158e-7
+ .999999999999594 9.011575368284484e-7
+ .9999999999995833 9.128608814625808e-7
+ .9999999999995726 9.245642260967132e-7
+ .9999999999995617 9.362675707308454e-7
+ .9999999999995507 9.479709153649775e-7
+ .9999999999995395 9.596742599991095e-7
+ .9999999999995283 9.713776046332412e-7
+ .9999999999995168 9.83080949267373e-7
+ .9999999999995052 9.947842939015044e-7
+ .9999999999994935 1.006487638535636e-6
+ .9999999999994816 1.0181909831697673e-6
+ .9999999999994696 1.0298943278038984e-6
+ .9999999999994575 1.0415976724380293e-6
+ .9999999999994453 1.0533010170721601e-6
+ .9999999999994329 1.065004361706291e-6
+ .9999999999994204 1.0767077063404215e-6
+ .9999999999994077 1.088411050974552e-6
+ .9999999999993949 1.1001143956086822e-6
+ .9999999999993819 1.1118177402428122e-6
+ .9999999999993688 1.1235210848769423e-6
+ .9999999999993556 1.135224429511072e-6
+ .9999999999993423 1.1469277741452017e-6
+ .9999999999993288 1.1586311187793313e-6
+ .9999999999993151 1.1703344634134605e-6
+ .9999999999993014 1.1820378080475897e-6
+ .9999999999992875 1.1937411526817187e-6
+ .9999999999992735 1.2054444973158477e-6
+ .9999999999992593 1.2171478419499764e-6
+ .9999999999992449 1.2288511865841048e-6
+ .9999999999992305 1.2405545312182331e-6
+ .999999999999216 1.2522578758523615e-6
+ .9999999999992012 1.2639612204864894e-6
+ .9999999999991863 1.2756645651206173e-6
+ .9999999999991713 1.287367909754745e-6
+ .9999999999991562 1.2990712543888725e-6
+ .9999999999991409 1.3107745990229998e-6
+ .9999999999991255 1.3224779436571269e-6
+ .9999999999991099 1.3341812882912537e-6
+ .9999999999990943 1.3458846329253806e-6
+ .9999999999990785 1.3575879775595072e-6
+ .9999999999990625 1.3692913221936337e-6
+ .9999999999990464 1.3809946668277597e-6
+ .9999999999990302 1.3926980114618857e-6
+ .9999999999990138 1.4044013560960117e-6
+ .9999999999989974 1.4161047007301373e-6
+ .9999999999989807 1.4278080453642627e-6
+ .9999999999989639 1.439511389998388e-6
+ .999999999998947 1.451214734632513e-6
+ .99999999999893 1.462918079266638e-6
+ .9999999999989128 1.4746214239007625e-6
+ .9999999999988954 1.486324768534887e-6
+ .999999999998878 1.4980281131690111e-6
+ .9999999999988604 1.5097314578031353e-6
+ .9999999999988426 1.5214348024372591e-6
+ .9999999999988247 1.5331381470713828e-6
+ .9999999999988067 1.544841491705506e-6
+ .9999999999987886 1.5565448363396294e-6
+ .9999999999987703 1.5682481809737524e-6
+ .9999999999987519 1.579951525607875e-6
+ .9999999999987333 1.5916548702419977e-6
+ .9999999999987146 1.60335821487612e-6
+ .9999999999986958 1.615061559510242e-6
+ .9999999999986768 1.626764904144364e-6
+ .9999999999986577 1.6384682487784858e-6
+ .9999999999986384 1.6501715934126072e-6
+ .9999999999986191 1.6618749380467283e-6
+ .9999999999985996 1.6735782826808495e-6
+ .9999999999985799 1.6852816273149702e-6
+ .9999999999985602 1.6969849719490907e-6
+ .9999999999985402 1.708688316583211e-6
+ .9999999999985201 1.720391661217331e-6
+ .9999999999985 1.732095005851451e-6
+ .9999999999984795 1.7437983504855706e-6
+ .9999999999984591 1.7555016951196899e-6
+ .9999999999984385 1.767205039753809e-6
+ .9999999999984177 1.778908384387928e-6
+ .9999999999983968 1.7906117290220465e-6
+ .9999999999983759 1.802315073656165e-6
+ .9999999999983546 1.814018418290283e-6
+ .9999999999983333 1.825721762924401e-6
+ .9999999999983119 1.8374251075585186e-6
+ .9999999999982904 1.8491284521926361e-6
+ .9999999999982686 1.8608317968267533e-6
+ .9999999999982468 1.8725351414608702e-6
+ .9999999999982249 1.8842384860949866e-6
+ .9999999999982027 1.8959418307291031e-6
+ .9999999999981805 1.9076451753632194e-6
+ .999999999998158 1.919348519997335e-6
+ .9999999999981355 1.9310518646314507e-6
+ .9999999999981128 1.942755209265566e-6
+ .9999999999980901 1.954458553899681e-6
+ .9999999999980671 1.966161898533796e-6
+ .999999999998044 1.9778652431679103e-6
+ .9999999999980208 1.9895685878020246e-6
+ .9999999999979975 2.0012719324361386e-6
+ .999999999997974 2.012975277070252e-6
+ .9999999999979503 2.0246786217043656e-6
+ .9999999999979265 2.0363819663384787e-6
+ .9999999999979027 2.048085310972592e-6
+ .9999999999978786 2.0597886556067045e-6
+ .9999999999978545 2.0714920002408167e-6
+ .9999999999978302 2.0831953448749286e-6
+ .9999999999978058 2.0948986895090404e-6
+ .9999999999977811 2.106602034143152e-6
+ .9999999999977564 2.118305378777263e-6
+ .9999999999977315 2.1300087234113738e-6
+ .9999999999977065 2.1417120680454843e-6
+ .9999999999976814 2.153415412679595e-6
+ .9999999999976561 2.1651187573137046e-6
+ .9999999999976307 2.1768221019478143e-6
+ .9999999999976051 2.188525446581924e-6
+ .9999999999975795 2.200228791216033e-6
+ .9999999999975536 2.2119321358501417e-6
+ .9999999999975278 2.22363548048425e-6
+ .9999999999975017 2.2353388251183586e-6
+ .9999999999974754 2.247042169752466e-6
+ .999999999997449 2.2587455143865738e-6
+ .9999999999974225 2.2704488590206814e-6
+ .9999999999973959 2.282152203654788e-6
+ .9999999999973691 2.293855548288895e-6
+ .9999999999973422 2.305558892923001e-6
+ .9999999999973151 2.317262237557107e-6
+ .999999999997288 2.328965582191213e-6
+ .9999999999972606 2.340668926825318e-6
+ .9999999999972332 2.352372271459423e-6
+ .9999999999972056 2.364075616093528e-6
+ .9999999999971778 2.3757789607276323e-6
+ .99999999999715 2.3874823053617365e-6
+ .999999999997122 2.3991856499958403e-6
+ .9999999999970938 2.4108889946299437e-6
+ .9999999999970656 2.4225923392640466e-6
+ .9999999999970371 2.4342956838981495e-6
+ .9999999999970085 2.445999028532252e-6
+ .9999999999969799 2.457702373166354e-6
+ .999999999996951 2.4694057178004558e-6
+ .999999999996922 2.4811090624345574e-6
+ .9999999999968929 2.4928124070686583e-6
+ .9999999999968637 2.504515751702759e-6
+ .9999999999968343 2.5162190963368595e-6
+ .9999999999968048 2.5279224409709594e-6
+ .9999999999967751 2.5396257856050594e-6
+ .9999999999967454 2.5513291302391585e-6
+ .9999999999967154 2.5630324748732576e-6
+ .9999999999966853 2.5747358195073563e-6
+ .9999999999966551 2.5864391641414546e-6
+ .9999999999966248 2.5981425087755525e-6
+ .9999999999965944 2.6098458534096503e-6
+ .9999999999965637 2.6215491980437473e-6
+ .999999999996533 2.6332525426778443e-6
+ .9999999999965021 2.644955887311941e-6
+ .999999999996471 2.656659231946037e-6
+ .99999999999644 2.6683625765801328e-6
+ .9999999999964087 2.680065921214228e-6
+ .9999999999963772 2.6917692658483234e-6
+ .9999999999963456 2.703472610482418e-6
+ .999999999996314 2.7151759551165123e-6
+ .9999999999962821 2.7268792997506064e-6
+ .9999999999962501 2.7385826443846996e-6
+ .9999999999962179 2.750285989018793e-6
+ .9999999999961857 2.761989333652886e-6
+ .9999999999961533 2.7736926782869783e-6
+ .9999999999961208 2.78539602292107e-6
+ .9999999999960881 2.797099367555162e-6
+ .9999999999960553 2.808802712189253e-6
+ .9999999999960224 2.8205060568233443e-6
+ .9999999999959893 2.832209401457435e-6
+ .9999999999959561 2.8439127460915247e-6
+ .9999999999959227 2.8556160907256145e-6
+ .9999999999958893 2.867319435359704e-6
+ .9999999999958556 2.879022779993793e-6
+ .9999999999958219 2.8907261246278814e-6
+ .9999999999957879 2.90242946926197e-6
+ .999999999995754 2.9141328138960576e-6
+ .9999999999957198 2.925836158530145e-6
+ .9999999999956855 2.9375395031642317e-6
+ .999999999995651 2.9492428477983186e-6
+ .9999999999956164 2.9609461924324046e-6
+ .9999999999955816 2.9726495370664905e-6
+ .9999999999955468 2.9843528817005757e-6
+ .9999999999955118 2.996056226334661e-6
+ .9999999999954767 3.007759570968745e-6
+ .9999999999954414 3.0194629156028294e-6
+ .999999999995406 3.0311662602369133e-6
+ .9999999999953705 3.0428696048709963e-6
+ .9999999999953348 3.0545729495050794e-6
+ .999999999995299 3.066276294139162e-6
+ .999999999995263 3.0779796387732437e-6
+ .9999999999952269 3.0896829834073255e-6
+ .9999999999951907 3.101386328041407e-6
+ .9999999999951543 3.1130896726754873e-6
+ .9999999999951178 3.1247930173095678e-6
+ .9999999999950812 3.136496361943648e-6
+ .9999999999950444 3.148199706577727e-6
+ .9999999999950075 3.1599030512118063e-6
+ .9999999999949705 3.171606395845885e-6
+ .9999999999949333 3.183309740479963e-6
+ .999999999994896 3.195013085114041e-6
+ .9999999999948584 3.206716429748118e-6
+ .9999999999948209 3.218419774382195e-6
+ .9999999999947832 3.2301231190162714e-6
+ .9999999999947453 3.2418264636503477e-6
+ .9999999999947072 3.253529808284423e-6
+ .9999999999946692 3.265233152918498e-6
+ .9999999999946309 3.276936497552573e-6
+ .9999999999945924 3.288639842186647e-6
+ .9999999999945539 3.300343186820721e-6
+ .9999999999945152 3.312046531454794e-6
+ .9999999999944763 3.323749876088867e-6
+ .9999999999944373 3.3354532207229395e-6
+ .9999999999943983 3.3471565653570115e-6
+ .9999999999943591 3.358859909991083e-6
+ .9999999999943197 3.370563254625154e-6
+ .9999999999942801 3.3822665992592245e-6
+ .9999999999942405 3.3939699438932944e-6
+ .9999999999942008 3.4056732885273643e-6
+ .9999999999941608 3.4173766331614334e-6
+ .9999999999941207 3.429079977795502e-6
+ .9999999999940805 3.4407833224295702e-6
+ .9999999999940402 3.452486667063638e-6
+ .9999999999939997 3.4641900116977054e-6
+ .999999999993959 3.4758933563317723e-6
+ .9999999999939183 3.4875967009658384e-6
+ .9999999999938775 3.4993000455999045e-6
+ .9999999999938364 3.5110033902339697e-6
+ .9999999999937953 3.5227067348680345e-6
+ .999999999993754 3.534410079502099e-6
+ .9999999999937126 3.546113424136163e-6
+ .999999999993671 3.5578167687702264e-6
+ .9999999999936293 3.5695201134042896e-6
+ .9999999999935875 3.581223458038352e-6
+ .9999999999935454 3.592926802672414e-6
+ .9999999999935033 3.6046301473064755e-6
+ .9999999999934611 3.6163334919405365e-6
+ .9999999999934187 3.628036836574597e-6
+ .9999999999933762 3.639740181208657e-6
+ .9999999999933334 3.6514435258427166e-6
+ .9999999999932907 3.6631468704767755e-6
+ .9999999999932477 3.674850215110834e-6
+ .9999999999932047 3.686553559744892e-6
+ .9999999999931615 3.6982569043789496e-6
+ .9999999999931181 3.7099602490130064e-6
+ .9999999999930747 3.7216635936470627e-6
+ .999999999993031 3.733366938281119e-6
+ .9999999999929873 3.745070282915174e-6
+ .9999999999929433 3.756773627549229e-6
+ .9999999999928992 3.768476972183284e-6
+ .9999999999928552 3.7801803168173377e-6
+ .9999999999928109 3.791883661451391e-6
+ .9999999999927663 3.803587006085444e-6
+ .9999999999927218 3.8152903507194965e-6
+ .9999999999926771 3.826993695353548e-6
+ .9999999999926322 3.838697039987599e-6
+ .9999999999925873 3.85040038462165e-6
+ .9999999999925421 3.862103729255701e-6
+ .9999999999924968 3.87380707388975e-6
+ .9999999999924514 3.885510418523799e-6
+ .9999999999924059 3.897213763157848e-6
+ .9999999999923602 3.9089171077918965e-6
+ .9999999999923144 3.9206204524259435e-6
+ .9999999999922684 3.9323237970599905e-6
+ .9999999999922223 3.9440271416940376e-6
+ .9999999999921761 3.955730486328084e-6
+ .9999999999921297 3.967433830962129e-6
+ .9999999999920832 3.9791371755961736e-6
+ .9999999999920366 3.990840520230218e-6
+ .9999999999919899 4.002543864864262e-6
+ .9999999999919429 4.014247209498305e-6
+ .9999999999918958 4.025950554132348e-6
+ .9999999999918486 4.03765389876639e-6
+ .9999999999918013 4.049357243400431e-6
+ .9999999999917539 4.061060588034472e-6
+ .9999999999917063 4.072763932668513e-6
+ .9999999999916586 4.084467277302553e-6
+ .9999999999916107 4.096170621936592e-6
+ .9999999999915626 4.107873966570632e-6
+ .9999999999915146 4.119577311204669e-6
+ .9999999999914663 4.131280655838707e-6
+ .9999999999914179 4.142984000472745e-6
+ .9999999999913692 4.154687345106781e-6
+ .9999999999913206 4.166390689740817e-6
+ .9999999999912718 4.178094034374852e-6
+ .9999999999912228 4.189797379008887e-6
+ .9999999999911737 4.201500723642921e-6
+ .9999999999911244 4.213204068276955e-6
+ .999999999991075 4.224907412910988e-6
+ .9999999999910255 4.236610757545021e-6
+ .9999999999909759 4.248314102179053e-6
+ .9999999999909261 4.260017446813084e-6
+ .9999999999908762 4.271720791447115e-6
+ .9999999999908261 4.283424136081145e-6
+ .9999999999907759 4.295127480715175e-6
+ .9999999999907256 4.306830825349204e-6
+ .9999999999906751 4.3185341699832325e-6
+ .9999999999906245 4.33023751461726e-6
+ .9999999999905738 4.3419408592512875e-6
+ .9999999999905229 4.353644203885314e-6
+ .9999999999904718 4.36534754851934e-6
+ .9999999999904207 4.377050893153365e-6
+ .9999999999903694 4.38875423778739e-6
+ .999999999990318 4.400457582421414e-6
+ .9999999999902665 4.4121609270554384e-6
+ .9999999999902147 4.423864271689461e-6
+ .9999999999901629 4.435567616323483e-6
+ .9999999999901109 4.447270960957506e-6
+ .9999999999900587 4.458974305591527e-6
+ .9999999999900065 4.470677650225547e-6
+ .9999999999899541 4.482380994859567e-6
+ .9999999999899016 4.494084339493587e-6
+ .9999999999898489 4.5057876841276054e-6
+ .9999999999897962 4.517491028761624e-6
+ .9999999999897432 4.529194373395641e-6
+ .9999999999896901 4.5408977180296584e-6
+ .999999999989637 4.552601062663675e-6
+ .9999999999895836 4.564304407297691e-6
+ .99999999998953 4.5760077519317055e-6
+ .9999999999894764 4.5877110965657195e-6
+ .9999999999894227 4.5994144411997335e-6
+ .9999999999893688 4.611117785833747e-6
+ .9999999999893148 4.622821130467759e-6
+ .9999999999892606 4.634524475101771e-6
+ .9999999999892063 4.646227819735783e-6
+ .9999999999891518 4.657931164369793e-6
+ .9999999999890973 4.669634509003803e-6
+ .9999999999890425 4.681337853637813e-6
+ .9999999999889877 4.693041198271821e-6
+ .9999999999889327 4.704744542905829e-6
+ .9999999999888776 4.716447887539837e-6
+ .9999999999888223 4.728151232173843e-6
+ .9999999999887669 4.73985457680785e-6
+ .9999999999887114 4.751557921441855e-6
+ .9999999999886556 4.76326126607586e-6
+ .9999999999885999 4.774964610709864e-6
+ .9999999999885439 4.786667955343868e-6
+ .9999999999884878 4.798371299977871e-6
+ .9999999999884316 4.810074644611873e-6
+ .9999999999883752 4.821777989245874e-6
+ .9999999999883187 4.833481333879875e-6
+ .9999999999882621 4.845184678513876e-6
+ .9999999999882053 4.856888023147875e-6
+ .9999999999881484 4.868591367781874e-6
+ .9999999999880914 4.880294712415872e-6
+ .9999999999880341 4.89199805704987e-6
+ .9999999999879768 4.903701401683867e-6
+ .9999999999879194 4.915404746317863e-6
+ .9999999999878618 4.9271080909518585e-6
+ .9999999999878041 4.938811435585853e-6
+ .9999999999877462 4.9505147802198475e-6
+ .9999999999876882 4.962218124853841e-6
+ .99999999998763 4.973921469487834e-6
+ .9999999999875717 4.985624814121826e-6
+ .9999999999875133 4.997328158755817e-6
+ .9999999999874548 5.009031503389808e-6
+ .9999999999873961 5.0207348480237985e-6
+ .9999999999873372 5.032438192657788e-6
+ .9999999999872783 5.0441415372917765e-6
+ .9999999999872192 5.055844881925764e-6
+ .9999999999871599 5.067548226559752e-6
+ .9999999999871007 5.079251571193739e-6
+ .9999999999870411 5.090954915827725e-6
+ .9999999999869814 5.10265826046171e-6
+ .9999999999869217 5.1143616050956945e-6
+ .9999999999868617 5.126064949729678e-6
+ .9999999999868017 5.1377682943636615e-6
+ .9999999999867415 5.149471638997644e-6
+ .9999999999866811 5.161174983631626e-6
+ .9999999999866207 5.172878328265607e-6
+ .9999999999865601 5.184581672899587e-6
+ .9999999999864994 5.196285017533567e-6
+ .9999999999864384 5.2079883621675455e-6
+ .9999999999863775 5.219691706801524e-6
+ .9999999999863163 5.2313950514355015e-6
+ .999999999986255 5.243098396069478e-6
+ .9999999999861935 5.254801740703454e-6
+ .999999999986132 5.266505085337429e-6
+ .9999999999860703 5.278208429971404e-6
+ .9999999999860084 5.289911774605378e-6
+ .9999999999859465 5.301615119239351e-6
+ .9999999999858843 5.313318463873323e-6
+ .9999999999858221 5.325021808507295e-6
+ .9999999999857597 5.336725153141267e-6
+ .9999999999856971 5.3484284977752366e-6
+ .9999999999856345 5.360131842409206e-6
+ .9999999999855717 5.371835187043175e-6
+ .9999999999855087 5.383538531677143e-6
+ .9999999999854456 5.3952418763111104e-6
+ .9999999999853825 5.406945220945077e-6
+ .9999999999853191 5.418648565579043e-6
+ .9999999999852557 5.4303519102130076e-6
+ .9999999999851921 5.4420552548469724e-6
+ .9999999999851282 5.453758599480936e-6
+ .9999999999850644 5.465461944114899e-6
+ .9999999999850003 5.47716528874886e-6
+ .9999999999849362 5.488868633382822e-6
+ .9999999999848719 5.500571978016782e-6
+ .9999999999848074 5.512275322650742e-6
+ .9999999999847429 5.523978667284702e-6
+ .9999999999846781 5.53568201191866e-6
+ .9999999999846133 5.547385356552617e-6
+ .9999999999845482 5.5590887011865745e-6
+ .9999999999844832 5.57079204582053e-6
+ .9999999999844179 5.582495390454486e-6
+ .9999999999843525 5.59419873508844e-6
+ .9999999999842869 5.605902079722394e-6
+ .9999999999842213 5.617605424356347e-6
+ .9999999999841555 5.629308768990299e-6
+ .9999999999840895 5.641012113624251e-6
+ .9999999999840234 5.652715458258201e-6
+ .9999999999839572 5.664418802892152e-6
+ .9999999999838908 5.6761221475261e-6
+ .9999999999838243 5.687825492160048e-6
+ .9999999999837577 5.699528836793996e-6
+ .9999999999836909 5.711232181427943e-6
+ .999999999983624 5.722935526061889e-6
+ .9999999999835569 5.734638870695834e-6
+ .9999999999834898 5.746342215329779e-6
+ .9999999999834225 5.758045559963722e-6
+ .999999999983355 5.769748904597665e-6
+ .9999999999832874 5.781452249231607e-6
+ .9999999999832196 5.793155593865548e-6
+ .9999999999831518 5.804858938499489e-6
+ .9999999999830838 5.816562283133429e-6
+ .9999999999830157 5.8282656277673675e-6
+ .9999999999829474 5.839968972401306e-6
+ .9999999999828789 5.851672317035243e-6
+ .9999999999828104 5.86337566166918e-6
+ .9999999999827417 5.875079006303115e-6
+ .9999999999826729 5.88678235093705e-6
+ .9999999999826039 5.898485695570985e-6
+ .9999999999825349 5.910189040204917e-6
+ .9999999999824656 5.92189238483885e-6
+ .9999999999823962 5.933595729472782e-6
+ .9999999999823267 5.945299074106713e-6
+ .9999999999822571 5.957002418740643e-6
+ .9999999999821872 5.9687057633745715e-6
+ .9999999999821173 5.9804091080085e-6
+ )))
+
+(define (make-w log-n)
+ (let ((n (expt 2 log-n))) ;; number of complexes
+ (if (fx<= n lut-table-size)
+ low-lut
+ (let ((result (make-f64vector (fx* 2 n))))
+
+ (define (copy-low-lut)
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i lut-table-size))
+ (let ((index (fx* i 2)))
+ (f64vector-set!
+ result
+ index
+ (f64vector-ref low-lut index))
+ (f64vector-set!
+ result
+ (fx+ index 1)
+ (f64vector-ref low-lut (fx+ index 1))))))
+
+ (define (extend-lut multiplier-lut bit-reverse-size bit-reverse-multiplier start end)
+
+ (define (bit-reverse x n)
+ (declare (not interrupts-enabled))
+ (do ((i 0 (fx+ i 1))
+ (x x (fxarithmetic-shift-right x 1))
+ (result 0 (fx+ (fx* result 2)
+ (bitwise-and x 1))))
+ ((fx= i n) result)))
+
+ (let loop ((i start)
+ (j 1))
+ (if (fx< i end)
+ (let* ((multiplier-index
+ (fx* 2
+ (fx* (bit-reverse j bit-reverse-size)
+ bit-reverse-multiplier)))
+ (multiplier-real
+ (f64vector-ref multiplier-lut multiplier-index))
+ (multiplier-imag
+ (f64vector-ref multiplier-lut (fx+ multiplier-index 1))))
+ (let inner ((i i)
+ (k 0))
+ ;; we copy complex multiples of all entries below
+ ;; start to entries starting at start
+ (if (fx< k start)
+ (let* ((index
+ (fx* k 2))
+ (real
+ (f64vector-ref result index))
+ (imag
+ (f64vector-ref result (fx+ index 1)))
+ (result-real
+ (fl- (fl* multiplier-real real)
+ (fl* multiplier-imag imag)))
+ (result-imag
+ (fl+ (fl* multiplier-real imag)
+ (fl* multiplier-imag real)))
+ (result-index (fx* i 2)))
+ (f64vector-set! result result-index result-real)
+ (f64vector-set! result (fx+ result-index 1) result-imag)
+ (inner (fx+ i 1)
+ (fx+ k 1)))
+ (loop i
+ (fx+ j 1)))))
+ result)))
+
+ (cond ((fx<= n lut-table-size^2)
+ (copy-low-lut)
+ (extend-lut med-lut
+ (fx- log-n log-lut-table-size)
+ (fxarithmetic-shift-left 1 (fx- (fx* 2 log-lut-table-size) log-n))
+ lut-table-size
+ n))
+ ((fx<= n lut-table-size^3)
+ (copy-low-lut)
+ (extend-lut med-lut
+ log-lut-table-size
+ 1
+ lut-table-size
+ lut-table-size^2)
+ (extend-lut high-lut
+ (fx- log-n (fx* 2 log-lut-table-size))
+ (fxarithmetic-shift-left 1 (fx- (fx* 3 log-lut-table-size) log-n))
+ lut-table-size^2
+ n))
+ (else
+ (error "asking for too large a table")))))))
+
+(define (direct-fft-recursive-4 a W-table)
+
+ ;; This is a direcct complex fft, using a decimation-in-time
+ ;; algorithm with inputs in natural order and outputs in
+ ;; bit-reversed order. The table of "twiddle" factors is in
+ ;; bit-reversed order.
+
+ ;; this is from page 66 of Chu and George, except that we have
+ ;; combined passes in pairs to cut the number of passes through
+ ;; the vector a
+
+ (let ((W (f64vector 0. 0. 0. 0.)))
+
+ (define (main-loop M N K SizeOfGroup)
+
+ (let inner-loop ((K K)
+ (JFirst M))
+
+ (if (fx< JFirst N)
+
+ (let* ((JLast (fx+ JFirst SizeOfGroup)))
+
+ (if (fxeven? K)
+ (begin
+ (f64vector-set! W 0 (f64vector-ref W-table K))
+ (f64vector-set! W 1 (f64vector-ref W-table (fx+ K 1))))
+ (begin
+ (f64vector-set! W 0 (fl- 0. (f64vector-ref W-table K)))
+ (f64vector-set! W 1 (f64vector-ref W-table (fx- K 1)))))
+
+ ;; we know the that the next two complex roots of
+ ;; unity have index 2K and 2K+1 so that the 2K+1
+ ;; index root can be gotten from the 2K index root
+ ;; in the same way that we get W_0 and W_1 from the
+ ;; table depending on whether K is even or not
+
+ (f64vector-set! W 2 (f64vector-ref W-table (fx* K 2)))
+ (f64vector-set! W 3 (f64vector-ref W-table (fx+ (fx* K 2) 1)))
+
+ (let J-loop ((J0 JFirst))
+ (if (fx< J0 JLast)
+
+ (let* ((J0 J0)
+ (J1 (fx+ J0 1))
+ (J2 (fx+ J0 SizeOfGroup))
+ (J3 (fx+ J2 1))
+ (J4 (fx+ J2 SizeOfGroup))
+ (J5 (fx+ J4 1))
+ (J6 (fx+ J4 SizeOfGroup))
+ (J7 (fx+ J6 1)))
+
+ (let ((W_0 (f64vector-ref W 0))
+ (W_1 (f64vector-ref W 1))
+ (W_2 (f64vector-ref W 2))
+ (W_3 (f64vector-ref W 3))
+ (a_J0 (f64vector-ref a J0))
+ (a_J1 (f64vector-ref a J1))
+ (a_J2 (f64vector-ref a J2))
+ (a_J3 (f64vector-ref a J3))
+ (a_J4 (f64vector-ref a J4))
+ (a_J5 (f64vector-ref a J5))
+ (a_J6 (f64vector-ref a J6))
+ (a_J7 (f64vector-ref a J7)))
+
+ ;; first we do the (overlapping) pairs of
+ ;; butterflies with entries 2*SizeOfGroup
+ ;; apart.
+
+ (let ((Temp_0 (fl- (fl* W_0 a_J4)
+ (fl* W_1 a_J5)))
+ (Temp_1 (fl+ (fl* W_0 a_J5)
+ (fl* W_1 a_J4)))
+ (Temp_2 (fl- (fl* W_0 a_J6)
+ (fl* W_1 a_J7)))
+ (Temp_3 (fl+ (fl* W_0 a_J7)
+ (fl* W_1 a_J6))))
+
+ (let ((a_J0 (fl+ a_J0 Temp_0))
+ (a_J1 (fl+ a_J1 Temp_1))
+ (a_J2 (fl+ a_J2 Temp_2))
+ (a_J3 (fl+ a_J3 Temp_3))
+ (a_J4 (fl- a_J0 Temp_0))
+ (a_J5 (fl- a_J1 Temp_1))
+ (a_J6 (fl- a_J2 Temp_2))
+ (a_J7 (fl- a_J3 Temp_3)))
+
+ ;; now we do the two (disjoint) pairs
+ ;; of butterflies distance SizeOfGroup
+ ;; apart, the first pair with W2+W3i,
+ ;; the second with -W3+W2i
+
+ ;; we rewrite the multipliers so I
+ ;; don't hurt my head too much when
+ ;; thinking about them.
+
+ (let ((W_0 W_2)
+ (W_1 W_3)
+ (W_2 (fl- 0. W_3))
+ (W_3 W_2))
+
+ (let ((Temp_0
+ (fl- (fl* W_0 a_J2)
+ (fl* W_1 a_J3)))
+ (Temp_1
+ (fl+ (fl* W_0 a_J3)
+ (fl* W_1 a_J2)))
+ (Temp_2
+ (fl- (fl* W_2 a_J6)
+ (fl* W_3 a_J7)))
+ (Temp_3
+ (fl+ (fl* W_2 a_J7)
+ (fl* W_3 a_J6))))
+
+ (let ((a_J0 (fl+ a_J0 Temp_0))
+ (a_J1 (fl+ a_J1 Temp_1))
+ (a_J2 (fl- a_J0 Temp_0))
+ (a_J3 (fl- a_J1 Temp_1))
+ (a_J4 (fl+ a_J4 Temp_2))
+ (a_J5 (fl+ a_J5 Temp_3))
+ (a_J6 (fl- a_J4 Temp_2))
+ (a_J7 (fl- a_J5 Temp_3)))
+
+ (f64vector-set! a J0 a_J0)
+ (f64vector-set! a J1 a_J1)
+ (f64vector-set! a J2 a_J2)
+ (f64vector-set! a J3 a_J3)
+ (f64vector-set! a J4 a_J4)
+ (f64vector-set! a J5 a_J5)
+ (f64vector-set! a J6 a_J6)
+ (f64vector-set! a J7 a_J7)
+
+ (J-loop (fx+ J0 2)))))))))
+ (inner-loop (fx+ K 1)
+ (fx+ JFirst (fx* SizeOfGroup 4)))))))))
+
+ (define (recursive-bit M N K SizeOfGroup)
+ (if (fx<= 2 SizeOfGroup)
+ (begin
+ (main-loop M N K SizeOfGroup)
+ (if (fx< 2048 (fx- N M))
+ (let ((new-size (fxarithmetic-shift-right (fx- N M) 2)))
+ (recursive-bit M
+ (fx+ M new-size)
+ (fx* K 4)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M new-size)
+ (fx+ M (fx* new-size 2))
+ (fx+ (fx* K 4) 1)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M (fx* new-size 2))
+ (fx+ M (fx* new-size 3))
+ (fx+ (fx* K 4) 2)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M (fx* new-size 3))
+ N
+ (fx+ (fx* K 4) 3)
+ (fxarithmetic-shift-right SizeOfGroup 2)))
+ (recursive-bit M
+ N
+ (fx* K 4)
+ (fxarithmetic-shift-right SizeOfGroup 2))))))
+
+ (define (radix-2-pass a)
+
+ ;; If we're here, the size of our (conceptually complex)
+ ;; array is not a power of 4, so we need to do a basic radix
+ ;; two pass with w=1 (so W[0]=1.0 and W[1] = 0.) and then
+ ;; call recursive-bit appropriately on the two half arrays.
+
+ (declare (not interrupts-enabled))
+
+ (let ((SizeOfGroup
+ (fxarithmetic-shift-right (f64vector-length a) 1)))
+ (let loop ((J0 0))
+ (if (fx< J0 SizeOfGroup)
+ (let ((J0 J0)
+ (J2 (fx+ J0 SizeOfGroup)))
+ (let ((J1 (fx+ J0 1))
+ (J3 (fx+ J2 1)))
+ (let ((a_J0 (f64vector-ref a J0))
+ (a_J1 (f64vector-ref a J1))
+ (a_J2 (f64vector-ref a J2))
+ (a_J3 (f64vector-ref a J3)))
+ (let ((a_J0 (fl+ a_J0 a_J2))
+ (a_J1 (fl+ a_J1 a_J3))
+ (a_J2 (fl- a_J0 a_J2))
+ (a_J3 (fl- a_J1 a_J3)))
+ (f64vector-set! a J0 a_J0)
+ (f64vector-set! a J1 a_J1)
+ (f64vector-set! a J2 a_J2)
+ (f64vector-set! a J3 a_J3)
+ (loop (fx+ J0 2))))))))))
+
+ (let* ((n (f64vector-length a))
+ (log_n (two^p>=m n)))
+
+ ;; there are n/2 complex entries in a; if n/2 is not a power
+ ;; of 4, then do a single radix-2 pass and do the rest of
+ ;; the passes as radix-4 passes
+
+ (if (fxodd? log_n)
+ (recursive-bit 0 n 0 (fxarithmetic-shift-right n 2))
+ (let ((n/2 (fxarithmetic-shift-right n 1))
+ (n/8 (fxarithmetic-shift-right n 3)))
+ (radix-2-pass a)
+ (recursive-bit 0 n/2 0 n/8)
+ (recursive-bit n/2 n 1 n/8))))))
+
+(define (inverse-fft-recursive-4 a W-table)
+
+ ;; This is an complex fft, using a decimation-in-frequency algorithm
+ ;; with inputs in bit-reversed order and outputs in natural order.
+
+ ;; The organization of the algorithm has little to do with the the
+ ;; associated algorithm on page 41 of Chu and George,
+ ;; I just reversed the operations of the direct algorithm given
+ ;; above (without dividing by 2 each time, so that this has to
+ ;; be "normalized" by dividing by N/2 at the end.
+
+ ;; The table of "twiddle" factors is in bit-reversed order.
+
+ (let ((W (f64vector 0. 0. 0. 0.)))
+
+ (define (main-loop M N K SizeOfGroup)
+ (let inner-loop ((K K)
+ (JFirst M))
+ (if (fx< JFirst N)
+ (let* ((JLast (fx+ JFirst SizeOfGroup)))
+ (if (fxeven? K)
+ (begin
+ (f64vector-set! W 0 (f64vector-ref W-table K))
+ (f64vector-set! W 1 (f64vector-ref W-table (fx+ K 1))))
+ (begin
+ (f64vector-set! W 0 (fl- 0. (f64vector-ref W-table K)))
+ (f64vector-set! W 1 (f64vector-ref W-table (fx- K 1)))))
+ (f64vector-set! W 2 (f64vector-ref W-table (fx* K 2)))
+ (f64vector-set! W 3 (f64vector-ref W-table (fx+ (fx* K 2) 1)))
+ (let J-loop ((J0 JFirst))
+ (if (fx< J0 JLast)
+ (let* ((J0 J0)
+ (J1 (fx+ J0 1))
+ (J2 (fx+ J0 SizeOfGroup))
+ (J3 (fx+ J2 1))
+ (J4 (fx+ J2 SizeOfGroup))
+ (J5 (fx+ J4 1))
+ (J6 (fx+ J4 SizeOfGroup))
+ (J7 (fx+ J6 1)))
+ (let ((W_0 (f64vector-ref W 0))
+ (W_1 (f64vector-ref W 1))
+ (W_2 (f64vector-ref W 2))
+ (W_3 (f64vector-ref W 3))
+ (a_J0 (f64vector-ref a J0))
+ (a_J1 (f64vector-ref a J1))
+ (a_J2 (f64vector-ref a J2))
+ (a_J3 (f64vector-ref a J3))
+ (a_J4 (f64vector-ref a J4))
+ (a_J5 (f64vector-ref a J5))
+ (a_J6 (f64vector-ref a J6))
+ (a_J7 (f64vector-ref a J7)))
+ (let ((W_00 W_2)
+ (W_01 W_3)
+ (W_02 (fl- 0. W_3))
+ (W_03 W_2))
+ (let ((Temp_0 (fl- a_J0 a_J2))
+ (Temp_1 (fl- a_J1 a_J3))
+ (Temp_2 (fl- a_J4 a_J6))
+ (Temp_3 (fl- a_J5 a_J7)))
+ (let ((a_J0 (fl+ a_J0 a_J2))
+ (a_J1 (fl+ a_J1 a_J3))
+ (a_J4 (fl+ a_J4 a_J6))
+ (a_J5 (fl+ a_J5 a_J7))
+ (a_J2 (fl+ (fl* W_00 Temp_0)
+ (fl* W_01 Temp_1)))
+ (a_J3 (fl- (fl* W_00 Temp_1)
+ (fl* W_01 Temp_0)))
+ (a_J6 (fl+ (fl* W_02 Temp_2)
+ (fl* W_03 Temp_3)))
+ (a_J7 (fl- (fl* W_02 Temp_3)
+ (fl* W_03 Temp_2))))
+ (let ((Temp_0 (fl- a_J0 a_J4))
+ (Temp_1 (fl- a_J1 a_J5))
+ (Temp_2 (fl- a_J2 a_J6))
+ (Temp_3 (fl- a_J3 a_J7)))
+ (let ((a_J0 (fl+ a_J0 a_J4))
+ (a_J1 (fl+ a_J1 a_J5))
+ (a_J2 (fl+ a_J2 a_J6))
+ (a_J3 (fl+ a_J3 a_J7))
+ (a_J4 (fl+ (fl* W_0 Temp_0)
+ (fl* W_1 Temp_1)))
+ (a_J5 (fl- (fl* W_0 Temp_1)
+ (fl* W_1 Temp_0)))
+ (a_J6 (fl+ (fl* W_0 Temp_2)
+ (fl* W_1 Temp_3)))
+ (a_J7 (fl- (fl* W_0 Temp_3)
+ (fl* W_1 Temp_2))))
+ (f64vector-set! a J0 a_J0)
+ (f64vector-set! a J1 a_J1)
+ (f64vector-set! a J2 a_J2)
+ (f64vector-set! a J3 a_J3)
+ (f64vector-set! a J4 a_J4)
+ (f64vector-set! a J5 a_J5)
+ (f64vector-set! a J6 a_J6)
+ (f64vector-set! a J7 a_J7)
+ (J-loop (fx+ J0 2)))))))))
+ (inner-loop (fx+ K 1)
+ (fx+ JFirst (fx* SizeOfGroup 4)))))))))
+
+ (define (recursive-bit M N K SizeOfGroup)
+ (if (fx<= 2 SizeOfGroup)
+ (begin
+ (if (fx< 2048 (fx- N M))
+ (let ((new-size (fxarithmetic-shift-right (fx- N M) 2)))
+ (recursive-bit M
+ (fx+ M new-size)
+ (fx* K 4)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M new-size)
+ (fx+ M (fx* new-size 2))
+ (fx+ (fx* K 4) 1)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M (fx* new-size 2))
+ (fx+ M (fx* new-size 3))
+ (fx+ (fx* K 4) 2)
+ (fxarithmetic-shift-right SizeOfGroup 2))
+ (recursive-bit (fx+ M (fx* new-size 3))
+ N
+ (fx+ (fx* K 4) 3)
+ (fxarithmetic-shift-right SizeOfGroup 2)))
+ (recursive-bit M
+ N
+ (fx* K 4)
+ (fxarithmetic-shift-right SizeOfGroup 2)))
+ (main-loop M N K SizeOfGroup))))
+
+ (define (radix-2-pass a)
+ (declare (not interrupts-enabled))
+ (let ((SizeOfGroup
+ (fxarithmetic-shift-right (f64vector-length a) 1)))
+ (let loop ((J0 0))
+ (if (fx< J0 SizeOfGroup)
+ (let ((J0 J0)
+ (J2 (fx+ J0 SizeOfGroup)))
+ (let ((J1 (fx+ J0 1))
+ (J3 (fx+ J2 1)))
+ (let ((a_J0 (f64vector-ref a J0))
+ (a_J1 (f64vector-ref a J1))
+ (a_J2 (f64vector-ref a J2))
+ (a_J3 (f64vector-ref a J3)))
+ (let ((a_J0 (fl+ a_J0 a_J2))
+ (a_J1 (fl+ a_J1 a_J3))
+ (a_J2 (fl- a_J0 a_J2))
+ (a_J3 (fl- a_J1 a_J3)))
+ (f64vector-set! a J0 a_J0)
+ (f64vector-set! a J1 a_J1)
+ (f64vector-set! a J2 a_J2)
+ (f64vector-set! a J3 a_J3)
+ (loop (fx+ J0 2))))))))))
+
+ (let* ((n (f64vector-length a))
+ (log_n (two^p>=m n)))
+ (if (fxodd? log_n)
+ (recursive-bit 0 n 0 (fxarithmetic-shift-right n 2))
+ (let ((n/2 (fxarithmetic-shift-right n 1))
+ (n/8 (fxarithmetic-shift-right n 3)))
+ (recursive-bit 0 n/2 0 n/8)
+ (recursive-bit n/2 n 1 n/8)
+ (radix-2-pass a))))))
+
+(define (two^p>=m m)
+ ;; returns smallest p, assumes fixnum m >= 0
+ (do ((p 0 (fx+ p 1))
+ (two^p 1 (fx* two^p 2)))
+ ((fx<= m two^p) p)))
+
+(define (test iters n)
+ (let ((two^n
+ (expt 2 n))
+ (table
+ (make-w (fx- n 1))))
+ (display (fx* two^n 2))(newline)
+ (let ((a
+ (make-f64vector (fx* two^n 2) 0.)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i iters))
+ (direct-fft-recursive-4 a table)
+ (inverse-fft-recursive-4 a table)))))
+
+(test 1000 11)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index d53c1b91..daf6e9b1 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -207,24 +207,15 @@ echo "======================================== embedding (2) ..."
$compile -e embedded2.scm
./a.out
-echo "======================================== regex benchmarks ..."
-
-cd ../benchmarks/regex
-../../csi -bnq -include-path ../.. benchmark.scm
-cd "${TEST_DIR}"
-
-echo "======================================== benchmarks ..."
-cd ../benchmarks
-for x in `ls *.scm`; do
- case $x in
- "cscbench.scm");;
- "plists.scm");;
- *)
- echo $x
- ../csc $x -compiler $CHICKEN -I.. -L.. -O3 -d0 -prelude '(define-syntax time (syntax-rules () ((_ x) x)))'
- ./`basename $x .scm`;;
- esac
-done
-cd "${TEST_DIR}"
+echo "======================================== timing compilation ..."
+time $compile silex.scm -t -S -O3
+
+echo "======================================== running floating-point benchmark ..."
+echo "boxed:"
+$compile fft.scm -O5
+time ./a.out
+echo "unboxed:"
+$compile fft.scm -O5 -D unboxed
+time ./a.out
echo "======================================== done."
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index b07e1f46..6d58ab98 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -40,9 +40,9 @@ Warning: at toplevel:
assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(procedure car (pair) *)'
Warning: at toplevel:
- expected in operator position of procedure call `((values (quote 1) (quote 2)))' a single result, but were given 2 results
+ expected in `let' binding of `g8' a single result, but were given 2 results
Warning: at toplevel:
- expected in procedure call to `(values (quote 1) (quote 2))' a value of type `(procedure () *)', but were given a value of type `fixnum'
+ expected in procedure call to `g89' a value of type `(procedure () *)', but were given a value of type `fixnum'
Warning: redefinition of standard binding `car'
diff --git a/tests/silex.scm b/tests/silex.scm
new file mode 100644
index 00000000..df550540
--- /dev/null
+++ b/tests/silex.scm
@@ -0,0 +1,6717 @@
+;; Copyright (C) 1997 Danny Dube, Universite de Montreal.
+;; All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+;; conditions are met:
+
+;; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+;; disclaimer.
+;; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
+;; disclaimer in the documentation and/or other materials provided with the distribution.
+;; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+;; products derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+;; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (fixnum)
+ (no-procedure-checks-for-usual-bindings) )
+
+
+(require-library srfi-13)
+
+
+(module silex *
+ (import scheme srfi-13) ; srfi-13 for string-downcase
+
+;----------------------------------------------------------------------------------------------------
+
+(define (string-append-list lst)
+ (let loop1 ((n 0) (x lst) (y '()))
+ (if (pair? x)
+ (let ((s (car x)))
+ (loop1 (+ n (string-length s)) (cdr x) (cons s y)))
+ (let ((result (make-string n #\space)))
+ (let loop2 ((k (- n 1)) (y y))
+ (if (pair? y)
+ (let ((s (car y)))
+ (let loop3 ((i k) (j (- (string-length s) 1)))
+ (if (not (< j 0))
+ (begin
+ (string-set! result i (string-ref s j))
+ (loop3 (- i 1) (- j 1)))
+ (loop2 i (cdr y)))))
+ result))))))
+
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+; Module util.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Quelques definitions de constantes
+;
+
+(define eof-tok 0)
+(define hblank-tok 1)
+(define vblank-tok 2)
+(define pipe-tok 3)
+(define question-tok 4)
+(define plus-tok 5)
+(define star-tok 6)
+(define lpar-tok 7)
+(define rpar-tok 8)
+(define dot-tok 9)
+(define lbrack-tok 10)
+(define lbrack-rbrack-tok 11)
+(define lbrack-caret-tok 12)
+(define lbrack-minus-tok 13)
+(define subst-tok 14)
+(define power-tok 15)
+(define doublequote-tok 16)
+(define char-tok 17)
+(define caret-tok 18)
+(define dollar-tok 19)
+(define <<EOF>>-tok 20)
+(define <<ERROR>>-tok 21)
+(define percent-percent-tok 22)
+(define id-tok 23)
+(define rbrack-tok 24)
+(define minus-tok 25)
+(define illegal-tok 26)
+; Tokens agreges
+(define class-tok 27)
+(define string-tok 28)
+
+(define number-of-tokens 29)
+
+(define newline-ch (char->integer #\newline))
+(define tab-ch (char->integer #\ ))
+(define dollar-ch (char->integer #\$))
+(define minus-ch (char->integer #\-))
+(define rbrack-ch (char->integer #\]))
+(define caret-ch (char->integer #\^))
+
+(define dot-class (list (cons 'inf- (- newline-ch 1))
+ (cons (+ newline-ch 1) 'inf+)))
+
+(define default-action
+ (string-append " (yycontinue)" (string #\newline)))
+(define default-<<EOF>>-action
+ (string-append " '(0)" (string #\newline)))
+(define default-<<ERROR>>-action
+ (string-append " (begin"
+ (string #\newline)
+ " (display \"Error: Invalid token.\")"
+ (string #\newline)
+ " (newline)"
+ (string #\newline)
+ " 'error)"
+ (string #\newline)))
+
+
+
+
+;
+; Fabrication de tables de dispatch
+;
+
+(define make-dispatch-table
+ (lambda (size alist default)
+ (let ((v (make-vector size default)))
+ (let loop ((alist alist))
+ (if (null? alist)
+ v
+ (begin
+ (vector-set! v (caar alist) (cdar alist))
+ (loop (cdr alist))))))))
+
+
+
+
+;
+; Fonctions de manipulation des tokens
+;
+
+(define make-tok
+ (lambda (tok-type lexeme line column . attr)
+ (cond ((null? attr)
+ (vector tok-type line column lexeme))
+ ((null? (cdr attr))
+ (vector tok-type line column lexeme (car attr)))
+ (else
+ (vector tok-type line column lexeme (car attr) (cadr attr))))))
+
+(define get-tok-type (lambda (tok) (vector-ref tok 0)))
+(define get-tok-line (lambda (tok) (vector-ref tok 1)))
+(define get-tok-column (lambda (tok) (vector-ref tok 2)))
+(define get-tok-lexeme (lambda (tok) (vector-ref tok 3)))
+(define get-tok-attr (lambda (tok) (vector-ref tok 4)))
+(define get-tok-2nd-attr (lambda (tok) (vector-ref tok 5)))
+
+
+
+
+;
+; Fonctions de manipulations des regles
+;
+
+(define make-rule
+ (lambda (line eof? error? bol? eol? regexp action)
+ (vector line eof? error? bol? eol? regexp action #f)))
+
+(define get-rule-line (lambda (rule) (vector-ref rule 0)))
+(define get-rule-eof? (lambda (rule) (vector-ref rule 1)))
+(define get-rule-error? (lambda (rule) (vector-ref rule 2)))
+(define get-rule-bol? (lambda (rule) (vector-ref rule 3)))
+(define get-rule-eol? (lambda (rule) (vector-ref rule 4)))
+(define get-rule-regexp (lambda (rule) (vector-ref rule 5)))
+(define get-rule-action (lambda (rule) (vector-ref rule 6)))
+(define get-rule-yytext? (lambda (rule) (vector-ref rule 7)))
+
+(define set-rule-regexp (lambda (rule regexp) (vector-set! rule 5 regexp)))
+(define set-rule-action (lambda (rule action) (vector-set! rule 6 action)))
+(define set-rule-yytext? (lambda (rule yytext?) (vector-set! rule 7 yytext?)))
+
+
+
+
+;
+; Noeuds des regexp
+;
+
+(define epsilon-re 0)
+(define or-re 1)
+(define conc-re 2)
+(define star-re 3)
+(define plus-re 4)
+(define question-re 5)
+(define class-re 6)
+(define char-re 7)
+
+(define make-re
+ (lambda (re-type . lattr)
+ (cond ((null? lattr)
+ (vector re-type))
+ ((null? (cdr lattr))
+ (vector re-type (car lattr)))
+ ((null? (cddr lattr))
+ (vector re-type (car lattr) (cadr lattr))))))
+
+(define get-re-type (lambda (re) (vector-ref re 0)))
+(define get-re-attr1 (lambda (re) (vector-ref re 1)))
+(define get-re-attr2 (lambda (re) (vector-ref re 2)))
+
+
+
+
+;
+; Fonctions de manipulation des ensembles d'etats
+;
+
+; Intersection de deux ensembles d'etats
+(define ss-inter
+ (lambda (ss1 ss2)
+ (cond ((null? ss1)
+ '())
+ ((null? ss2)
+ '())
+ (else
+ (let ((t1 (car ss1))
+ (t2 (car ss2)))
+ (cond ((< t1 t2)
+ (ss-inter (cdr ss1) ss2))
+ ((= t1 t2)
+ (cons t1 (ss-inter (cdr ss1) (cdr ss2))))
+ (else
+ (ss-inter ss1 (cdr ss2)))))))))
+
+; Difference entre deux ensembles d'etats
+(define ss-diff
+ (lambda (ss1 ss2)
+ (cond ((null? ss1)
+ '())
+ ((null? ss2)
+ ss1)
+ (else
+ (let ((t1 (car ss1))
+ (t2 (car ss2)))
+ (cond ((< t1 t2)
+ (cons t1 (ss-diff (cdr ss1) ss2)))
+ ((= t1 t2)
+ (ss-diff (cdr ss1) (cdr ss2)))
+ (else
+ (ss-diff ss1 (cdr ss2)))))))))
+
+; Union de deux ensembles d'etats
+(define ss-union
+ (lambda (ss1 ss2)
+ (cond ((null? ss1)
+ ss2)
+ ((null? ss2)
+ ss1)
+ (else
+ (let ((t1 (car ss1))
+ (t2 (car ss2)))
+ (cond ((< t1 t2)
+ (cons t1 (ss-union (cdr ss1) ss2)))
+ ((= t1 t2)
+ (cons t1 (ss-union (cdr ss1) (cdr ss2))))
+ (else
+ (cons t2 (ss-union ss1 (cdr ss2))))))))))
+
+; Decoupage de deux ensembles d'etats
+(define ss-sep
+ (lambda (ss1 ss2)
+ (let loop ((ss1 ss1) (ss2 ss2) (l '()) (c '()) (r '()))
+ (if (null? ss1)
+ (if (null? ss2)
+ (vector (reverse l) (reverse c) (reverse r))
+ (loop ss1 (cdr ss2) l c (cons (car ss2) r)))
+ (if (null? ss2)
+ (loop (cdr ss1) ss2 (cons (car ss1) l) c r)
+ (let ((t1 (car ss1))
+ (t2 (car ss2)))
+ (cond ((< t1 t2)
+ (loop (cdr ss1) ss2 (cons t1 l) c r))
+ ((= t1 t2)
+ (loop (cdr ss1) (cdr ss2) l (cons t1 c) r))
+ (else
+ (loop ss1 (cdr ss2) l c (cons t2 r))))))))))
+
+
+
+
+;
+; Fonctions de manipulation des classes de caracteres
+;
+
+; Comparaisons de bornes d'intervalles
+(define class-= eqv?)
+
+(define class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+
+(define class->=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #t)
+ ((eq? b2 'inf-) #t)
+ ((eq? b1 'inf-) #f)
+ ((eq? b2 'inf+) #f)
+ (else (>= b1 b2)))))
+
+(define class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+
+(define class->
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #f)
+ ((eq? b2 'inf+) #f)
+ ((eq? b1 'inf+) #t)
+ ((eq? b2 'inf-) #t)
+ (else (> b1 b2)))))
+
+; Complementation d'une classe
+(define class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (if (class-< rend 'inf+)
+ (loop (cdr c) (+ rend 1))
+ '())))))))
+
+; Union de deux classes de caracteres
+(define class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (class-<= r1start r2start)
+ (cond ((class-= r1end 'inf+)
+ (loop c1 (cdr c2) u))
+ ((class-< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((class-<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((class-= r2end 'inf+)
+ (loop (cdr c1) c2 u))
+ ((class-> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((class->= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+
+; Decoupage de deux classes de caracteres
+(define class-sep
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (l '()) (c '()) (r '()))
+ (if (null? c1)
+ (if (null? c2)
+ (vector (reverse l) (reverse c) (reverse r))
+ (loop c1 (cdr c2) l c (cons (car c2) r)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) l) c r)
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (cond ((class-< r1start r2start)
+ (if (class-< r1end r2start)
+ (loop (cdr c1) c2 (cons r1 l) c r)
+ (loop (cons (cons r2start r1end) (cdr c1)) c2
+ (cons (cons r1start (- r2start 1)) l) c r)))
+ ((class-> r1start r2start)
+ (if (class-> r1start r2end)
+ (loop c1 (cdr c2) l c (cons r2 r))
+ (loop c1 (cons (cons r1start r2end) (cdr c2))
+ l c (cons (cons r2start (- r1start 1)) r))))
+ (else
+ (cond ((class-< r1end r2end)
+ (loop (cdr c1)
+ (cons (cons (+ r1end 1) r2end) (cdr c2))
+ l (cons r1 c) r))
+ ((class-= r1end r2end)
+ (loop (cdr c1) (cdr c2) l (cons r1 c) r))
+ (else
+ (loop (cons (cons (+ r2end 1) r1end) (cdr c1))
+ (cdr c2)
+ l (cons r2 c) r)))))))))))
+
+; Transformer une classe (finie) de caracteres en une liste de ...
+(define class->char-list
+ (lambda (c)
+ (let loop1 ((c c))
+ (if (null? c)
+ '()
+ (let* ((r (car c))
+ (rend (cdr r))
+ (tail (loop1 (cdr c))))
+ (let loop2 ((rstart (car r)))
+ (if (<= rstart rend)
+ (cons (integer->char rstart) (loop2 (+ rstart 1)))
+ tail)))))))
+
+; Transformer une classe de caracteres en une liste poss. compl.
+; 1er element = #t -> classe complementee
+(define class->tagged-char-list
+ (lambda (c)
+ (let* ((finite? (or (null? c) (number? (caar c))))
+ (c2 (if finite? c (class-compl c)))
+ (c-l (class->char-list c2)))
+ (cons (not finite?) c-l))))
+
+
+
+
+;
+; Fonction digraph
+;
+
+; Fonction "digraph".
+; Etant donne un graphe dirige dont les noeuds comportent une valeur,
+; calcule pour chaque noeud la "somme" des valeurs contenues dans le
+; noeud lui-meme et ceux atteignables a partir de celui-ci. La "somme"
+; consiste a appliquer un operateur commutatif et associatif aux valeurs
+; lorsqu'elles sont additionnees.
+; L'entree consiste en un vecteur de voisinages externes, un autre de
+; valeurs initiales et d'un operateur.
+; La sortie est un vecteur de valeurs finales.
+(define digraph
+ (lambda (arcs init op)
+ (let* ((nbnodes (vector-length arcs))
+ (infinity nbnodes)
+ (prio (make-vector nbnodes -1))
+ (stack (make-vector nbnodes #f))
+ (sp 0)
+ (final (make-vector nbnodes #f)))
+ (letrec ((store-final
+ (lambda (self-sp value)
+ (let loop ()
+ (if (> sp self-sp)
+ (let ((voisin (vector-ref stack (- sp 1))))
+ (vector-set! prio voisin infinity)
+ (set! sp (- sp 1))
+ (vector-set! final voisin value)
+ (loop))))))
+ (visit-node
+ (lambda (n)
+ (let ((self-sp sp))
+ (vector-set! prio n self-sp)
+ (vector-set! stack sp n)
+ (set! sp (+ sp 1))
+ (vector-set! final n (vector-ref init n))
+ (let loop ((vois (vector-ref arcs n)))
+ (if (pair? vois)
+ (let* ((v (car vois))
+ (vprio (vector-ref prio v)))
+ (if (= vprio -1)
+ (visit-node v))
+ (vector-set! prio n (min (vector-ref prio n)
+ (vector-ref prio v)))
+ (vector-set! final n (op (vector-ref final n)
+ (vector-ref final v)))
+ (loop (cdr vois)))))
+ (if (= (vector-ref prio n) self-sp)
+ (store-final self-sp (vector-ref final n)))))))
+ (let loop ((n 0))
+ (if (< n nbnodes)
+ (begin
+ (if (= (vector-ref prio n) -1)
+ (visit-node n))
+ (loop (+ n 1)))))
+ final))))
+
+
+
+
+;
+; Fonction de tri
+;
+
+(define merge-sort-merge
+ (lambda (l1 l2 cmp-<=)
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((h1 (car l1))
+ (h2 (car l2)))
+ (if (cmp-<= h1 h2)
+ (cons h1 (merge-sort-merge (cdr l1) l2 cmp-<=))
+ (cons h2 (merge-sort-merge l1 (cdr l2) cmp-<=))))))))
+
+(define merge-sort
+ (lambda (l cmp-<=)
+ (if (null? l)
+ l
+ (let loop1 ((ll (map list l)))
+ (if (null? (cdr ll))
+ (car ll)
+ (loop1
+ (let loop2 ((ll ll))
+ (cond ((null? ll)
+ ll)
+ ((null? (cdr ll))
+ ll)
+ (else
+ (cons (merge-sort-merge (car ll) (cadr ll) cmp-<=)
+ (loop2 (cddr ll))))))))))))
+
+; Module action.l.scm.
+;
+; Table generated from the file action.l by SILex 1.0
+;
+
+(define action-tables
+ (vector
+ 'all
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok eof-tok yytext yyline yycolumn)
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (begin
+ (display "Error: Invalid token.")
+ (newline)
+ 'error)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok hblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok vblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok char-tok yytext yyline yycolumn)
+ )))
+ 'tagged-chars-lists
+ 0
+ 0
+ '#((((#f #\ #\space) . 4)
+ ((#f #\;) . 3)
+ ((#f #\newline) . 2)
+ ((#t #\ #\newline #\space #\;) . 1))
+ (((#t #\newline) . 1))
+ ()
+ (((#t #\newline) . 3))
+ (((#f #\ #\space) . 4)
+ ((#f #\;) . 3)
+ ((#t #\ #\newline #\space #\;) . 1)))
+ '#((#f . #f) (2 . 2) (1 . 1) (0 . 0) (0 . 0))))
+
+; Module class.l.scm.
+;
+; Table generated from the file class.l by SILex 1.0
+;
+
+(define class-tables
+ (vector
+ 'all
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok eof-tok yytext yyline yycolumn)
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (begin
+ (display "Error: Invalid token.")
+ (newline)
+ 'error)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok rbrack-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok minus-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-spec-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-quoted-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-ordinary-char yytext yyline yycolumn)
+ )))
+ 'tagged-chars-lists
+ 0
+ 0
+ '#((((#f #\]) . 4) ((#f #\-) . 3) ((#f #\\) . 2) ((#t #\- #\\ #\]) . 1))
+ ()
+ (((#f #\n) . 8)
+ ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 7)
+ ((#f #\-) . 6)
+ ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 5))
+ ()
+ ()
+ ()
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10))
+ ()
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10)))
+ '#((#f . #f) (6 . 6) (6 . 6) (1 . 1) (0 . 0) (5 . 5) (5 . 5)
+ (3 . 3) (2 . 2) (4 . 4) (3 . 3))))
+
+; Module macro.l.scm.
+;
+; Table generated from the file macro.l by SILex 1.0
+;
+
+(define macro-tables
+ (vector
+ 'all
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok eof-tok yytext yyline yycolumn)
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (begin
+ (display "Error: Invalid token.")
+ (newline)
+ 'error)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok hblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok vblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok percent-percent-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-id yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok illegal-tok yytext yyline yycolumn)
+ )))
+ 'tagged-chars-lists
+ 0
+ 0
+ '#((((#f #\ #\space) . 8)
+ ((#f #\;) . 7)
+ ((#f #\newline) . 6)
+ ((#f #\%) . 5)
+ ((#f #\! #\$ #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E
+ #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U
+ #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i
+ #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y
+ #\z #\~)
+ .
+ 4)
+ ((#f #\+ #\-) . 3)
+ ((#f #\.) . 2)
+ ((#t #\ #\newline #\space #\! #\$
+ #\% #\& #\* #\+ #\- #\.
+ #\/ #\: #\; #\< #\= #\>
+ #\? #\A #\B #\C #\D #\E
+ #\F #\G #\H #\I #\J #\K
+ #\L #\M #\N #\O #\P #\Q
+ #\R #\S #\T #\U #\V #\W
+ #\X #\Y #\Z #\^ #\_ #\a
+ #\b #\c #\d #\e #\f #\g
+ #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s
+ #\t #\u #\v #\w #\x #\y
+ #\z #\~)
+ .
+ 1))
+ ()
+ (((#f #\.) . 9))
+ ()
+ (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+ #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+ #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+ #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+ #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+ .
+ 10))
+ (((#f #\%) . 11)
+ ((#f #\! #\$ #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6
+ #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G #\H
+ #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X
+ #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l
+ #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+ .
+ 10))
+ ()
+ (((#t #\newline) . 12))
+ ()
+ (((#f #\.) . 13))
+ (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+ #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+ #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+ #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+ #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+ .
+ 10))
+ (((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+ #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+ #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+ #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+ #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+ .
+ 10))
+ (((#t #\newline) . 12))
+ ())
+ '#((#f . #f) (4 . 4) (4 . 4) (3 . 3) (3 . 3) (3 . 3) (1 . 1)
+ (0 . 0) (0 . 0) (#f . #f) (3 . 3) (2 . 2) (0 . 0) (3 . 3))))
+
+; Module regexp.l.scm.
+;
+; Table generated from the file regexp.l by SILex 1.0
+;
+
+(define regexp-tables
+ (vector
+ 'all
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok eof-tok yytext yyline yycolumn)
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (begin
+ (display "Error: Invalid token.")
+ (newline)
+ 'error)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok hblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok vblank-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok pipe-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok question-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok plus-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok star-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok lpar-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok rpar-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok dot-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok lbrack-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok lbrack-rbrack-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok lbrack-caret-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok lbrack-minus-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-id-ref yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-power-m yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-power-m-inf yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-power-m-n yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok illegal-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok doublequote-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-spec-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-quoted-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok caret-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok dollar-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-ordinary-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok <<EOF>>-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok <<ERROR>>-tok yytext yyline yycolumn)
+ )))
+ 'tagged-chars-lists
+ 0
+ 0
+ '#((((#f #\ #\space) . 18)
+ ((#f #\;) . 17)
+ ((#f #\newline) . 16)
+ ((#f #\|) . 15)
+ ((#f #\?) . 14)
+ ((#f #\+) . 13)
+ ((#f #\*) . 12)
+ ((#f #\() . 11)
+ ((#f #\)) . 10)
+ ((#f #\.) . 9)
+ ((#f #\[) . 8)
+ ((#f #\{) . 7)
+ ((#f #\") . 6)
+ ((#f #\\) . 5)
+ ((#f #\^) . 4)
+ ((#f #\$) . 3)
+ ((#t #\ #\newline #\space #\" #\$
+ #\( #\) #\* #\+ #\. #\;
+ #\< #\? #\[ #\\ #\^ #\{
+ #\|)
+ .
+ 2)
+ ((#f #\<) . 1))
+ (((#f #\<) . 19))
+ ()
+ ()
+ ()
+ (((#f #\n) . 23)
+ ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 22)
+ ((#f #\-) . 21)
+ ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 20))
+ ()
+ (((#f #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D
+ #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
+ #\U #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h
+ #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
+ #\y #\z #\~)
+ .
+ 27)
+ ((#f #\+ #\-) . 26)
+ ((#f #\.) . 25)
+ ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24))
+ (((#f #\]) . 30) ((#f #\^) . 29) ((#f #\-) . 28))
+ ()
+ ()
+ ()
+ ()
+ ()
+ ()
+ ()
+ ()
+ (((#t #\newline) . 31))
+ ()
+ (((#f #\E) . 32))
+ ()
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
+ ()
+ (((#f #\}) . 36)
+ ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24)
+ ((#f #\,) . 35))
+ (((#f #\.) . 37))
+ (((#f #\}) . 38))
+ (((#f #\}) . 38)
+ ((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+ #\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
+ #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
+ #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
+ #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
+ .
+ 27))
+ ()
+ ()
+ ()
+ (((#t #\newline) . 31))
+ (((#f #\O) . 40) ((#f #\R) . 39))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
+ (((#f #\}) . 42) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
+ ()
+ (((#f #\.) . 26))
+ ()
+ (((#f #\R) . 43))
+ (((#f #\F) . 44))
+ (((#f #\}) . 45) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
+ ()
+ (((#f #\O) . 46))
+ (((#f #\>) . 47))
+ ()
+ (((#f #\R) . 48))
+ (((#f #\>) . 49))
+ (((#f #\>) . 50))
+ ()
+ (((#f #\>) . 51))
+ ())
+ '#((#f . #f) (25 . 25) (25 . 25) (24 . 24) (23 . 23) (25 . 25) (18 . 18)
+ (17 . 17) (9 . 9) (8 . 8) (7 . 7) (6 . 6) (5 . 5) (4 . 4)
+ (3 . 3) (2 . 2) (1 . 1) (0 . 0) (0 . 0) (#f . #f) (22 . 22)
+ (22 . 22) (20 . 20) (19 . 19) (#f . #f) (#f . #f) (#f . #f) (#f . #f)
+ (12 . 12) (11 . 11) (10 . 10) (0 . 0) (#f . #f) (21 . 21) (20 . 20)
+ (#f . #f) (14 . 14) (#f . #f) (13 . 13) (#f . #f) (#f . #f) (#f . #f)
+ (15 . 15) (#f . #f) (#f . #f) (16 . 16) (#f . #f) (#f . #f) (#f . #f)
+ (26 . 26) (#f . #f) (27 . 27))))
+
+; Module string.l.scm.
+;
+; Table generated from the file string.l by SILex 1.0
+;
+
+(define string-tables
+ (vector
+ 'all
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok eof-tok yytext yyline yycolumn)
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (begin
+ (display "Error: Invalid token.")
+ (newline)
+ 'error)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (make-tok doublequote-tok yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-spec-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-digits-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-quoted-char yytext yyline yycolumn)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline yycolumn yyoffset)
+ (parse-ordinary-char yytext yyline yycolumn)
+ )))
+ 'tagged-chars-lists
+ 0
+ 0
+ '#((((#f #\") . 3) ((#f #\\) . 2) ((#t #\" #\\) . 1))
+ ()
+ (((#f #\n) . 7)
+ ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 6)
+ ((#f #\-) . 5)
+ ((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 4))
+ ()
+ ()
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
+ ()
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
+ (((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9)))
+ '#((#f . #f) (5 . 5) (5 . 5) (0 . 0) (4 . 4) (4 . 4) (2 . 2)
+ (1 . 1) (3 . 3) (2 . 2))))
+
+; Module multilex.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+ (lambda (buffer read-ptr input-f counters)
+ (let ((input-f input-f) ; Entree reelle
+ (buffer buffer) ; Buffer
+ (buflen (string-length buffer))
+ (read-ptr read-ptr)
+ (start-ptr 1) ; Marque de debut de lexeme
+ (start-line 1)
+ (start-column 1)
+ (start-offset 0)
+ (end-ptr 1) ; Marque de fin de lexeme
+ (point-ptr 1) ; Le point
+ (user-ptr 1) ; Marque de l'usager
+ (user-line 1)
+ (user-column 1)
+ (user-offset 0)
+ (user-up-to-date? #t)) ; Concerne la colonne seul.
+ (letrec
+ ((start-go-to-end-none ; Fonctions de depl. des marques
+ (lambda ()
+ (set! start-ptr end-ptr)))
+ (start-go-to-end-line
+ (lambda ()
+ (let loop ((ptr start-ptr) (line start-line))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1))
+ (loop (+ ptr 1) line))))))
+ (start-go-to-end-all
+ (lambda ()
+ (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+ (let loop ((ptr start-ptr)
+ (line start-line)
+ (column start-column))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1) 1)
+ (loop (+ ptr 1) line (+ column 1)))))))
+ (start-go-to-user-none
+ (lambda ()
+ (set! start-ptr user-ptr)))
+ (start-go-to-user-line
+ (lambda ()
+ (set! start-ptr user-ptr)
+ (set! start-line user-line)))
+ (start-go-to-user-all
+ (lambda ()
+ (set! start-line user-line)
+ (set! start-offset user-offset)
+ (if user-up-to-date?
+ (begin
+ (set! start-ptr user-ptr)
+ (set! start-column user-column))
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1))))))))
+ (end-go-to-point
+ (lambda ()
+ (set! end-ptr point-ptr)))
+ (point-go-to-start
+ (lambda ()
+ (set! point-ptr start-ptr)))
+ (user-go-to-start-none
+ (lambda ()
+ (set! user-ptr start-ptr)))
+ (user-go-to-start-line
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)))
+ (user-go-to-start-all
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)
+ (set! user-column start-column)
+ (set! user-offset start-offset)
+ (set! user-up-to-date? #t)))
+ (init-lexeme-none ; Debute un nouveau lexeme
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-none))
+ (point-go-to-start)))
+ (init-lexeme-line
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-line))
+ (point-go-to-start)))
+ (init-lexeme-all
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-all))
+ (point-go-to-start)))
+ (get-start-line ; Obtention des stats du debut du lxm
+ (lambda ()
+ start-line))
+ (get-start-column
+ (lambda ()
+ start-column))
+ (get-start-offset
+ (lambda ()
+ start-offset))
+ (peek-left-context ; Obtention de caracteres (#f si EOF)
+ (lambda ()
+ (char->integer (string-ref buffer (- start-ptr 1)))))
+ (peek-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (char->integer (string-ref buffer point-ptr))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (read-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (let ((c (string-ref buffer point-ptr)))
+ (set! point-ptr (+ point-ptr 1))
+ (char->integer c))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (set! point-ptr read-ptr)
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (get-start-end-text ; Obtention du lexeme
+ (lambda ()
+ (substring buffer start-ptr end-ptr)))
+ (get-user-line-line ; Fonctions pour l'usager
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ user-line))
+ (get-user-line-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-line))
+ (get-user-column-all
+ (lambda ()
+ (cond ((< user-ptr start-ptr)
+ (user-go-to-start-all)
+ user-column)
+ (user-up-to-date?
+ user-column)
+ (else
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! user-column column)
+ (set! user-up-to-date? #t)
+ column)
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1)))))))))
+ (get-user-offset-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-offset))
+ (user-getc-none
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-none))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-line
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-ungetc-none
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (set! user-ptr (- user-ptr 1)))))
+ (user-ungetc-line
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (set! user-line (- user-line 1))))))))
+ (user-ungetc-all
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (- user-line 1))
+ (set! user-up-to-date? #f))
+ (set! user-column (- user-column 1)))
+ (set! user-offset (- user-offset 1)))))))
+ (reorganize-buffer ; Decaler ou agrandir le buffer
+ (lambda ()
+ (if (< (* 2 start-ptr) buflen)
+ (let* ((newlen (* 2 buflen))
+ (newbuf (make-string newlen))
+ (delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! newbuf
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! buffer newbuf)
+ (set! buflen newlen)
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))
+ (let ((delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! buffer
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))))))
+ (list (cons 'start-go-to-end
+ (cond ((eq? counters 'none) start-go-to-end-none)
+ ((eq? counters 'line) start-go-to-end-line)
+ ((eq? counters 'all ) start-go-to-end-all)))
+ (cons 'end-go-to-point
+ end-go-to-point)
+ (cons 'init-lexeme
+ (cond ((eq? counters 'none) init-lexeme-none)
+ ((eq? counters 'line) init-lexeme-line)
+ ((eq? counters 'all ) init-lexeme-all)))
+ (cons 'get-start-line
+ get-start-line)
+ (cons 'get-start-column
+ get-start-column)
+ (cons 'get-start-offset
+ get-start-offset)
+ (cons 'peek-left-context
+ peek-left-context)
+ (cons 'peek-char
+ peek-char)
+ (cons 'read-char
+ read-char)
+ (cons 'get-start-end-text
+ get-start-end-text)
+ (cons 'get-user-line
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) get-user-line-line)
+ ((eq? counters 'all ) get-user-line-all)))
+ (cons 'get-user-column
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-column-all)))
+ (cons 'get-user-offset
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-offset-all)))
+ (cons 'user-getc
+ (cond ((eq? counters 'none) user-getc-none)
+ ((eq? counters 'line) user-getc-line)
+ ((eq? counters 'all ) user-getc-all)))
+ (cons 'user-ungetc
+ (cond ((eq? counters 'none) user-ungetc-none)
+ ((eq? counters 'line) user-ungetc-line)
+ ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+ (lambda (input-type input . largs)
+ (let ((counters-type (cond ((null? largs)
+ 'line)
+ ((memq (car largs) '(none line all))
+ (car largs))
+ (else
+ 'line))))
+ (cond ((and (eq? input-type 'port) (input-port? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f (lambda () (read-char input))))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'procedure) (procedure? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f input))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'string) (string? input))
+ (let* ((buffer (string-append (string #\newline) input))
+ (read-ptr (string-length buffer))
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ (else
+ (let* ((buffer (string #\newline))
+ (read-ptr 1)
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+; lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+ (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+ (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+ (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+ (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+ (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+ (lambda (tables IS)
+ (letrec
+ (; Contenu de la table
+ (counters-type (vector-ref tables 0))
+ (<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-actions (vector-ref tables 3))
+ (table-nl-start (vector-ref tables 5))
+ (table-no-nl-start (vector-ref tables 6))
+ (trees-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8))
+
+ ; Contenu du IS
+ (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
+ (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
+ (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
+ (IS-get-start-line (cdr (assq 'get-start-line IS)))
+ (IS-get-start-column (cdr (assq 'get-start-column IS)))
+ (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
+ (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
+ (IS-peek-char (cdr (assq 'peek-char IS)))
+ (IS-read-char (cdr (assq 'read-char IS)))
+ (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+ (IS-get-user-line (cdr (assq 'get-user-line IS)))
+ (IS-get-user-column (cdr (assq 'get-user-column IS)))
+ (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
+ (IS-user-getc (cdr (assq 'user-getc IS)))
+ (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
+
+ ; Resultats
+ (<<EOF>>-action #f)
+ (<<ERROR>>-action #f)
+ (rules-actions #f)
+ (states #f)
+ (final-lexer #f)
+
+ ; Gestion des hooks
+ (hook-list '())
+ (add-hook
+ (lambda (thunk)
+ (set! hook-list (cons thunk hook-list))))
+ (apply-hooks
+ (lambda ()
+ (let loop ((l hook-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))))
+
+ ; Preparation des actions
+ (set-action-statics
+ (lambda (pre-action)
+ (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+ (prepare-special-action-none
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda ()
+ (action "")))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-line
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline)
+ (action "" yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-all
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (action "" yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-special-action-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-special-action-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-special-action-all pre-action)))))
+ (prepare-action-yytext-none
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-line
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-all
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline yycolumn yyoffset))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-yytext-all pre-action)))))
+ (prepare-action-no-yytext-none
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (start-go-to-end)
+ (action)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-line
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (start-go-to-end)
+ (action yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-all
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (start-go-to-end)
+ (action yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-no-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-no-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-no-yytext-all pre-action)))))
+
+ ; Fabrique les fonctions de dispatch
+ (prepare-dispatch-err
+ (lambda (leaf)
+ (lambda (c)
+ #f)))
+ (prepare-dispatch-number
+ (lambda (leaf)
+ (let ((state-function #f))
+ (let ((result
+ (lambda (c)
+ state-function))
+ (hook
+ (lambda ()
+ (set! state-function (vector-ref states leaf)))))
+ (add-hook hook)
+ result))))
+ (prepare-dispatch-leaf
+ (lambda (leaf)
+ (if (eq? leaf 'err)
+ (prepare-dispatch-err leaf)
+ (prepare-dispatch-number leaf))))
+ (prepare-dispatch-<
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 1))
+ (right-tree (list-ref tree 2)))
+ (let ((bound (list-ref tree 0))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (< c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-=
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 2))
+ (right-tree (list-ref tree 3)))
+ (let ((bound (list-ref tree 1))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (= c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-tree
+ (lambda (tree)
+ (cond ((not (pair? tree))
+ (prepare-dispatch-leaf tree))
+ ((eq? (car tree) '=)
+ (prepare-dispatch-= tree))
+ (else
+ (prepare-dispatch-< tree)))))
+ (prepare-dispatch
+ (lambda (tree)
+ (let ((dicho-func (prepare-dispatch-tree tree)))
+ (lambda (c)
+ (and c (dicho-func c))))))
+
+ ; Fabrique les fonctions de transition (read & go) et (abort)
+ (prepare-read-n-go
+ (lambda (tree)
+ (let ((dispatch-func (prepare-dispatch tree))
+ (read-char IS-read-char))
+ (lambda ()
+ (dispatch-func (read-char))))))
+ (prepare-abort
+ (lambda (tree)
+ (lambda ()
+ #f)))
+ (prepare-transition
+ (lambda (tree)
+ (if (eq? tree 'err)
+ (prepare-abort tree)
+ (prepare-read-n-go tree))))
+
+ ; Fabrique les fonctions d'etats ([set-end] & trans)
+ (prepare-state-no-acc
+ (lambda (s r1 r2)
+ (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+ (lambda (action)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state action)
+ action))))))
+ (prepare-state-yes-no
+ (lambda (s r1 r2)
+ (let ((peek-char IS-peek-char)
+ (end-go-to-point IS-end-go-to-point)
+ (new-action1 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ (begin
+ (end-go-to-point)
+ new-action1)
+ action))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-diff-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (peek-char IS-peek-char)
+ (new-action1 #f)
+ (new-action2 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ new-action1
+ new-action2))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1))
+ (set! new-action2 (vector-ref rules-actions r2)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-same-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (trans-func (prepare-transition (vector-ref trees-v s)))
+ (new-action #f))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state
+ (lambda (s)
+ (let* ((acc (vector-ref acc-v s))
+ (r1 (car acc))
+ (r2 (cdr acc)))
+ (cond ((not r1) (prepare-state-no-acc s r1 r2))
+ ((not r2) (prepare-state-yes-no s r1 r2))
+ ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+ (else (prepare-state-same-acc s r1 r2))))))
+
+ ; Fabrique la fonction de lancement du lexage a l'etat de depart
+ (prepare-start-same
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (start-state #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (if (not (peek-char))
+ eof-action
+ (start-state error-action))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state (vector-ref states s1))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start-diff
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (peek-left-context IS-peek-left-context)
+ (start-state1 #f)
+ (start-state2 #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (cond ((not (peek-char))
+ eof-action)
+ ((= (peek-left-context) lexer-integer-newline)
+ (start-state1 error-action))
+ (else
+ (start-state2 error-action)))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state1 (vector-ref states s1))
+ (set! start-state2 (vector-ref states s2))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start
+ (lambda ()
+ (let ((s1 table-nl-start)
+ (s2 table-no-nl-start))
+ (if (= s1 s2)
+ (prepare-start-same s1 s2)
+ (prepare-start-diff s1 s2)))))
+
+ ; Fabrique la fonction principale
+ (prepare-lexer-none
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ ((start-func))))))
+ (prepare-lexer-line
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line)))
+ ((start-func) yyline))))))
+ (prepare-lexer-all
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (get-start-column IS-get-start-column)
+ (get-start-offset IS-get-start-offset)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line))
+ (yycolumn (get-start-column))
+ (yyoffset (get-start-offset)))
+ ((start-func) yyline yycolumn yyoffset))))))
+ (prepare-lexer
+ (lambda ()
+ (cond ((eq? counters-type 'none) (prepare-lexer-none))
+ ((eq? counters-type 'line) (prepare-lexer-line))
+ ((eq? counters-type 'all) (prepare-lexer-all))))))
+
+ ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+ (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
+ (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+ ; Calculer la valeur de rules-actions
+ (let* ((len (quotient (vector-length rules-pre-actions) 2))
+ (v (make-vector len)))
+ (let loop ((r (- len 1)))
+ (if (< r 0)
+ (set! rules-actions v)
+ (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+ (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+ (action (if yytext?
+ (prepare-action-yytext pre-action)
+ (prepare-action-no-yytext pre-action))))
+ (vector-set! v r action)
+ (loop (- r 1))))))
+
+ ; Calculer la valeur de states
+ (let* ((len (vector-length trees-v))
+ (v (make-vector len)))
+ (let loop ((s (- len 1)))
+ (if (< s 0)
+ (set! states v)
+ (begin
+ (vector-set! v s (prepare-state s))
+ (loop (- s 1))))))
+
+ ; Calculer la valeur de final-lexer
+ (set! final-lexer (prepare-lexer))
+
+ ; Executer les hooks
+ (apply-hooks)
+
+ ; Resultat
+ final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+ (let* ((char->class
+ (lambda (c)
+ (let ((n (char->integer c)))
+ (list (cons n n)))))
+ (merge-sort
+ (lambda (l combine zero-elt)
+ (if (null? l)
+ zero-elt
+ (let loop1 ((l l))
+ (if (null? (cdr l))
+ (car l)
+ (loop1
+ (let loop2 ((l l))
+ (cond ((null? l)
+ l)
+ ((null? (cdr l))
+ l)
+ (else
+ (cons (combine (car l) (cadr l))
+ (loop2 (cddr l))))))))))))
+ (finite-class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (<= r1start r2start)
+ (cond ((< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((>= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+ (char-list->class
+ (lambda (cl)
+ (let ((classes (map char->class cl)))
+ (merge-sort classes finite-class-union '()))))
+ (class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+ (finite-class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (loop (cdr c) (+ rend 1))))))))
+ (tagged-chars->class
+ (lambda (tcl)
+ (let* ((inverse? (car tcl))
+ (cl (cdr tcl))
+ (class-tmp (char-list->class cl)))
+ (if inverse? (finite-class-compl class-tmp) class-tmp))))
+ (charc->arc
+ (lambda (charc)
+ (let* ((tcl (car charc))
+ (dest (cdr charc))
+ (class (tagged-chars->class tcl)))
+ (cons class dest))))
+ (arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+ (class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+ (sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+ (merge-sharcs
+ (lambda (l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((sharc1 (car l1))
+ (sharc2 (car l2)))
+ (if (sharc-<= sharc1 sharc2)
+ (cons sharc1 (loop (cdr l1) l2))
+ (cons sharc2 (loop l1 (cdr l2))))))))))
+ (class-= eqv?)
+ (fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err)
+ (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err)
+ (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+ (charcs->tree
+ (lambda (charcs)
+ (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+ (sharcs-l (map op charcs))
+ (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+ (full-sharcs (fill-error sorted-sharcs))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op full-sharcs))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right))))))))))
+ (lambda (tables IS)
+ (let ((counters (vector-ref tables 0))
+ (<<EOF>>-action (vector-ref tables 1))
+ (<<ERROR>>-action (vector-ref tables 2))
+ (rules-actions (vector-ref tables 3))
+ (nl-start (vector-ref tables 5))
+ (no-nl-start (vector-ref tables 6))
+ (charcs-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8)))
+ (let* ((len (vector-length charcs-v))
+ (v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+ (loop (- i 1)))
+ (lexer-make-tree-lexer
+ (vector counters
+ <<EOF>>-action
+ <<ERROR>>-action
+ rules-actions
+ 'decision-trees
+ nl-start
+ no-nl-start
+ v
+ acc-v)
+ IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+ (lambda (tables IS)
+ (let ((<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-action (vector-ref tables 3))
+ (code (vector-ref tables 5)))
+ (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+ (lambda (tables IS)
+ (let ((automaton-type (vector-ref tables 4)))
+ (cond ((eq? automaton-type 'decision-trees)
+ (lexer-make-tree-lexer tables IS))
+ ((eq? automaton-type 'tagged-chars-lists)
+ (lexer-make-char-lexer tables IS))
+ ((eq? automaton-type 'code)
+ (lexer-make-code-lexer tables IS))))))
+
+; Module lexparser.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Fonctions auxilliaires du lexer
+;
+
+(define parse-spec-char
+ (lambda (lexeme line column)
+ (make-tok char-tok lexeme line column newline-ch)))
+
+(define parse-digits-char
+ (lambda (lexeme line column)
+ (let* ((num (substring lexeme 1 (string-length lexeme)))
+ (n (string->number num)))
+ (make-tok char-tok lexeme line column n))))
+
+(define parse-quoted-char
+ (lambda (lexeme line column)
+ (let ((c (string-ref lexeme 1)))
+ (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define parse-ordinary-char
+ (lambda (lexeme line column)
+ (let ((c (string-ref lexeme 0)))
+ (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define extract-id
+ (lambda (s)
+ (let ((len (string-length s)))
+ (substring s 1 (- len 1)))))
+
+(define parse-id
+ (lambda (lexeme line column)
+ (make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
+
+(define parse-id-ref
+ (lambda (lexeme line column)
+ (let* ((orig-name (extract-id lexeme))
+ (name (string-downcase orig-name)))
+ (make-tok subst-tok lexeme line column name orig-name))))
+
+(define parse-power-m
+ (lambda (lexeme line column)
+ (let* ((len (string-length lexeme))
+ (substr (substring lexeme 1 (- len 1)))
+ (m (string->number substr))
+ (range (cons m m)))
+ (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-inf
+ (lambda (lexeme line column)
+ (let* ((len (string-length lexeme))
+ (substr (substring lexeme 1 (- len 2)))
+ (m (string->number substr))
+ (range (cons m 'inf)))
+ (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-n
+ (lambda (lexeme line column)
+ (let ((len (string-length lexeme)))
+ (let loop ((comma 2))
+ (if (char=? (string-ref lexeme comma) #\,)
+ (let* ((sub1 (substring lexeme 1 comma))
+ (sub2 (substring lexeme (+ comma 1) (- len 1)))
+ (m (string->number sub1))
+ (n (string->number sub2))
+ (range (cons m n)))
+ (make-tok power-tok lexeme line column range))
+ (loop (+ comma 1)))))))
+
+
+
+
+;
+; Lexer generique
+;
+
+(define lexer-raw #f)
+(define lexer-stack '())
+
+(define lexer-alist #f)
+
+(define lexer-buffer #f)
+(define lexer-buffer-empty? #t)
+
+(define lexer-history '())
+(define lexer-history-interp #f)
+
+(define init-lexer
+ (lambda (port)
+ (let* ((IS (lexer-make-IS 'port port 'all))
+ (action-lexer (lexer-make-lexer action-tables IS))
+ (class-lexer (lexer-make-lexer class-tables IS))
+ (macro-lexer (lexer-make-lexer macro-tables IS))
+ (regexp-lexer (lexer-make-lexer regexp-tables IS))
+ (string-lexer (lexer-make-lexer string-tables IS)))
+ (set! lexer-raw #f)
+ (set! lexer-stack '())
+ (set! lexer-alist
+ (list (cons 'action action-lexer)
+ (cons 'class class-lexer)
+ (cons 'macro macro-lexer)
+ (cons 'regexp regexp-lexer)
+ (cons 'string string-lexer)))
+ (set! lexer-buffer-empty? #t)
+ (set! lexer-history '()))))
+
+; Lexer brut
+; S'assurer qu'il n'y a pas de risque de changer de
+; lexer quand le buffer est rempli
+(define push-lexer
+ (lambda (name)
+ (set! lexer-stack (cons lexer-raw lexer-stack))
+ (set! lexer-raw (cdr (assq name lexer-alist)))))
+
+(define pop-lexer
+ (lambda ()
+ (set! lexer-raw (car lexer-stack))
+ (set! lexer-stack (cdr lexer-stack))))
+
+; Traite le "unget" (capacite du unget: 1)
+(define lexer2
+ (lambda ()
+ (if lexer-buffer-empty?
+ (lexer-raw)
+ (begin
+ (set! lexer-buffer-empty? #t)
+ lexer-buffer))))
+
+(define lexer2-unget
+ (lambda (tok)
+ (set! lexer-buffer tok)
+ (set! lexer-buffer-empty? #f)))
+
+; Traite l'historique
+(define lexer
+ (lambda ()
+ (let* ((tok (lexer2))
+ (tok-lexeme (get-tok-lexeme tok))
+ (hist-lexeme (if lexer-history-interp
+ (blank-translate tok-lexeme)
+ tok-lexeme)))
+ (set! lexer-history (cons hist-lexeme lexer-history))
+ tok)))
+
+(define lexer-unget
+ (lambda (tok)
+ (set! lexer-history (cdr lexer-history))
+ (lexer2-unget tok)))
+
+(define lexer-set-blank-history
+ (lambda (b)
+ (set! lexer-history-interp b)))
+
+(define blank-translate
+ (lambda (s)
+ (let ((ss (string-copy s)))
+ (let loop ((i (- (string-length ss) 1)))
+ (cond ((< i 0)
+ ss)
+ ((char=? (string-ref ss i) (integer->char tab-ch))
+ (loop (- i 1)))
+ ((char=? (string-ref ss i) #\newline)
+ (loop (- i 1)))
+ (else
+ (string-set! ss i #\space)
+ (loop (- i 1))))))))
+
+(define lexer-get-history
+ (lambda ()
+ (let* ((rightlist (reverse lexer-history))
+ (str (string-append-list rightlist))
+ (strlen (string-length str))
+ (str2 (if (and (> strlen 0)
+ (char=? (string-ref str (- strlen 1)) #\newline))
+ str
+ (string-append str (string #\newline)))))
+ (set! lexer-history '())
+ str2)))
+
+
+
+
+;
+; Traitement des listes de tokens
+;
+
+(define de-anchor-tokens
+ (let ((not-anchor-toks (make-dispatch-table number-of-tokens
+ (list (cons caret-tok #f)
+ (cons dollar-tok #f)
+ (cons <<EOF>>-tok #f)
+ (cons <<ERROR>>-tok #f))
+ #t)))
+ (lambda (tok-list)
+ (if (null? tok-list)
+ '()
+ (let* ((tok (car tok-list))
+ (tok-type (get-tok-type tok))
+ (toks (cdr tok-list))
+ (new-toks (de-anchor-tokens toks)))
+ (cond ((vector-ref not-anchor-toks tok-type)
+ (cons tok new-toks))
+ ((or (= tok-type caret-tok) (= tok-type dollar-tok))
+ (let* ((line (get-tok-line tok))
+ (column (get-tok-column tok))
+ (attr (if (= tok-type caret-tok) caret-ch dollar-ch))
+ (new-tok (make-tok char-tok "" line column attr)))
+ (cons new-tok new-toks)))
+ ((= tok-type <<EOF>>-tok)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "the <<EOF>> anchor must be used alone"
+ " and only after %%."))
+ ((= tok-type <<ERROR>>-tok)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "the <<ERROR>> anchor must be used alone"
+ " and only after %%."))))))))
+
+(define strip-end
+ (lambda (l)
+ (if (null? (cdr l))
+ '()
+ (cons (car l) (strip-end (cdr l))))))
+
+(define extract-anchors
+ (lambda (tok-list)
+ (let* ((tok1 (car tok-list))
+ (line (get-tok-line tok1))
+ (tok1-type (get-tok-type tok1)))
+ (cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
+ (make-rule line #t #f #f #f '() #f))
+ ((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
+ (make-rule line #f #t #f #f '() #f))
+ (else
+ (let* ((bol? (= tok1-type caret-tok))
+ (tok-list2 (if bol? (cdr tok-list) tok-list)))
+ (if (null? tok-list2)
+ (make-rule line #f #f bol? #f tok-list2 #f)
+ (let* ((len (length tok-list2))
+ (tok2 (list-ref tok-list2 (- len 1)))
+ (tok2-type (get-tok-type tok2))
+ (eol? (= tok2-type dollar-tok))
+ (tok-list3 (if eol?
+ (strip-end tok-list2)
+ tok-list2)))
+ (make-rule line #f #f bol? eol? tok-list3 #f)))))))))
+
+(define char-list->conc
+ (lambda (char-list)
+ (if (null? char-list)
+ (make-re epsilon-re)
+ (let loop ((cl char-list))
+ (let* ((c (car cl))
+ (cl2 (cdr cl)))
+ (if (null? cl2)
+ (make-re char-re c)
+ (make-re conc-re (make-re char-re c) (loop cl2))))))))
+
+(define parse-tokens-atom
+ (let ((action-table
+ (make-dispatch-table
+ number-of-tokens
+ (list (cons lpar-tok
+ (lambda (tok tok-list macros)
+ (parse-tokens-sub tok-list macros)))
+ (cons dot-tok
+ (lambda (tok tok-list macros)
+ (cons (make-re class-re dot-class) (cdr tok-list))))
+ (cons subst-tok
+ (lambda (tok tok-list macros)
+ (let* ((name (get-tok-attr tok))
+ (ass (assoc name macros)))
+ (if ass
+ (cons (cdr ass) (cdr tok-list))
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "unknown macro \""
+ (get-tok-2nd-attr tok)
+ "\".")))))
+ (cons char-tok
+ (lambda (tok tok-list macros)
+ (let ((c (get-tok-attr tok)))
+ (cons (make-re char-re c) (cdr tok-list)))))
+ (cons class-tok
+ (lambda (tok tok-list macros)
+ (let ((class (get-tok-attr tok)))
+ (cons (make-re class-re class) (cdr tok-list)))))
+ (cons string-tok
+ (lambda (tok tok-list macros)
+ (let* ((char-list (get-tok-attr tok))
+ (re (char-list->conc char-list)))
+ (cons re (cdr tok-list))))))
+ (lambda (tok tok-list macros)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "syntax error in regular expression.")))))
+ (lambda (tok-list macros)
+ (let* ((tok (car tok-list))
+ (tok-type (get-tok-type tok))
+ (action (vector-ref action-table tok-type)))
+ (action tok tok-list macros)))))
+
+(define check-power-tok
+ (lambda (tok)
+ (let* ((range (get-tok-attr tok))
+ (start (car range))
+ (end (cdr range)))
+ (if (or (eq? 'inf end) (<= start end))
+ range
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "incorrect power specification.")))))
+
+(define power->star-plus
+ (lambda (re range)
+ (power->star-plus-rec re (car range) (cdr range))))
+
+(define power->star-plus-rec
+ (lambda (re start end)
+ (cond ((eq? end 'inf)
+ (cond ((= start 0)
+ (make-re star-re re))
+ ((= start 1)
+ (make-re plus-re re))
+ (else
+ (make-re conc-re
+ re
+ (power->star-plus-rec re (- start 1) 'inf)))))
+ ((= start 0)
+ (cond ((= end 0)
+ (make-re epsilon-re))
+ ((= end 1)
+ (make-re question-re re))
+ (else
+ (make-re question-re
+ (power->star-plus-rec re 1 end)))))
+ ((= start 1)
+ (if (= end 1)
+ re
+ (make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
+ (else
+ (make-re conc-re
+ re
+ (power->star-plus-rec re (- start 1) (- end 1)))))))
+
+(define parse-tokens-fact
+ (let ((not-op-toks (make-dispatch-table number-of-tokens
+ (list (cons question-tok #f)
+ (cons plus-tok #f)
+ (cons star-tok #f)
+ (cons power-tok #f))
+ #t)))
+ (lambda (tok-list macros)
+ (let* ((result (parse-tokens-atom tok-list macros))
+ (re (car result))
+ (tok-list2 (cdr result)))
+ (let loop ((re re) (tok-list3 tok-list2))
+ (let* ((tok (car tok-list3))
+ (tok-type (get-tok-type tok)))
+ (cond ((vector-ref not-op-toks tok-type)
+ (cons re tok-list3))
+ ((= tok-type question-tok)
+ (loop (make-re question-re re) (cdr tok-list3)))
+ ((= tok-type plus-tok)
+ (loop (make-re plus-re re) (cdr tok-list3)))
+ ((= tok-type star-tok)
+ (loop (make-re star-re re) (cdr tok-list3)))
+ ((= tok-type power-tok)
+ (loop (power->star-plus re (check-power-tok tok))
+ (cdr tok-list3))))))))))
+
+(define parse-tokens-conc
+ (lambda (tok-list macros)
+ (let* ((result1 (parse-tokens-fact tok-list macros))
+ (re1 (car result1))
+ (tok-list2 (cdr result1))
+ (tok (car tok-list2))
+ (tok-type (get-tok-type tok)))
+ (cond ((or (= tok-type pipe-tok)
+ (= tok-type rpar-tok))
+ result1)
+ (else ; Autres facteurs
+ (let* ((result2 (parse-tokens-conc tok-list2 macros))
+ (re2 (car result2))
+ (tok-list3 (cdr result2)))
+ (cons (make-re conc-re re1 re2) tok-list3)))))))
+
+(define parse-tokens-or
+ (lambda (tok-list macros)
+ (let* ((result1 (parse-tokens-conc tok-list macros))
+ (re1 (car result1))
+ (tok-list2 (cdr result1))
+ (tok (car tok-list2))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type pipe-tok)
+ (let* ((tok-list3 (cdr tok-list2))
+ (result2 (parse-tokens-or tok-list3 macros))
+ (re2 (car result2))
+ (tok-list4 (cdr result2)))
+ (cons (make-re or-re re1 re2) tok-list4)))
+ (else ; rpar-tok
+ result1)))))
+
+(define parse-tokens-sub
+ (lambda (tok-list macros)
+ (let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
+ (result (parse-tokens-or tok-list2 macros))
+ (re (car result))
+ (tok-list3 (cdr result))
+ (tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
+ (cons re tok-list4))))
+
+(define parse-tokens-match
+ (lambda (tok-list line)
+ (let loop ((tl tok-list) (count 0))
+ (if (null? tl)
+ (if (> count 0)
+ (lex-error line
+ #f
+ "mismatched parentheses."))
+ (let* ((tok (car tl))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type lpar-tok)
+ (loop (cdr tl) (+ count 1)))
+ ((= tok-type rpar-tok)
+ (if (zero? count)
+ (lex-error line
+ #f
+ "mismatched parentheses."))
+ (loop (cdr tl) (- count 1)))
+ (else
+ (loop (cdr tl) count))))))))
+
+; Ne traite pas les anchors
+(define parse-tokens
+ (lambda (tok-list macros)
+ (if (null? tok-list)
+ (make-re epsilon-re)
+ (let ((line (get-tok-line (car tok-list))))
+ (parse-tokens-match tok-list line)
+ (let* ((begin-par (make-tok lpar-tok "" line 1))
+ (end-par (make-tok rpar-tok "" line 1)))
+ (let* ((tok-list2 (append (list begin-par)
+ tok-list
+ (list end-par)))
+ (result (parse-tokens-sub tok-list2 macros)))
+ (car result))))))) ; (cdr result) == () obligatoirement
+
+(define tokens->regexp
+ (lambda (tok-list macros)
+ (let ((tok-list2 (de-anchor-tokens tok-list)))
+ (parse-tokens tok-list2 macros))))
+
+(define tokens->rule
+ (lambda (tok-list macros)
+ (let* ((rule (extract-anchors tok-list))
+ (tok-list2 (get-rule-regexp rule))
+ (tok-list3 (de-anchor-tokens tok-list2))
+ (re (parse-tokens tok-list3 macros)))
+ (set-rule-regexp rule re)
+ rule)))
+
+; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
+(define adapt-rules
+ (lambda (rules)
+ (let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
+ (if (null? r)
+ (cons (or <<EOF>>-action default-<<EOF>>-action)
+ (cons (or <<ERROR>>-action default-<<ERROR>>-action)
+ (list->vector (reverse revr))))
+ (let ((r1 (car r)))
+ (cond ((get-rule-eof? r1)
+ (if <<EOF>>-action
+ (lex-error (get-rule-line r1)
+ #f
+ "the <<EOF>> anchor can be "
+ "used at most once.")
+ (loop (cdr r)
+ revr
+ (get-rule-action r1)
+ <<ERROR>>-action)))
+ ((get-rule-error? r1)
+ (if <<ERROR>>-action
+ (lex-error (get-rule-line r1)
+ #f
+ "the <<ERROR>> anchor can be "
+ "used at most once.")
+ (loop (cdr r)
+ revr
+ <<EOF>>-action
+ (get-rule-action r1))))
+ (else
+ (loop (cdr r)
+ (cons r1 revr)
+ <<EOF>>-action
+ <<ERROR>>-action))))))))
+
+
+
+
+;
+; Analyseur de fichier lex
+;
+
+(define parse-hv-blanks
+ (lambda ()
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (if (or (= tok-type hblank-tok)
+ (= tok-type vblank-tok))
+ (parse-hv-blanks)
+ (lexer-unget tok)))))
+
+(define parse-class-range
+ (lambda ()
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type char-tok)
+ (let* ((c (get-tok-attr tok))
+ (tok2 (lexer))
+ (tok2-type (get-tok-type tok2)))
+ (if (not (= tok2-type minus-tok))
+ (begin
+ (lexer-unget tok2)
+ (cons c c))
+ (let* ((tok3 (lexer))
+ (tok3-type (get-tok-type tok3)))
+ (cond ((= tok3-type char-tok)
+ (let ((c2 (get-tok-attr tok3)))
+ (if (> c c2)
+ (lex-error (get-tok-line tok3)
+ (get-tok-column tok3)
+ "bad range specification in "
+ "character class;"
+ #\newline
+ "the start character is "
+ "higher than the end one.")
+ (cons c c2))))
+ ((or (= tok3-type rbrack-tok)
+ (= tok3-type minus-tok))
+ (lex-error (get-tok-line tok3)
+ (get-tok-column tok3)
+ "bad range specification in "
+ "character class; a specification"
+ #\newline
+ "like \"-x\", \"x--\" or \"x-]\" has "
+ "been used."))
+ ((= tok3-type eof-tok)
+ (lex-error (get-tok-line tok3)
+ #f
+ "eof of file found while parsing "
+ "a character class.")))))))
+ ((= tok-type minus-tok)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "bad range specification in character class; a "
+ "specification"
+ #\newline
+ "like \"-x\", \"x--\" or \"x-]\" has been used."))
+ ((= tok-type rbrack-tok)
+ #f)
+ ((= tok-type eof-tok)
+ (lex-error (get-tok-line tok)
+ #f
+ "eof of file found while parsing "
+ "a character class."))))))
+
+(define parse-class
+ (lambda (initial-class negative-class? line column)
+ (push-lexer 'class)
+ (let loop ((class initial-class))
+ (let ((new-range (parse-class-range)))
+ (if new-range
+ (loop (class-union (list new-range) class))
+ (let ((class (if negative-class?
+ (class-compl class)
+ class)))
+ (pop-lexer)
+ (make-tok class-tok "" line column class)))))))
+
+(define parse-string
+ (lambda (line column)
+ (push-lexer 'string)
+ (let ((char-list (let loop ()
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type char-tok)
+ (cons (get-tok-attr tok) (loop)))
+ ((= tok-type doublequote-tok)
+ (pop-lexer)
+ '())
+ (else ; eof-tok
+ (lex-error (get-tok-line tok)
+ #f
+ "end of file found while "
+ "parsing a string.")))))))
+ (make-tok string-tok "" line column char-list))))
+
+(define parse-regexp
+ (let* ((end-action
+ (lambda (tok loop)
+ (lexer-unget tok)
+ (pop-lexer)
+ (lexer-set-blank-history #f)
+ `()))
+ (action-table
+ (make-dispatch-table
+ number-of-tokens
+ (list (cons eof-tok end-action)
+ (cons hblank-tok end-action)
+ (cons vblank-tok end-action)
+ (cons lbrack-tok
+ (lambda (tok loop)
+ (let ((tok1 (parse-class (list)
+ #f
+ (get-tok-line tok)
+ (get-tok-column tok))))
+ (cons tok1 (loop)))))
+ (cons lbrack-rbrack-tok
+ (lambda (tok loop)
+ (let ((tok1 (parse-class
+ (list (cons rbrack-ch rbrack-ch))
+ #f
+ (get-tok-line tok)
+ (get-tok-column tok))))
+ (cons tok1 (loop)))))
+ (cons lbrack-caret-tok
+ (lambda (tok loop)
+ (let ((tok1 (parse-class (list)
+ #t
+ (get-tok-line tok)
+ (get-tok-column tok))))
+ (cons tok1 (loop)))))
+ (cons lbrack-minus-tok
+ (lambda (tok loop)
+ (let ((tok1 (parse-class
+ (list (cons minus-ch minus-ch))
+ #f
+ (get-tok-line tok)
+ (get-tok-column tok))))
+ (cons tok1 (loop)))))
+ (cons doublequote-tok
+ (lambda (tok loop)
+ (let ((tok1 (parse-string (get-tok-line tok)
+ (get-tok-column tok))))
+ (cons tok1 (loop)))))
+ (cons illegal-tok
+ (lambda (tok loop)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "syntax error in macro reference."))))
+ (lambda (tok loop)
+ (cons tok (loop))))))
+ (lambda ()
+ (push-lexer 'regexp)
+ (lexer-set-blank-history #t)
+ (parse-hv-blanks)
+ (let loop ()
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok))
+ (action (vector-ref action-table tok-type)))
+ (action tok loop))))))
+
+(define parse-ws1-regexp ; Exige un blanc entre le nom et la RE d'une macro
+ (lambda ()
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
+ (parse-regexp))
+ (else ; percent-percent-tok, id-tok ou illegal-tok
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "white space expected."))))))
+
+(define parse-macro
+ (lambda (macros)
+ (push-lexer 'macro)
+ (parse-hv-blanks)
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type id-tok)
+ (let* ((name (get-tok-attr tok))
+ (ass (assoc name macros)))
+ (if ass
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "the macro \""
+ (get-tok-2nd-attr tok)
+ "\" has already been defined.")
+ (let* ((tok-list (parse-ws1-regexp))
+ (regexp (tokens->regexp tok-list macros)))
+ (pop-lexer)
+ (cons name regexp)))))
+ ((= tok-type percent-percent-tok)
+ (pop-lexer)
+ #f)
+ ((= tok-type illegal-tok)
+ (lex-error (get-tok-line tok)
+ (get-tok-column tok)
+ "macro name expected."))
+ ((= tok-type eof-tok)
+ (lex-error (get-tok-line tok)
+ #f
+ "end of file found before %%."))))))
+
+(define parse-macros
+ (lambda ()
+ (let loop ((macros '()))
+ (let ((macro (parse-macro macros)))
+ (if macro
+ (loop (cons macro macros))
+ macros)))))
+
+(define parse-action-end
+ (lambda (<<EOF>>-action? <<ERROR>>-action? action?)
+ (let ((act (lexer-get-history)))
+ (cond (action?
+ act)
+ (<<EOF>>-action?
+ (string-append act default-<<EOF>>-action))
+ (<<ERROR>>-action?
+ (string-append act default-<<ERROR>>-action))
+ (else
+ (string-append act default-action))))))
+
+(define parse-action
+ (lambda (<<EOF>>-action? <<ERROR>>-action?)
+ (push-lexer 'action)
+ (let loop ((action? #f))
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok)))
+ (cond ((= tok-type char-tok)
+ (loop #t))
+ ((= tok-type hblank-tok)
+ (loop action?))
+ ((= tok-type vblank-tok)
+ (push-lexer 'regexp)
+ (let* ((tok (lexer))
+ (tok-type (get-tok-type tok))
+ (bidon (lexer-unget tok)))
+ (pop-lexer)
+ (if (or (= tok-type hblank-tok)
+ (= tok-type vblank-tok))
+ (loop action?)
+ (begin
+ (pop-lexer)
+ (parse-action-end <<EOF>>-action?
+ <<ERROR>>-action?
+ action?)))))
+ (else ; eof-tok
+ (lexer-unget tok)
+ (pop-lexer)
+ (parse-action-end <<EOF>>-action?
+ <<ERROR>>-action?
+ action?)))))))
+
+(define parse-rule
+ (lambda (macros)
+ (let ((tok-list (parse-regexp)))
+ (if (null? tok-list)
+ #f
+ (let* ((rule (tokens->rule tok-list macros))
+ (action
+ (parse-action (get-rule-eof? rule) (get-rule-error? rule))))
+ (set-rule-action rule action)
+ rule)))))
+
+(define parse-rules
+ (lambda (macros)
+ (parse-action #f #f)
+ (let loop ()
+ (let ((rule (parse-rule macros)))
+ (if rule
+ (cons rule (loop))
+ '())))))
+
+(define parser
+ (lambda (filename)
+ (let* ((port (open-input-file filename))
+ (port-open? #t))
+ (lex-unwind-protect (lambda ()
+ (if port-open?
+ (close-input-port port))))
+ (init-lexer port)
+ (let* ((macros (parse-macros))
+ (rules (parse-rules macros)))
+ (close-input-port port)
+ (set! port-open? #f)
+ (adapt-rules rules)))))
+
+; Module re2nfa.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+; Le vecteur d'etats contient la table de transition du nfa.
+; Chaque entree contient les arcs partant de l'etat correspondant.
+; Les arcs sont stockes dans une liste.
+; Chaque arc est une paire (class . destination).
+; Les caracteres d'une classe sont enumeres par ranges.
+; Les ranges sont donnes dans une liste,
+; chaque element etant une paire (debut . fin).
+; Le symbole eps peut remplacer une classe.
+; L'acceptation est decrite par une paire (acc-if-eol . acc-if-no-eol).
+
+; Quelques variables globales
+(define r2n-counter 0)
+(define r2n-v-arcs '#(#f))
+(define r2n-v-acc '#(#f))
+(define r2n-v-len 1)
+
+; Initialisation des variables globales
+(define r2n-init
+ (lambda ()
+ (set! r2n-counter 0)
+ (set! r2n-v-arcs (vector '()))
+ (set! r2n-v-acc (vector #f))
+ (set! r2n-v-len 1)))
+
+; Agrandissement des vecteurs
+(define r2n-extend-v
+ (lambda ()
+ (let* ((new-len (* 2 r2n-v-len))
+ (new-v-arcs (make-vector new-len '()))
+ (new-v-acc (make-vector new-len #f)))
+ (let loop ((i 0))
+ (if (< i r2n-v-len)
+ (begin
+ (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+ (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+ (loop (+ i 1)))))
+ (set! r2n-v-arcs new-v-arcs)
+ (set! r2n-v-acc new-v-acc)
+ (set! r2n-v-len new-len))))
+
+; Finalisation des vecteurs
+(define r2n-finalize-v
+ (lambda ()
+ (let* ((new-v-arcs (make-vector r2n-counter))
+ (new-v-acc (make-vector r2n-counter)))
+ (let loop ((i 0))
+ (if (< i r2n-counter)
+ (begin
+ (vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
+ (vector-set! new-v-acc i (vector-ref r2n-v-acc i))
+ (loop (+ i 1)))))
+ (set! r2n-v-arcs new-v-arcs)
+ (set! r2n-v-acc new-v-acc)
+ (set! r2n-v-len r2n-counter))))
+
+; Creation d'etat
+(define r2n-get-state
+ (lambda (acc)
+ (if (= r2n-counter r2n-v-len)
+ (r2n-extend-v))
+ (let ((state r2n-counter))
+ (set! r2n-counter (+ r2n-counter 1))
+ (vector-set! r2n-v-acc state (or acc (cons #f #f)))
+ state)))
+
+; Ajout d'un arc
+(define r2n-add-arc
+ (lambda (start chars end)
+ (vector-set! r2n-v-arcs
+ start
+ (cons (cons chars end) (vector-ref r2n-v-arcs start)))))
+
+; Construction de l'automate a partir des regexp
+(define r2n-build-epsilon
+ (lambda (re start end)
+ (r2n-add-arc start 'eps end)))
+
+(define r2n-build-or
+ (lambda (re start end)
+ (let ((re1 (get-re-attr1 re))
+ (re2 (get-re-attr2 re)))
+ (r2n-build-re re1 start end)
+ (r2n-build-re re2 start end))))
+
+(define r2n-build-conc
+ (lambda (re start end)
+ (let* ((re1 (get-re-attr1 re))
+ (re2 (get-re-attr2 re))
+ (inter (r2n-get-state #f)))
+ (r2n-build-re re1 start inter)
+ (r2n-build-re re2 inter end))))
+
+(define r2n-build-star
+ (lambda (re start end)
+ (let* ((re1 (get-re-attr1 re))
+ (inter1 (r2n-get-state #f))
+ (inter2 (r2n-get-state #f)))
+ (r2n-add-arc start 'eps inter1)
+ (r2n-add-arc inter1 'eps inter2)
+ (r2n-add-arc inter2 'eps end)
+ (r2n-build-re re1 inter2 inter1))))
+
+(define r2n-build-plus
+ (lambda (re start end)
+ (let* ((re1 (get-re-attr1 re))
+ (inter1 (r2n-get-state #f))
+ (inter2 (r2n-get-state #f)))
+ (r2n-add-arc start 'eps inter1)
+ (r2n-add-arc inter2 'eps inter1)
+ (r2n-add-arc inter2 'eps end)
+ (r2n-build-re re1 inter1 inter2))))
+
+(define r2n-build-question
+ (lambda (re start end)
+ (let ((re1 (get-re-attr1 re)))
+ (r2n-add-arc start 'eps end)
+ (r2n-build-re re1 start end))))
+
+(define r2n-build-class
+ (lambda (re start end)
+ (let ((class (get-re-attr1 re)))
+ (r2n-add-arc start class end))))
+
+(define r2n-build-char
+ (lambda (re start end)
+ (let* ((c (get-re-attr1 re))
+ (class (list (cons c c))))
+ (r2n-add-arc start class end))))
+
+(define r2n-build-re
+ (let ((sub-function-v (vector r2n-build-epsilon
+ r2n-build-or
+ r2n-build-conc
+ r2n-build-star
+ r2n-build-plus
+ r2n-build-question
+ r2n-build-class
+ r2n-build-char)))
+ (lambda (re start end)
+ (let* ((re-type (get-re-type re))
+ (sub-f (vector-ref sub-function-v re-type)))
+ (sub-f re start end)))))
+
+; Construction de l'automate relatif a une regle
+(define r2n-build-rule
+ (lambda (rule ruleno nl-start no-nl-start)
+ (let* ((re (get-rule-regexp rule))
+ (bol? (get-rule-bol? rule))
+ (eol? (get-rule-eol? rule))
+ (rule-start (r2n-get-state #f))
+ (rule-end (r2n-get-state (if eol?
+ (cons ruleno #f)
+ (cons ruleno ruleno)))))
+ (r2n-build-re re rule-start rule-end)
+ (r2n-add-arc nl-start 'eps rule-start)
+ (if (not bol?)
+ (r2n-add-arc no-nl-start 'eps rule-start)))))
+
+; Construction de l'automate complet
+(define re2nfa
+ (lambda (rules)
+ (let ((nb-of-rules (vector-length rules)))
+ (r2n-init)
+ (let* ((nl-start (r2n-get-state #f))
+ (no-nl-start (r2n-get-state #f)))
+ (let loop ((i 0))
+ (if (< i nb-of-rules)
+ (begin
+ (r2n-build-rule (vector-ref rules i)
+ i
+ nl-start
+ no-nl-start)
+ (loop (+ i 1)))))
+ (r2n-finalize-v)
+ (let ((v-arcs r2n-v-arcs)
+ (v-acc r2n-v-acc))
+ (r2n-init)
+ (list nl-start no-nl-start v-arcs v-acc))))))
+
+; Module noeps.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+; Fonction "merge" qui elimine les repetitions
+(define noeps-merge-1
+ (lambda (l1 l2)
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((t1 (car l1))
+ (t2 (car l2)))
+ (cond ((< t1 t2)
+ (cons t1 (noeps-merge-1 (cdr l1) l2)))
+ ((= t1 t2)
+ (cons t1 (noeps-merge-1 (cdr l1) (cdr l2))))
+ (else
+ (cons t2 (noeps-merge-1 l1 (cdr l2))))))))))
+
+; Fabrication des voisinages externes
+(define noeps-mkvois
+ (lambda (trans-v)
+ (let* ((nbnodes (vector-length trans-v))
+ (arcs (make-vector nbnodes '())))
+ (let loop1 ((n 0))
+ (if (< n nbnodes)
+ (begin
+ (let loop2 ((trans (vector-ref trans-v n)) (ends '()))
+ (if (null? trans)
+ (vector-set! arcs n ends)
+ (let* ((tran (car trans))
+ (class (car tran))
+ (end (cdr tran)))
+ (loop2 (cdr trans) (if (eq? class 'eps)
+ (noeps-merge-1 ends (list end))
+ ends)))))
+ (loop1 (+ n 1)))))
+ arcs)))
+
+; Fabrication des valeurs initiales
+(define noeps-mkinit
+ (lambda (trans-v)
+ (let* ((nbnodes (vector-length trans-v))
+ (init (make-vector nbnodes)))
+ (let loop ((n 0))
+ (if (< n nbnodes)
+ (begin
+ (vector-set! init n (list n))
+ (loop (+ n 1)))))
+ init)))
+
+; Traduction d'une liste d'arcs
+(define noeps-trad-arcs
+ (lambda (trans dict)
+ (let loop ((trans trans))
+ (if (null? trans)
+ '()
+ (let* ((tran (car trans))
+ (class (car tran))
+ (end (cdr tran)))
+ (if (eq? class 'eps)
+ (loop (cdr trans))
+ (let* ((new-end (vector-ref dict end))
+ (new-tran (cons class new-end)))
+ (cons new-tran (loop (cdr trans))))))))))
+
+; Elimination des transitions eps
+(define noeps
+ (lambda (nl-start no-nl-start arcs acc)
+ (let* ((digraph-arcs (noeps-mkvois arcs))
+ (digraph-init (noeps-mkinit arcs))
+ (dict (digraph digraph-arcs digraph-init noeps-merge-1))
+ (new-nl-start (vector-ref dict nl-start))
+ (new-no-nl-start (vector-ref dict no-nl-start)))
+ (let loop ((i (- (vector-length arcs) 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! arcs i (noeps-trad-arcs (vector-ref arcs i) dict))
+ (loop (- i 1)))))
+ (list new-nl-start new-no-nl-start arcs acc))))
+
+; Module sweep.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+; Preparer les arcs pour digraph
+(define sweep-mkarcs
+ (lambda (trans-v)
+ (let* ((nbnodes (vector-length trans-v))
+ (arcs-v (make-vector nbnodes '())))
+ (let loop1 ((n 0))
+ (if (< n nbnodes)
+ (let loop2 ((trans (vector-ref trans-v n)) (arcs '()))
+ (if (null? trans)
+ (begin
+ (vector-set! arcs-v n arcs)
+ (loop1 (+ n 1)))
+ (loop2 (cdr trans) (noeps-merge-1 (cdar trans) arcs))))
+ arcs-v)))))
+
+; Preparer l'operateur pour digraph
+(define sweep-op
+ (let ((acc-min (lambda (rule1 rule2)
+ (cond ((not rule1)
+ rule2)
+ ((not rule2)
+ rule1)
+ (else
+ (min rule1 rule2))))))
+ (lambda (acc1 acc2)
+ (cons (acc-min (car acc1) (car acc2))
+ (acc-min (cdr acc1) (cdr acc2))))))
+
+; Renumerotation des etats (#f pour etat a eliminer)
+; Retourne (new-nbnodes . dict)
+(define sweep-renum
+ (lambda (dist-acc-v)
+ (let* ((nbnodes (vector-length dist-acc-v))
+ (dict (make-vector nbnodes)))
+ (let loop ((n 0) (new-n 0))
+ (if (< n nbnodes)
+ (let* ((acc (vector-ref dist-acc-v n))
+ (dead? (equal? acc '(#f . #f))))
+ (if dead?
+ (begin
+ (vector-set! dict n #f)
+ (loop (+ n 1) new-n))
+ (begin
+ (vector-set! dict n new-n)
+ (loop (+ n 1) (+ new-n 1)))))
+ (cons new-n dict))))))
+
+; Elimination des etats inutiles d'une liste d'etats
+(define sweep-list
+ (lambda (ss dict)
+ (if (null? ss)
+ '()
+ (let* ((olds (car ss))
+ (news (vector-ref dict olds)))
+ (if news
+ (cons news (sweep-list (cdr ss) dict))
+ (sweep-list (cdr ss) dict))))))
+
+; Elimination des etats inutiles d'une liste d'arcs
+(define sweep-arcs
+ (lambda (arcs dict)
+ (if (null? arcs)
+ '()
+ (let* ((arc (car arcs))
+ (class (car arc))
+ (ss (cdr arc))
+ (new-ss (sweep-list ss dict)))
+ (if (null? new-ss)
+ (sweep-arcs (cdr arcs) dict)
+ (cons (cons class new-ss) (sweep-arcs (cdr arcs) dict)))))))
+
+; Elimination des etats inutiles dans toutes les transitions
+(define sweep-all-arcs
+ (lambda (arcs-v dict)
+ (let loop ((n (- (vector-length arcs-v) 1)))
+ (if (>= n 0)
+ (begin
+ (vector-set! arcs-v n (sweep-arcs (vector-ref arcs-v n) dict))
+ (loop (- n 1)))
+ arcs-v))))
+
+; Elimination des etats inutiles dans un vecteur
+(define sweep-states
+ (lambda (v new-nbnodes dict)
+ (let ((nbnodes (vector-length v))
+ (new-v (make-vector new-nbnodes)))
+ (let loop ((n 0))
+ (if (< n nbnodes)
+ (let ((new-n (vector-ref dict n)))
+ (if new-n
+ (vector-set! new-v new-n (vector-ref v n)))
+ (loop (+ n 1)))
+ new-v)))))
+
+; Elimination des etats inutiles
+(define sweep
+ (lambda (nl-start no-nl-start arcs-v acc-v)
+ (let* ((digraph-arcs (sweep-mkarcs arcs-v))
+ (digraph-init acc-v)
+ (digraph-op sweep-op)
+ (dist-acc-v (digraph digraph-arcs digraph-init digraph-op))
+ (result (sweep-renum dist-acc-v))
+ (new-nbnodes (car result))
+ (dict (cdr result))
+ (new-nl-start (sweep-list nl-start dict))
+ (new-no-nl-start (sweep-list no-nl-start dict))
+ (new-arcs-v (sweep-states (sweep-all-arcs arcs-v dict)
+ new-nbnodes
+ dict))
+ (new-acc-v (sweep-states acc-v new-nbnodes dict)))
+ (list new-nl-start new-no-nl-start new-arcs-v new-acc-v))))
+
+; Module nfa2dfa.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+; Recoupement de deux arcs
+(define n2d-2arcs
+ (lambda (arc1 arc2)
+ (let* ((class1 (car arc1))
+ (ss1 (cdr arc1))
+ (class2 (car arc2))
+ (ss2 (cdr arc2))
+ (result (class-sep class1 class2))
+ (classl (vector-ref result 0))
+ (classc (vector-ref result 1))
+ (classr (vector-ref result 2))
+ (ssl ss1)
+ (ssc (ss-union ss1 ss2))
+ (ssr ss2))
+ (vector (if (or (null? classl) (null? ssl)) #f (cons classl ssl))
+ (if (or (null? classc) (null? ssc)) #f (cons classc ssc))
+ (if (or (null? classr) (null? ssr)) #f (cons classr ssr))))))
+
+; Insertion d'un arc dans une liste d'arcs a classes distinctes
+(define n2d-insert-arc
+ (lambda (new-arc arcs)
+ (if (null? arcs)
+ (list new-arc)
+ (let* ((arc (car arcs))
+ (others (cdr arcs))
+ (result (n2d-2arcs new-arc arc))
+ (arcl (vector-ref result 0))
+ (arcc (vector-ref result 1))
+ (arcr (vector-ref result 2))
+ (list-arcc (if arcc (list arcc) '()))
+ (list-arcr (if arcr (list arcr) '())))
+ (if arcl
+ (append list-arcc list-arcr (n2d-insert-arc arcl others))
+ (append list-arcc list-arcr others))))))
+
+; Regroupement des arcs qui aboutissent au meme sous-ensemble d'etats
+(define n2d-factorize-arcs
+ (lambda (arcs)
+ (if (null? arcs)
+ '()
+ (let* ((arc (car arcs))
+ (arc-ss (cdr arc))
+ (others-no-fact (cdr arcs))
+ (others (n2d-factorize-arcs others-no-fact)))
+ (let loop ((o others))
+ (if (null? o)
+ (list arc)
+ (let* ((o1 (car o))
+ (o1-ss (cdr o1)))
+ (if (equal? o1-ss arc-ss)
+ (let* ((arc-class (car arc))
+ (o1-class (car o1))
+ (new-class (class-union arc-class o1-class))
+ (new-arc (cons new-class arc-ss)))
+ (cons new-arc (cdr o)))
+ (cons o1 (loop (cdr o)))))))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes distinctes
+(define n2d-distinguish-arcs
+ (lambda (arcs)
+ (let loop ((arcs arcs) (n-arcs '()))
+ (if (null? arcs)
+ n-arcs
+ (loop (cdr arcs) (n2d-insert-arc (car arcs) n-arcs))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes et a
+; destinations distinctes
+(define n2d-normalize-arcs
+ (lambda (arcs)
+ (n2d-factorize-arcs (n2d-distinguish-arcs arcs))))
+
+; Factoriser des arcs a destination unique (~deterministes)
+(define n2d-factorize-darcs
+ (lambda (arcs)
+ (if (null? arcs)
+ '()
+ (let* ((arc (car arcs))
+ (arc-end (cdr arc))
+ (other-arcs (cdr arcs))
+ (farcs (n2d-factorize-darcs other-arcs)))
+ (let loop ((farcs farcs))
+ (if (null? farcs)
+ (list arc)
+ (let* ((farc (car farcs))
+ (farc-end (cdr farc)))
+ (if (= farc-end arc-end)
+ (let* ((arc-class (car arc))
+ (farc-class (car farc))
+ (new-class (class-union farc-class arc-class))
+ (new-arc (cons new-class arc-end)))
+ (cons new-arc (cdr farcs)))
+ (cons farc (loop (cdr farcs)))))))))))
+
+; Normaliser un vecteur de listes d'arcs
+(define n2d-normalize-arcs-v
+ (lambda (arcs-v)
+ (let* ((nbnodes (vector-length arcs-v))
+ (new-v (make-vector nbnodes)))
+ (let loop ((n 0))
+ (if (= n nbnodes)
+ new-v
+ (begin
+ (vector-set! new-v n (n2d-normalize-arcs (vector-ref arcs-v n)))
+ (loop (+ n 1))))))))
+
+; Inserer un arc dans une liste d'arcs a classes distinctes en separant
+; les arcs contenant une partie de la classe du nouvel arc des autres arcs
+; Retourne: (oui . non)
+(define n2d-ins-sep-arc
+ (lambda (new-arc arcs)
+ (if (null? arcs)
+ (cons (list new-arc) '())
+ (let* ((arc (car arcs))
+ (others (cdr arcs))
+ (result (n2d-2arcs new-arc arc))
+ (arcl (vector-ref result 0))
+ (arcc (vector-ref result 1))
+ (arcr (vector-ref result 2))
+ (l-arcc (if arcc (list arcc) '()))
+ (l-arcr (if arcr (list arcr) '()))
+ (result (if arcl
+ (n2d-ins-sep-arc arcl others)
+ (cons '() others)))
+ (oui-arcs (car result))
+ (non-arcs (cdr result)))
+ (cons (append l-arcc oui-arcs) (append l-arcr non-arcs))))))
+
+; Combiner deux listes d'arcs a classes distinctes
+; Ne tente pas de combiner les arcs qui ont nec. des classes disjointes
+; Conjecture: les arcs crees ont leurs classes disjointes
+; Note: envisager de rajouter un "n2d-factorize-arcs" !!!!!!!!!!!!
+(define n2d-combine-arcs
+ (lambda (arcs1 arcs2)
+ (let loop ((arcs1 arcs1) (arcs2 arcs2) (dist-arcs2 '()))
+ (if (null? arcs1)
+ (append arcs2 dist-arcs2)
+ (let* ((arc (car arcs1))
+ (result (n2d-ins-sep-arc arc arcs2))
+ (oui-arcs (car result))
+ (non-arcs (cdr result)))
+ (loop (cdr arcs1) non-arcs (append oui-arcs dist-arcs2)))))))
+
+; ;
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det. Recherche lineaire. Creation naive
+; ; des arcs d'un ensemble d'etats.
+; ;
+;
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+;
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+;
+; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
+;
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
+;
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+; (lambda ()
+; (set! n2d-state-dict (vector #f))
+; (set! n2d-state-len 1)
+; (set! n2d-state-count 0)))
+;
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+; (lambda ()
+; (let* ((new-len (* 2 n2d-state-len))
+; (v (make-vector new-len #f)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (begin
+; (set! n2d-state-dict v)
+; (set! n2d-state-len new-len))
+; (begin
+; (vector-set! v n (vector-ref n2d-state-dict n))
+; (loop (+ n 1))))))))
+;
+; ; Ajout d'un etat
+; (define n2d-add-state
+; (lambda (ss)
+; (let* ((s n2d-state-count)
+; (dentry (make-dentry ss)))
+; (if (= n2d-state-count n2d-state-len)
+; (n2d-extend-dict))
+; (vector-set! n2d-state-dict s dentry)
+; (set! n2d-state-count (+ n2d-state-count 1))
+; s)))
+;
+; ; Recherche d'un etat
+; (define n2d-search-state
+; (lambda (ss)
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (n2d-add-state ss)
+; (let* ((dentry (vector-ref n2d-state-dict n))
+; (dentry-ss (get-dentry-ss dentry)))
+; (if (equal? dentry-ss ss)
+; n
+; (loop (+ n 1))))))))
+;
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+; (lambda (arc)
+; (let* ((class (car arc))
+; (ss (cdr arc))
+; (s (n2d-search-state ss)))
+; (cons class s))))
+;
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+; (lambda (arcs)
+; (map n2d-translate-arc arcs)))
+;
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+; (let ((acc-min (lambda (rule1 rule2)
+; (cond ((not rule1)
+; rule2)
+; ((not rule2)
+; rule1)
+; (else
+; (min rule1 rule2))))))
+; (lambda (acc1 acc2)
+; (cons (acc-min (car acc1) (car acc2))
+; (acc-min (cdr acc1) (cdr acc2))))))
+;
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+; (lambda (accs)
+; (if (null? accs)
+; (cons #f #f)
+; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+;
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+; (lambda ()
+; (let* ((arcs-v (make-vector n2d-state-count))
+; (acc-v (make-vector n2d-state-count)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (cons arcs-v acc-v)
+; (begin
+; (vector-set! arcs-v n (get-dentry-darcs
+; (vector-ref n2d-state-dict n)))
+; (vector-set! acc-v n (get-dentry-acc
+; (vector-ref n2d-state-dict n)))
+; (loop (+ n 1))))))))
+;
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+; (lambda (nl-start no-nl-start arcs-v acc-v)
+; (n2d-init-glob-vars)
+; (let* ((nl-d (n2d-search-state nl-start))
+; (no-nl-d (n2d-search-state no-nl-start)))
+; (let loop ((n 0))
+; (if (< n n2d-state-count)
+; (let* ((dentry (vector-ref n2d-state-dict n))
+; (ss (get-dentry-ss dentry))
+; (arcss (map (lambda (s) (vector-ref arcs-v s)) ss))
+; (arcs (apply append arcss))
+; (dist-arcs (n2d-distinguish-arcs arcs))
+; (darcs (n2d-translate-arcs dist-arcs))
+; (fact-darcs (n2d-factorize-darcs darcs))
+; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; (acc (n2d-acc-mins accs)))
+; (set-dentry-darcs dentry fact-darcs)
+; (set-dentry-acc dentry acc)
+; (loop (+ n 1)))))
+; (let* ((result (n2d-extract-vs))
+; (new-arcs-v (car result))
+; (new-acc-v (cdr result)))
+; (n2d-init-glob-vars)
+; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ;
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det. Recherche lineaire. Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ;
+;
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+;
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+;
+; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
+;
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
+;
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+; (lambda ()
+; (set! n2d-state-dict (vector #f))
+; (set! n2d-state-len 1)
+; (set! n2d-state-count 0)))
+;
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+; (lambda ()
+; (let* ((new-len (* 2 n2d-state-len))
+; (v (make-vector new-len #f)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (begin
+; (set! n2d-state-dict v)
+; (set! n2d-state-len new-len))
+; (begin
+; (vector-set! v n (vector-ref n2d-state-dict n))
+; (loop (+ n 1))))))))
+;
+; ; Ajout d'un etat
+; (define n2d-add-state
+; (lambda (ss)
+; (let* ((s n2d-state-count)
+; (dentry (make-dentry ss)))
+; (if (= n2d-state-count n2d-state-len)
+; (n2d-extend-dict))
+; (vector-set! n2d-state-dict s dentry)
+; (set! n2d-state-count (+ n2d-state-count 1))
+; s)))
+;
+; ; Recherche d'un etat
+; (define n2d-search-state
+; (lambda (ss)
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (n2d-add-state ss)
+; (let* ((dentry (vector-ref n2d-state-dict n))
+; (dentry-ss (get-dentry-ss dentry)))
+; (if (equal? dentry-ss ss)
+; n
+; (loop (+ n 1))))))))
+;
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+; (lambda (arcs-l)
+; (if (null? arcs-l)
+; '()
+; (let* ((arcs (car arcs-l))
+; (other-arcs-l (cdr arcs-l))
+; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; (n2d-combine-arcs arcs other-arcs)))))
+;
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+; (lambda (arc)
+; (let* ((class (car arc))
+; (ss (cdr arc))
+; (s (n2d-search-state ss)))
+; (cons class s))))
+;
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+; (lambda (arcs)
+; (map n2d-translate-arc arcs)))
+;
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+; (let ((acc-min (lambda (rule1 rule2)
+; (cond ((not rule1)
+; rule2)
+; ((not rule2)
+; rule1)
+; (else
+; (min rule1 rule2))))))
+; (lambda (acc1 acc2)
+; (cons (acc-min (car acc1) (car acc2))
+; (acc-min (cdr acc1) (cdr acc2))))))
+;
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+; (lambda (accs)
+; (if (null? accs)
+; (cons #f #f)
+; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+;
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+; (lambda ()
+; (let* ((arcs-v (make-vector n2d-state-count))
+; (acc-v (make-vector n2d-state-count)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (cons arcs-v acc-v)
+; (begin
+; (vector-set! arcs-v n (get-dentry-darcs
+; (vector-ref n2d-state-dict n)))
+; (vector-set! acc-v n (get-dentry-acc
+; (vector-ref n2d-state-dict n)))
+; (loop (+ n 1))))))))
+;
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+; (lambda (nl-start no-nl-start arcs-v acc-v)
+; (n2d-init-glob-vars)
+; (let* ((nl-d (n2d-search-state nl-start))
+; (no-nl-d (n2d-search-state no-nl-start))
+; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+; (let loop ((n 0))
+; (if (< n n2d-state-count)
+; (let* ((dentry (vector-ref n2d-state-dict n))
+; (ss (get-dentry-ss dentry))
+; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; (arcs (n2d-combine-arcs-l arcs-l))
+; (darcs (n2d-translate-arcs arcs))
+; (fact-darcs (n2d-factorize-darcs darcs))
+; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; (acc (n2d-acc-mins accs)))
+; (set-dentry-darcs dentry fact-darcs)
+; (set-dentry-acc dentry acc)
+; (loop (+ n 1)))))
+; (let* ((result (n2d-extract-vs))
+; (new-arcs-v (car result))
+; (new-acc-v (cdr result)))
+; (n2d-init-glob-vars)
+; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ;
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det. Arbre de recherche. Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ;
+;
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; (define n2d-state-tree '#(#f ()))
+;
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+;
+; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
+;
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
+;
+; ; Fonctions de gestion de l'arbre de recherche
+; (define make-snode (lambda () (vector #f '())))
+;
+; (define get-snode-dstate (lambda (snode) (vector-ref snode 0)))
+; (define get-snode-children (lambda (snode) (vector-ref snode 1)))
+;
+; (define set-snode-dstate
+; (lambda (snode dstate) (vector-set! snode 0 dstate)))
+; (define set-snode-children
+; (lambda (snode children) (vector-set! snode 1 children)))
+;
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+; (lambda ()
+; (set! n2d-state-dict (vector #f))
+; (set! n2d-state-len 1)
+; (set! n2d-state-count 0)
+; (set! n2d-state-tree (make-snode))))
+;
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+; (lambda ()
+; (let* ((new-len (* 2 n2d-state-len))
+; (v (make-vector new-len #f)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (begin
+; (set! n2d-state-dict v)
+; (set! n2d-state-len new-len))
+; (begin
+; (vector-set! v n (vector-ref n2d-state-dict n))
+; (loop (+ n 1))))))))
+;
+; ; Ajout d'un etat
+; (define n2d-add-state
+; (lambda (ss)
+; (let* ((s n2d-state-count)
+; (dentry (make-dentry ss)))
+; (if (= n2d-state-count n2d-state-len)
+; (n2d-extend-dict))
+; (vector-set! n2d-state-dict s dentry)
+; (set! n2d-state-count (+ n2d-state-count 1))
+; s)))
+;
+; ; Recherche d'un etat
+; (define n2d-search-state
+; (lambda (ss)
+; (let loop ((s-l ss) (snode n2d-state-tree))
+; (if (null? s-l)
+; (or (get-snode-dstate snode)
+; (let ((s (n2d-add-state ss)))
+; (set-snode-dstate snode s)
+; s))
+; (let* ((next-s (car s-l))
+; (alist (get-snode-children snode))
+; (ass (or (assv next-s alist)
+; (let ((ass (cons next-s (make-snode))))
+; (set-snode-children snode (cons ass alist))
+; ass))))
+; (loop (cdr s-l) (cdr ass)))))))
+;
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+; (lambda (arcs-l)
+; (if (null? arcs-l)
+; '()
+; (let* ((arcs (car arcs-l))
+; (other-arcs-l (cdr arcs-l))
+; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; (n2d-combine-arcs arcs other-arcs)))))
+;
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+; (lambda (arc)
+; (let* ((class (car arc))
+; (ss (cdr arc))
+; (s (n2d-search-state ss)))
+; (cons class s))))
+;
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+; (lambda (arcs)
+; (map n2d-translate-arc arcs)))
+;
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+; (let ((acc-min (lambda (rule1 rule2)
+; (cond ((not rule1)
+; rule2)
+; ((not rule2)
+; rule1)
+; (else
+; (min rule1 rule2))))))
+; (lambda (acc1 acc2)
+; (cons (acc-min (car acc1) (car acc2))
+; (acc-min (cdr acc1) (cdr acc2))))))
+;
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+; (lambda (accs)
+; (if (null? accs)
+; (cons #f #f)
+; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+;
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+; (lambda ()
+; (let* ((arcs-v (make-vector n2d-state-count))
+; (acc-v (make-vector n2d-state-count)))
+; (let loop ((n 0))
+; (if (= n n2d-state-count)
+; (cons arcs-v acc-v)
+; (begin
+; (vector-set! arcs-v n (get-dentry-darcs
+; (vector-ref n2d-state-dict n)))
+; (vector-set! acc-v n (get-dentry-acc
+; (vector-ref n2d-state-dict n)))
+; (loop (+ n 1))))))))
+;
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+; (lambda (nl-start no-nl-start arcs-v acc-v)
+; (n2d-init-glob-vars)
+; (let* ((nl-d (n2d-search-state nl-start))
+; (no-nl-d (n2d-search-state no-nl-start))
+; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+; (let loop ((n 0))
+; (if (< n n2d-state-count)
+; (let* ((dentry (vector-ref n2d-state-dict n))
+; (ss (get-dentry-ss dentry))
+; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; (arcs (n2d-combine-arcs-l arcs-l))
+; (darcs (n2d-translate-arcs arcs))
+; (fact-darcs (n2d-factorize-darcs darcs))
+; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; (acc (n2d-acc-mins accs)))
+; (set-dentry-darcs dentry fact-darcs)
+; (set-dentry-acc dentry acc)
+; (loop (+ n 1)))))
+; (let* ((result (n2d-extract-vs))
+; (new-arcs-v (car result))
+; (new-acc-v (cdr result)))
+; (n2d-init-glob-vars)
+; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+;
+; Section temporaire: vieille facon de generer le dfa
+; Dictionnaire d'etat det. Table de hashage. Creation des
+; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; classes distinctes.
+;
+
+; Quelques variables globales
+(define n2d-state-dict '#(#f))
+(define n2d-state-len 1)
+(define n2d-state-count 0)
+(define n2d-state-hash '#())
+
+; Fonctions de gestion des entrees du dictionnaire
+(define make-dentry (lambda (ss) (vector ss #f #f)))
+
+(define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
+(define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+(define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
+
+(define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+(define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
+
+; Initialisation des variables globales
+(define n2d-init-glob-vars
+ (lambda (hash-len)
+ (set! n2d-state-dict (vector #f))
+ (set! n2d-state-len 1)
+ (set! n2d-state-count 0)
+ (set! n2d-state-hash (make-vector hash-len '()))))
+
+; Extension du dictionnaire
+(define n2d-extend-dict
+ (lambda ()
+ (let* ((new-len (* 2 n2d-state-len))
+ (v (make-vector new-len #f)))
+ (let loop ((n 0))
+ (if (= n n2d-state-count)
+ (begin
+ (set! n2d-state-dict v)
+ (set! n2d-state-len new-len))
+ (begin
+ (vector-set! v n (vector-ref n2d-state-dict n))
+ (loop (+ n 1))))))))
+
+; Ajout d'un etat
+(define n2d-add-state
+ (lambda (ss)
+ (let* ((s n2d-state-count)
+ (dentry (make-dentry ss)))
+ (if (= n2d-state-count n2d-state-len)
+ (n2d-extend-dict))
+ (vector-set! n2d-state-dict s dentry)
+ (set! n2d-state-count (+ n2d-state-count 1))
+ s)))
+
+; Recherche d'un etat
+(define n2d-search-state
+ (lambda (ss)
+ (let* ((hash-no (if (null? ss) 0 (car ss)))
+ (alist (vector-ref n2d-state-hash hash-no))
+ (ass (assoc ss alist)))
+ (if ass
+ (cdr ass)
+ (let* ((s (n2d-add-state ss))
+ (new-ass (cons ss s)))
+ (vector-set! n2d-state-hash hash-no (cons new-ass alist))
+ s)))))
+
+; Combiner des listes d'arcs a classes dictinctes
+(define n2d-combine-arcs-l
+ (lambda (arcs-l)
+ (if (null? arcs-l)
+ '()
+ (let* ((arcs (car arcs-l))
+ (other-arcs-l (cdr arcs-l))
+ (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+ (n2d-combine-arcs arcs other-arcs)))))
+
+; Transformer un arc non-det. en un arc det.
+(define n2d-translate-arc
+ (lambda (arc)
+ (let* ((class (car arc))
+ (ss (cdr arc))
+ (s (n2d-search-state ss)))
+ (cons class s))))
+
+; Transformer une liste d'arcs non-det. en ...
+(define n2d-translate-arcs
+ (lambda (arcs)
+ (map n2d-translate-arc arcs)))
+
+; Trouver le minimum de deux acceptants
+(define n2d-acc-min2
+ (let ((acc-min (lambda (rule1 rule2)
+ (cond ((not rule1)
+ rule2)
+ ((not rule2)
+ rule1)
+ (else
+ (min rule1 rule2))))))
+ (lambda (acc1 acc2)
+ (cons (acc-min (car acc1) (car acc2))
+ (acc-min (cdr acc1) (cdr acc2))))))
+
+; Trouver le minimum de plusieurs acceptants
+(define n2d-acc-mins
+ (lambda (accs)
+ (if (null? accs)
+ (cons #f #f)
+ (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+
+; Fabriquer les vecteurs d'arcs et d'acceptance
+(define n2d-extract-vs
+ (lambda ()
+ (let* ((arcs-v (make-vector n2d-state-count))
+ (acc-v (make-vector n2d-state-count)))
+ (let loop ((n 0))
+ (if (= n n2d-state-count)
+ (cons arcs-v acc-v)
+ (begin
+ (vector-set! arcs-v n (get-dentry-darcs
+ (vector-ref n2d-state-dict n)))
+ (vector-set! acc-v n (get-dentry-acc
+ (vector-ref n2d-state-dict n)))
+ (loop (+ n 1))))))))
+
+; Effectuer la transformation de l'automate de non-det. a det.
+(define nfa2dfa
+ (lambda (nl-start no-nl-start arcs-v acc-v)
+ (n2d-init-glob-vars (vector-length arcs-v))
+ (let* ((nl-d (n2d-search-state nl-start))
+ (no-nl-d (n2d-search-state no-nl-start))
+ (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+ (let loop ((n 0))
+ (if (< n n2d-state-count)
+ (let* ((dentry (vector-ref n2d-state-dict n))
+ (ss (get-dentry-ss dentry))
+ (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+ (arcs (n2d-combine-arcs-l arcs-l))
+ (darcs (n2d-translate-arcs arcs))
+ (fact-darcs (n2d-factorize-darcs darcs))
+ (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+ (acc (n2d-acc-mins accs)))
+ (set-dentry-darcs dentry fact-darcs)
+ (set-dentry-acc dentry acc)
+ (loop (+ n 1)))))
+ (let* ((result (n2d-extract-vs))
+ (new-arcs-v (car result))
+ (new-acc-v (cdr result)))
+ (n2d-init-glob-vars 0)
+ (list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; Module prep.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Divers pre-traitements avant l'ecriture des tables
+;
+
+; Passe d'un arc multi-range a une liste d'arcs mono-range
+(define prep-arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+
+; Compare des arcs courts selon leur premier caractere
+(define prep-sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+
+; Remplit les trous parmi les sharcs avec des arcs "erreur"
+(define prep-fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err) (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err) (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+
+; ; Passe d'une liste d'arcs a un arbre de decision
+; ; 1ere methode: seulement des comparaisons <
+; (define prep-arcs->tree
+; (lambda (arcs)
+; (let* ((sharcs-l (map prep-arc->sharcs arcs))
+; (sharcs (apply append sharcs-l))
+; (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
+; (sorted (prep-fill-error sorted-with-holes))
+; (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+; (table (list->vector (map op sorted))))
+; (let loop ((left 0) (right (- (vector-length table) 1)))
+; (if (= left right)
+; (cdr (vector-ref table left))
+; (let ((mid (quotient (+ left right 1) 2)))
+; (list (car (vector-ref table mid))
+; (loop left (- mid 1))
+; (loop mid right))))))))
+
+; Passe d'une liste d'arcs a un arbre de decision
+; 2eme methode: permettre des comparaisons = quand ca adonne
+(define prep-arcs->tree
+ (lambda (arcs)
+ (let* ((sharcs-l (map prep-arc->sharcs arcs))
+ (sharcs (apply append sharcs-l))
+ (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
+ (sorted (prep-fill-error sorted-with-holes))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op sorted))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right)))))))))
+
+; Determine si une action a besoin de calculer yytext
+(define prep-detect-yytext
+ (lambda (s)
+ (let loop1 ((i (- (string-length s) 6)))
+ (cond ((< i 0)
+ #f)
+ ((char-ci=? (string-ref s i) #\y)
+ (let loop2 ((j 5))
+ (cond ((= j 0)
+ #t)
+ ((char-ci=? (string-ref s (+ i j))
+ (string-ref "yytext" j))
+ (loop2 (- j 1)))
+ (else
+ (loop1 (- i 1))))))
+ (else
+ (loop1 (- i 1)))))))
+
+; Note dans une regle si son action a besoin de yytext
+(define prep-set-rule-yytext?
+ (lambda (rule)
+ (let ((action (get-rule-action rule)))
+ (set-rule-yytext? rule (prep-detect-yytext action)))))
+
+; Note dans toutes les regles si leurs actions ont besoin de yytext
+(define prep-set-rules-yytext?
+ (lambda (rules)
+ (let loop ((n (- (vector-length rules) 1)))
+ (if (>= n 0)
+ (begin
+ (prep-set-rule-yytext? (vector-ref rules n))
+ (loop (- n 1)))))))
+
+; Module output.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Nettoie les actions en enlevant les lignes blanches avant et apres
+;
+
+(define out-split-in-lines
+ (lambda (s)
+ (let ((len (string-length s)))
+ (let loop ((i 0) (start 0))
+ (cond ((= i len)
+ '())
+ ((char=? (string-ref s i) #\newline)
+ (cons (substring s start (+ i 1))
+ (loop (+ i 1) (+ i 1))))
+ (else
+ (loop (+ i 1) start)))))))
+
+(define out-empty-line?
+ (lambda (s)
+ (let ((len (- (string-length s) 1)))
+ (let loop ((i 0))
+ (cond ((= i len)
+ #t)
+ ((char-whitespace? (string-ref s i))
+ (loop (+ i 1)))
+ (else
+ #f))))))
+
+; Enleve les lignes vides dans une liste avant et apres l'action
+(define out-remove-empty-lines
+ (lambda (lines)
+ (let loop ((lines lines) (top? #t))
+ (if (null? lines)
+ '()
+ (let ((line (car lines)))
+ (cond ((not (out-empty-line? line))
+ (cons line (loop (cdr lines) #f)))
+ (top?
+ (loop (cdr lines) #t))
+ (else
+ (let ((rest (loop (cdr lines) #f)))
+ (if (null? rest)
+ '()
+ (cons line rest))))))))))
+
+; Enleve les lignes vides avant et apres l'action
+(define out-clean-action
+ (lambda (s)
+ (let* ((lines (out-split-in-lines s))
+ (clean-lines (out-remove-empty-lines lines)))
+ (string-append-list clean-lines))))
+
+
+
+
+;
+; Pretty-printer pour les booleens, la liste vide, les nombres,
+; les symboles, les caracteres, les chaines, les listes et les vecteurs
+;
+
+; Colonne limite pour le pretty-printer (a ne pas atteindre)
+(define out-max-col 76)
+
+(define out-flatten-list
+ (lambda (ll)
+ (let loop ((ll ll) (part-out '()))
+ (if (null? ll)
+ part-out
+ (let* ((new-part-out (loop (cdr ll) part-out))
+ (head (car ll)))
+ (cond ((null? head)
+ new-part-out)
+ ((pair? head)
+ (loop head new-part-out))
+ (else
+ (cons head new-part-out))))))))
+
+(define out-force-string
+ (lambda (obj)
+ (if (char? obj)
+ (string obj)
+ obj)))
+
+; Transforme une liste impropre en une liste propre qui s'ecrit
+; de la meme facon
+(define out-regular-list
+ (let ((symbolic-dot (string->symbol ".")))
+ (lambda (p)
+ (let ((tail (cdr p)))
+ (cond ((null? tail)
+ p)
+ ((pair? tail)
+ (cons (car p) (out-regular-list tail)))
+ (else
+ (list (car p) symbolic-dot tail)))))))
+
+; Cree des chaines d'espaces de facon paresseuse
+(define out-blanks
+ (let ((cache-v (make-vector 80 #f)))
+ (lambda (n)
+ (or (vector-ref cache-v n)
+ (let ((result (make-string n #\space)))
+ (vector-set! cache-v n result)
+ result)))))
+
+; Insere le separateur entre chaque element d'une liste non-vide
+(define out-separate
+ (lambda (text-l sep)
+ (if (null? (cdr text-l))
+ text-l
+ (cons (car text-l) (cons sep (out-separate (cdr text-l) sep))))))
+
+; Met des donnees en colonnes. Retourne comme out-pp-aux-list
+(define out-pp-columns
+ (lambda (left right wmax txt&lens)
+ (let loop1 ((tls txt&lens) (lwmax 0) (lwlast 0) (lines '()))
+ (if (null? tls)
+ (vector #t 0 lwmax lwlast (reverse lines))
+ (let loop2 ((tls tls) (len 0) (first? #t) (prev-pad 0) (line '()))
+ (cond ((null? tls)
+ (loop1 tls
+ (max len lwmax)
+ len
+ (cons (reverse line) lines)))
+ ((> (+ left len prev-pad 1 wmax) out-max-col)
+ (loop1 tls
+ (max len lwmax)
+ len
+ (cons (reverse line) lines)))
+ (first?
+ (let ((text (caar tls))
+ (text-len (cdar tls)))
+ (loop2 (cdr tls)
+ (+ len text-len)
+ #f
+ (- wmax text-len)
+ (cons text line))))
+ ((pair? (cdr tls))
+ (let* ((prev-pad-s (out-blanks prev-pad))
+ (text (caar tls))
+ (text-len (cdar tls)))
+ (loop2 (cdr tls)
+ (+ len prev-pad 1 text-len)
+ #f
+ (- wmax text-len)
+ (cons text (cons " " (cons prev-pad-s line))))))
+ (else
+ (let ((prev-pad-s (out-blanks prev-pad))
+ (text (caar tls))
+ (text-len (cdar tls)))
+ (if (> (+ left len prev-pad 1 text-len) right)
+ (loop1 tls
+ (max len lwmax)
+ len
+ (cons (reverse line) lines))
+ (loop2 (cdr tls)
+ (+ len prev-pad 1 text-len)
+ #f
+ (- wmax text-len)
+ (append (list text " " prev-pad-s)
+ line)))))))))))
+
+; Retourne un vecteur #( multiline? width-all width-max width-last text-l )
+(define out-pp-aux-list
+ (lambda (l left right)
+ (let loop ((l l) (multi? #f) (wall -1) (wmax -1) (wlast -1) (txt&lens '()))
+ (if (null? l)
+ (cond (multi?
+ (vector #t wall wmax wlast (map car (reverse txt&lens))))
+ ((<= (+ left wall) right)
+ (vector #f wall wmax wlast (map car (reverse txt&lens))))
+ ((<= (+ left wmax 1 wmax) out-max-col)
+ (out-pp-columns left right wmax (reverse txt&lens)))
+ (else
+ (vector #t wall wmax wlast (map car (reverse txt&lens)))))
+ (let* ((obj (car l))
+ (last? (null? (cdr l)))
+ (this-right (if last? right out-max-col))
+ (result (out-pp-aux obj left this-right))
+ (obj-multi? (vector-ref result 0))
+ (obj-wmax (vector-ref result 1))
+ (obj-wlast (vector-ref result 2))
+ (obj-text (vector-ref result 3)))
+ (loop (cdr l)
+ (or multi? obj-multi?)
+ (+ wall obj-wmax 1)
+ (max wmax obj-wmax)
+ obj-wlast
+ (cons (cons obj-text obj-wmax) txt&lens)))))))
+
+; Retourne un vecteur #( multiline? wmax wlast text )
+(define out-pp-aux
+ (lambda (obj left right)
+ (cond ((boolean? obj)
+ (vector #f 2 2 (if obj '("#t") '("#f"))))
+ ((null? obj)
+ (vector #f 2 2 '("()")))
+ ((number? obj)
+ (let* ((s (number->string obj))
+ (len (string-length s)))
+ (vector #f len len (list s))))
+ ((symbol? obj)
+ (let* ((s (symbol->string obj))
+ (len (string-length s)))
+ (vector #f len len (list s))))
+ ((char? obj)
+ (cond ((char=? obj #\space)
+ (vector #f 7 7 (list "#\\space")))
+ ((char=? obj #\newline)
+ (vector #f 9 9 (list "#\\newline")))
+ (else
+ (vector #f 3 3 (list "#\\" obj)))))
+ ((string? obj)
+ (let loop ((i (- (string-length obj) 1))
+ (len 1)
+ (text '("\"")))
+ (if (= i -1)
+ (vector #f (+ len 1) (+ len 1) (cons "\"" text))
+ (let ((c (string-ref obj i)))
+ (cond ((char=? c #\\)
+ (loop (- i 1) (+ len 2) (cons "\\\\" text)))
+ ((char=? c #\")
+ (loop (- i 1) (+ len 2) (cons "\\\"" text)))
+ (else
+ (loop (- i 1) (+ len 1) (cons (string c) text))))))))
+ ((pair? obj)
+ (let* ((l (out-regular-list obj))
+ (result (out-pp-aux-list l (+ left 1) (- right 1)))
+ (multiline? (vector-ref result 0))
+ (width-all (vector-ref result 1))
+ (width-max (vector-ref result 2))
+ (width-last (vector-ref result 3))
+ (text-l (vector-ref result 4)))
+ (if multiline?
+ (let* ((sep (list #\newline (out-blanks left)))
+ (formatted-text (out-separate text-l sep))
+ (text (list "(" formatted-text ")")))
+ (vector #t
+ (+ (max width-max (+ width-last 1)) 1)
+ (+ width-last 2)
+ text))
+ (let* ((sep (list " "))
+ (formatted-text (out-separate text-l sep))
+ (text (list "(" formatted-text ")")))
+ (vector #f (+ width-all 2) (+ width-all 2) text)))))
+ ((and (vector? obj) (zero? (vector-length obj)))
+ (vector #f 3 3 '("#()")))
+ ((vector? obj)
+ (let* ((l (vector->list obj))
+ (result (out-pp-aux-list l (+ left 2) (- right 1)))
+ (multiline? (vector-ref result 0))
+ (width-all (vector-ref result 1))
+ (width-max (vector-ref result 2))
+ (width-last (vector-ref result 3))
+ (text-l (vector-ref result 4)))
+ (if multiline?
+ (let* ((sep (list #\newline (out-blanks (+ left 1))))
+ (formatted-text (out-separate text-l sep))
+ (text (list "#(" formatted-text ")")))
+ (vector #t
+ (+ (max width-max (+ width-last 1)) 2)
+ (+ width-last 3)
+ text))
+ (let* ((sep (list " "))
+ (formatted-text (out-separate text-l sep))
+ (text (list "#(" formatted-text ")")))
+ (vector #f (+ width-all 3) (+ width-all 3) text)))))
+ (else
+ (display "Internal error: out-pp")
+ (newline)))))
+
+; Retourne la chaine a afficher
+(define out-pp
+ (lambda (obj col)
+ (let* ((list-rec-of-strings-n-chars
+ (vector-ref (out-pp-aux obj col out-max-col) 3))
+ (list-of-strings-n-chars
+ (out-flatten-list list-rec-of-strings-n-chars))
+ (list-of-strings
+ (map out-force-string list-of-strings-n-chars)))
+ (string-append-list list-of-strings))))
+
+
+
+
+;
+; Nice-printer, plus rapide mais moins beau que le pretty-printer
+;
+
+(define out-np
+ (lambda (obj start)
+ (letrec ((line-pad
+ (string-append (string #\newline)
+ (out-blanks (- start 1))))
+ (step-line
+ (lambda (p)
+ (set-car! p line-pad)))
+ (p-bool
+ (lambda (obj col objw texts hole cont)
+ (let ((text (if obj "#t" "#f")))
+ (cont (+ col 2) (+ objw 2) (cons text texts) hole))))
+ (p-number
+ (lambda (obj col objw texts hole cont)
+ (let* ((text (number->string obj))
+ (len (string-length text)))
+ (cont (+ col len) (+ objw len) (cons text texts) hole))))
+ (p-symbol
+ (lambda (obj col objw texts hole cont)
+ (let* ((text (symbol->string obj))
+ (len (string-length text)))
+ (cont (+ col len) (+ objw len) (cons text texts) hole))))
+ (p-char
+ (lambda (obj col objw texts hole cont)
+ (let* ((text
+ (cond ((char=? obj #\space) "#\\space")
+ ((char=? obj #\newline) "#\\newline")
+ (else (string-append "#\\" (string obj)))))
+ (len (string-length text)))
+ (cont (+ col len) (+ objw len) (cons text texts) hole))))
+ (p-list
+ (lambda (obj col objw texts hole cont)
+ (p-tail obj (+ col 1) (+ objw 1) (cons "(" texts) hole cont)))
+ (p-vector
+ (lambda (obj col objw texts hole cont)
+ (p-list (vector->list obj)
+ (+ col 1) (+ objw 1) (cons "#" texts) hole cont)))
+ (p-tail
+ (lambda (obj col objw texts hole cont)
+ (if (null? obj)
+ (cont (+ col 1) (+ objw 1) (cons ")" texts) hole)
+ (p-obj (car obj) col objw texts hole
+ (make-cdr-cont obj cont)))))
+ (make-cdr-cont
+ (lambda (obj cont)
+ (lambda (col objw texts hole)
+ (cond ((null? (cdr obj))
+ (cont (+ col 1) (+ objw 1) (cons ")" texts) hole))
+ ((> col out-max-col)
+ (step-line hole)
+ (let ((hole2 (cons " " texts)))
+ (p-cdr obj (+ start objw 1) 0 hole2 hole2 cont)))
+ (else
+ (let ((hole2 (cons " " texts)))
+ (p-cdr obj (+ col 1) 0 hole2 hole2 cont)))))))
+ (p-cdr
+ (lambda (obj col objw texts hole cont)
+ (if (pair? (cdr obj))
+ (p-tail (cdr obj) col objw texts hole cont)
+ (p-dot col objw texts hole
+ (make-cdr-cont (list #f (cdr obj)) cont)))))
+ (p-dot
+ (lambda (col objw texts hole cont)
+ (cont (+ col 1) (+ objw 1) (cons "." texts) hole)))
+ (p-obj
+ (lambda (obj col objw texts hole cont)
+ (cond ((boolean? obj)
+ (p-bool obj col objw texts hole cont))
+ ((number? obj)
+ (p-number obj col objw texts hole cont))
+ ((symbol? obj)
+ (p-symbol obj col objw texts hole cont))
+ ((char? obj)
+ (p-char obj col objw texts hole cont))
+ ((or (null? obj) (pair? obj))
+ (p-list obj col objw texts hole cont))
+ ((vector? obj)
+ (p-vector obj col objw texts hole cont))))))
+ (p-obj obj start 0 '() (cons #f #f)
+ (lambda (col objw texts hole)
+ (if (> col out-max-col)
+ (step-line hole))
+ (string-append-list (reverse texts)))))))
+
+
+
+
+;
+; Fonction pour afficher une table
+; Appelle la sous-routine adequate pour le type de fin de table
+;
+
+; Affiche la table d'un driver
+(define out-print-table
+ (lambda (args-alist
+ <<EOF>>-action <<ERROR>>-action rules
+ nl-start no-nl-start arcs-v acc-v
+ port)
+ (let* ((filein
+ (cdr (assq 'filein args-alist)))
+ (table-name
+ (cdr (assq 'table-name args-alist)))
+ (pretty?
+ (assq 'pp args-alist))
+ (counters-type
+ (let ((a (assq 'counters args-alist)))
+ (if a (cdr a) 'line)))
+ (counters-param-list
+ (cond ((eq? counters-type 'none)
+ ")")
+ ((eq? counters-type 'line)
+ " yyline)")
+ (else ; 'all
+ " yyline yycolumn yyoffset)")))
+ (counters-param-list-short
+ (if (char=? (string-ref counters-param-list 0) #\space)
+ (substring counters-param-list
+ 1
+ (string-length counters-param-list))
+ counters-param-list))
+ (clean-eof-action
+ (out-clean-action <<EOF>>-action))
+ (clean-error-action
+ (out-clean-action <<ERROR>>-action))
+ (rule-op
+ (lambda (rule) (out-clean-action (get-rule-action rule))))
+ (rules-l
+ (vector->list rules))
+ (clean-actions-l
+ (map rule-op rules-l))
+ (yytext?-l
+ (map get-rule-yytext? rules-l)))
+
+ ; Commentaires prealables
+ (display ";" port)
+ (newline port)
+ (display "; Table generated from the file " port)
+ (display filein port)
+ (display " by SILex 1.0" port)
+ (newline port)
+ (display ";" port)
+ (newline port)
+ (newline port)
+
+ ; Ecrire le debut de la table
+ (display "(define " port)
+ (display table-name port)
+ (newline port)
+ (display " (vector" port)
+ (newline port)
+
+ ; Ecrire la description du type de compteurs
+ (display " '" port)
+ (write counters-type port)
+ (newline port)
+
+ ; Ecrire l'action pour la fin de fichier
+ (display " (lambda (yycontinue yygetc yyungetc)" port)
+ (newline port)
+ (display " (lambda (yytext" port)
+ (display counters-param-list port)
+ (newline port)
+ (display clean-eof-action port)
+ (display " ))" port)
+ (newline port)
+
+ ; Ecrire l'action pour le cas d'erreur
+ (display " (lambda (yycontinue yygetc yyungetc)" port)
+ (newline port)
+ (display " (lambda (yytext" port)
+ (display counters-param-list port)
+ (newline port)
+ (display clean-error-action port)
+ (display " ))" port)
+ (newline port)
+
+ ; Ecrire le vecteur des actions des regles ordinaires
+ (display " (vector" port)
+ (newline port)
+ (let loop ((al clean-actions-l) (yyl yytext?-l))
+ (if (pair? al)
+ (let ((yytext? (car yyl)))
+ (display " " port)
+ (write yytext? port)
+ (newline port)
+ (display " (lambda (yycontinue yygetc yyungetc)" port)
+ (newline port)
+ (if yytext?
+ (begin
+ (display " (lambda (yytext" port)
+ (display counters-param-list port))
+ (begin
+ (display " (lambda (" port)
+ (display counters-param-list-short port)))
+ (newline port)
+ (display (car al) port)
+ (display " ))" port)
+ (if (pair? (cdr al))
+ (newline port))
+ (loop (cdr al) (cdr yyl)))))
+ (display ")" port)
+ (newline port)
+
+ ; Ecrire l'automate
+ (cond ((assq 'portable args-alist)
+ (out-print-table-chars
+ pretty?
+ nl-start no-nl-start arcs-v acc-v
+ port))
+ ((assq 'code args-alist)
+ (out-print-table-code
+ counters-type (vector-length rules) yytext?-l
+ nl-start no-nl-start arcs-v acc-v
+ port))
+ (else
+ (out-print-table-data
+ pretty?
+ nl-start no-nl-start arcs-v acc-v
+ port))))))
+
+;
+; Affiche l'automate sous forme d'arbres de decision
+; Termine la table du meme coup
+;
+
+(define out-print-table-data
+ (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
+ (let* ((len (vector-length arcs-v))
+ (trees-v (make-vector len)))
+ (let loop ((i 0))
+ (if (< i len)
+ (begin
+ (vector-set! trees-v i (prep-arcs->tree (vector-ref arcs-v i)))
+ (loop (+ i 1)))))
+
+ ; Decrire le format de l'automate
+ (display " 'decision-trees" port)
+ (newline port)
+
+ ; Ecrire l'etat de depart pour le cas "debut de la ligne"
+ (display " " port)
+ (write nl-start port)
+ (newline port)
+
+ ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
+ (display " " port)
+ (write no-nl-start port)
+ (newline port)
+
+ ; Ecrire la table de transitions
+ (display " '" port)
+ (if pretty?
+ (display (out-pp trees-v 5) port)
+ (display (out-np trees-v 5) port))
+ (newline port)
+
+ ; Ecrire la table des acceptations
+ (display " '" port)
+ (if pretty?
+ (display (out-pp acc-v 5) port)
+ (display (out-np acc-v 5) port))
+
+ ; Ecrire la fin de la table
+ (display "))" port)
+ (newline port))))
+
+;
+; Affiche l'automate sous forme de listes de caracteres taggees
+; Termine la table du meme coup
+;
+
+(define out-print-table-chars
+ (lambda (pretty? nl-start no-nl-start arcs-v acc-v port)
+ (let* ((len (vector-length arcs-v))
+ (portable-v (make-vector len))
+ (arc-op (lambda (arc)
+ (cons (class->tagged-char-list (car arc)) (cdr arc)))))
+ (let loop ((s 0))
+ (if (< s len)
+ (let* ((arcs (vector-ref arcs-v s))
+ (port-arcs (map arc-op arcs)))
+ (vector-set! portable-v s port-arcs)
+ (loop (+ s 1)))))
+
+ ; Decrire le format de l'automate
+ (display " 'tagged-chars-lists" port)
+ (newline port)
+
+ ; Ecrire l'etat de depart pour le cas "debut de la ligne"
+ (display " " port)
+ (write nl-start port)
+ (newline port)
+
+ ; Ecrire l'etat de depart pour le cas "pas au debut de la ligne"
+ (display " " port)
+ (write no-nl-start port)
+ (newline port)
+
+ ; Ecrire la table de transitions
+ (display " '" port)
+ (if pretty?
+ (display (out-pp portable-v 5) port)
+ (display (out-np portable-v 5) port))
+ (newline port)
+
+ ; Ecrire la table des acceptations
+ (display " '" port)
+ (if pretty?
+ (display (out-pp acc-v 5) port)
+ (display (out-np acc-v 5) port))
+
+ ; Ecrire la fin de la table
+ (display "))" port)
+ (newline port))))
+
+;
+; Genere l'automate en code Scheme
+; Termine la table du meme coup
+;
+
+(define out-print-code-trans3
+ (lambda (margin tree action-var port)
+ (newline port)
+ (display (out-blanks margin) port)
+ (cond ((eq? tree 'err)
+ (display action-var port))
+ ((number? tree)
+ (display "(state-" port)
+ (display tree port)
+ (display " " port)
+ (display action-var port)
+ (display ")" port))
+ ((eq? (car tree) '=)
+ (display "(if (= c " port)
+ (display (list-ref tree 1) port)
+ (display ")" port)
+ (out-print-code-trans3 (+ margin 4)
+ (list-ref tree 2)
+ action-var
+ port)
+ (out-print-code-trans3 (+ margin 4)
+ (list-ref tree 3)
+ action-var
+ port)
+ (display ")" port))
+ (else
+ (display "(if (< c " port)
+ (display (list-ref tree 0) port)
+ (display ")" port)
+ (out-print-code-trans3 (+ margin 4)
+ (list-ref tree 1)
+ action-var
+ port)
+ (out-print-code-trans3 (+ margin 4)
+ (list-ref tree 2)
+ action-var
+ port)
+ (display ")" port)))))
+
+(define out-print-code-trans2
+ (lambda (margin tree action-var port)
+ (newline port)
+ (display (out-blanks margin) port)
+ (display "(if c" port)
+ (out-print-code-trans3 (+ margin 4) tree action-var port)
+ (newline port)
+ (display (out-blanks (+ margin 4)) port)
+ (display action-var port)
+ (display ")" port)))
+
+(define out-print-code-trans1
+ (lambda (margin tree action-var port)
+ (newline port)
+ (display (out-blanks margin) port)
+ (if (eq? tree 'err)
+ (display action-var port)
+ (begin
+ (display "(let ((c (read-char)))" port)
+ (out-print-code-trans2 (+ margin 2) tree action-var port)
+ (display ")" port)))))
+
+(define out-print-table-code
+ (lambda (counters nbrules yytext?-l
+ nl-start no-nl-start arcs-v acc-v
+ port)
+ (let* ((counters-params
+ (cond ((eq? counters 'none) ")")
+ ((eq? counters 'line) " yyline)")
+ ((eq? counters 'all) " yyline yycolumn yyoffset)")))
+ (counters-params-short
+ (cond ((eq? counters 'none) ")")
+ ((eq? counters 'line) "yyline)")
+ ((eq? counters 'all) "yyline yycolumn yyoffset)")))
+ (nbstates (vector-length arcs-v))
+ (trees-v (make-vector nbstates)))
+ (let loop ((s 0))
+ (if (< s nbstates)
+ (begin
+ (vector-set! trees-v s (prep-arcs->tree (vector-ref arcs-v s)))
+ (loop (+ s 1)))))
+
+ ; Decrire le format de l'automate
+ (display " 'code" port)
+ (newline port)
+
+ ; Ecrire l'entete de la fonction
+ (display " (lambda (<<EOF>>-pre-action" port)
+ (newline port)
+ (display " <<ERROR>>-pre-action" port)
+ (newline port)
+ (display " rules-pre-action" port)
+ (newline port)
+ (display " IS)" port)
+ (newline port)
+
+ ; Ecrire le debut du letrec et les variables d'actions brutes
+ (display " (letrec" port)
+ (newline port)
+ (display " ((user-action-<<EOF>> #f)" port)
+ (newline port)
+ (display " (user-action-<<ERROR>> #f)" port)
+ (newline port)
+ (let loop ((i 0))
+ (if (< i nbrules)
+ (begin
+ (display " (user-action-" port)
+ (write i port)
+ (display " #f)" port)
+ (newline port)
+ (loop (+ i 1)))))
+
+ ; Ecrire l'extraction des fonctions du IS
+ (display " (start-go-to-end " port)
+ (display "(cdr (assq 'start-go-to-end IS)))" port)
+ (newline port)
+ (display " (end-go-to-point " port)
+ (display "(cdr (assq 'end-go-to-point IS)))" port)
+ (newline port)
+ (display " (init-lexeme " port)
+ (display "(cdr (assq 'init-lexeme IS)))" port)
+ (newline port)
+ (display " (get-start-line " port)
+ (display "(cdr (assq 'get-start-line IS)))" port)
+ (newline port)
+ (display " (get-start-column " port)
+ (display "(cdr (assq 'get-start-column IS)))" port)
+ (newline port)
+ (display " (get-start-offset " port)
+ (display "(cdr (assq 'get-start-offset IS)))" port)
+ (newline port)
+ (display " (peek-left-context " port)
+ (display "(cdr (assq 'peek-left-context IS)))" port)
+ (newline port)
+ (display " (peek-char " port)
+ (display "(cdr (assq 'peek-char IS)))" port)
+ (newline port)
+ (display " (read-char " port)
+ (display "(cdr (assq 'read-char IS)))" port)
+ (newline port)
+ (display " (get-start-end-text " port)
+ (display "(cdr (assq 'get-start-end-text IS)))" port)
+ (newline port)
+ (display " (user-getc " port)
+ (display "(cdr (assq 'user-getc IS)))" port)
+ (newline port)
+ (display " (user-ungetc " port)
+ (display "(cdr (assq 'user-ungetc IS)))" port)
+ (newline port)
+
+ ; Ecrire les variables d'actions
+ (display " (action-<<EOF>>" port)
+ (newline port)
+ (display " (lambda (" port)
+ (display counters-params-short port)
+ (newline port)
+ (display " (user-action-<<EOF>> \"\"" port)
+ (display counters-params port)
+ (display "))" port)
+ (newline port)
+ (display " (action-<<ERROR>>" port)
+ (newline port)
+ (display " (lambda (" port)
+ (display counters-params-short port)
+ (newline port)
+ (display " (user-action-<<ERROR>> \"\"" port)
+ (display counters-params port)
+ (display "))" port)
+ (newline port)
+ (let loop ((i 0) (yyl yytext?-l))
+ (if (< i nbrules)
+ (begin
+ (display " (action-" port)
+ (display i port)
+ (newline port)
+ (display " (lambda (" port)
+ (display counters-params-short port)
+ (newline port)
+ (if (car yyl)
+ (begin
+ (display " (let ((yytext" port)
+ (display " (get-start-end-text)))" port)
+ (newline port)
+ (display " (start-go-to-end)" port)
+ (newline port)
+ (display " (user-action-" port)
+ (display i port)
+ (display " yytext" port)
+ (display counters-params port)
+ (display ")))" port)
+ (newline port))
+ (begin
+ (display " (start-go-to-end)" port)
+ (newline port)
+ (display " (user-action-" port)
+ (display i port)
+ (display counters-params port)
+ (display "))" port)
+ (newline port)))
+ (loop (+ i 1) (cdr yyl)))))
+
+ ; Ecrire les variables d'etats
+ (let loop ((s 0))
+ (if (< s nbstates)
+ (let* ((tree (vector-ref trees-v s))
+ (acc (vector-ref acc-v s))
+ (acc-eol (car acc))
+ (acc-no-eol (cdr acc)))
+ (display " (state-" port)
+ (display s port)
+ (newline port)
+ (display " (lambda (action)" port)
+ (cond ((not acc-eol)
+ (out-print-code-trans1 13 tree "action" port))
+ ((not acc-no-eol)
+ (newline port)
+ (if (eq? tree 'err)
+ (display " (let* ((c (peek-char))" port)
+ (display " (let* ((c (read-char))" port))
+ (newline port)
+ (display " (new-action (if (o" port)
+ (display "r (not c) (= c lexer-integer-newline))" port)
+ (newline port)
+ (display " " port)
+ (display " (begin (end-go-to-point) action-" port)
+ (display acc-eol port)
+ (display ")" port)
+ (newline port)
+ (display " " port)
+ (display " action)))" port)
+ (if (eq? tree 'err)
+ (out-print-code-trans1 15 tree "new-action" port)
+ (out-print-code-trans2 15 tree "new-action" port))
+ (display ")" port))
+ ((< acc-eol acc-no-eol)
+ (newline port)
+ (display " (end-go-to-point)" port)
+ (newline port)
+ (if (eq? tree 'err)
+ (display " (let* ((c (peek-char))" port)
+ (display " (let* ((c (read-char))" port))
+ (newline port)
+ (display " (new-action (if (o" port)
+ (display "r (not c) (= c lexer-integer-newline))" port)
+ (newline port)
+ (display " " port)
+ (display " action-" port)
+ (display acc-eol port)
+ (newline port)
+ (display " " port)
+ (display " action-" port)
+ (display acc-no-eol port)
+ (display ")))" port)
+ (if (eq? tree 'err)
+ (out-print-code-trans1 15 tree "new-action" port)
+ (out-print-code-trans2 15 tree "new-action" port))
+ (display ")" port))
+ (else
+ (let ((action-var
+ (string-append "action-"
+ (number->string acc-eol))))
+ (newline port)
+ (display " (end-go-to-point)" port)
+ (out-print-code-trans1 13 tree action-var port))))
+ (display "))" port)
+ (newline port)
+ (loop (+ s 1)))))
+
+ ; Ecrire la variable de lancement de l'automate
+ (display " (start-automaton" port)
+ (newline port)
+ (display " (lambda ()" port)
+ (newline port)
+ (if (= nl-start no-nl-start)
+ (begin
+ (display " (if (peek-char)" port)
+ (newline port)
+ (display " (state-" port)
+ (display nl-start port)
+ (display " action-<<ERROR>>)" port)
+ (newline port)
+ (display " action-<<EOF>>)" port))
+ (begin
+ (display " (cond ((not (peek-char))" port)
+ (newline port)
+ (display " action-<<EOF>>)" port)
+ (newline port)
+ (display " ((= (peek-left-context)" port)
+ (display " lexer-integer-newline)" port)
+ (newline port)
+ (display " (state-" port)
+ (display nl-start port)
+ (display " action-<<ERROR>>))" port)
+ (newline port)
+ (display " (else" port)
+ (newline port)
+ (display " (state-" port)
+ (display no-nl-start port)
+ (display " action-<<ERROR>>)))" port)))
+ (display "))" port)
+ (newline port)
+
+ ; Ecrire la fonction principale de lexage
+ (display " (final-lexer" port)
+ (newline port)
+ (display " (lambda ()" port)
+ (newline port)
+ (display " (init-lexeme)" port)
+ (newline port)
+ (cond ((eq? counters 'none)
+ (display " ((start-automaton))" port))
+ ((eq? counters 'line)
+ (display " (let ((yyline (get-start-line)))" port)
+ (newline port)
+ (display " ((start-automaton) yyline))" port))
+ ((eq? counters 'all)
+ (display " (let ((yyline (get-start-line))" port)
+ (newline port)
+ (display " (yycolumn (get-start-column))" port)
+ (newline port)
+ (display " (yyoffset (get-start-offset)))" port)
+ (newline port)
+ (display " ((start-automat" port)
+ (display "on) yyline yycolumn yyoffset))" port)))
+ (display "))" port)
+
+ ; Fermer les bindings du grand letrec
+ (display ")" port)
+ (newline port)
+
+ ; Initialiser les variables user-action-XX
+ (display " (set! user-action-<<EOF>>" port)
+ (display " (<<EOF>>-pre-action" port)
+ (newline port)
+ (display " final-lexer" port)
+ (display " user-getc user-ungetc))" port)
+ (newline port)
+ (display " (set! user-action-<<ERROR>>" port)
+ (display " (<<ERROR>>-pre-action" port)
+ (newline port)
+ (display " final-lexer" port)
+ (display " user-getc user-ungetc))" port)
+ (newline port)
+ (let loop ((r 0))
+ (if (< r nbrules)
+ (let* ((str-r (number->string r))
+ (blanks (out-blanks (string-length str-r))))
+ (display " (set! user-action-" port)
+ (display str-r port)
+ (display " ((vector-ref rules-pre-action " port)
+ (display (number->string (+ (* 2 r) 1)) port)
+ (display ")" port)
+ (newline port)
+ (display blanks port)
+ (display " final-lexer " port)
+ (display "user-getc user-ungetc))" port)
+ (newline port)
+ (loop (+ r 1)))))
+
+ ; Faire retourner le lexer final et fermer la table au complet
+ (display " final-lexer))))" port)
+ (newline port))))
+
+;
+; Fonctions necessaires a l'initialisation automatique du lexer
+;
+
+(define out-print-driver-functions
+ (lambda (args-alist port)
+ (let ((counters (cdr (or (assq 'counters args-alist) '(z . line))))
+ (table-name (cdr (assq 'table-name args-alist))))
+ (display ";" port)
+ (newline port)
+ (display "; User functions" port)
+ (newline port)
+ (display ";" port)
+ (newline port)
+ (newline port)
+ (display "(define lexer #f)" port)
+ (newline port)
+ (newline port)
+ (if (not (eq? counters 'none))
+ (begin
+ (display "(define lexer-get-line #f)" port)
+ (newline port)
+ (if (eq? counters 'all)
+ (begin
+ (display "(define lexer-get-column #f)" port)
+ (newline port)
+ (display "(define lexer-get-offset #f)" port)
+ (newline port)))))
+ (display "(define lexer-getc #f)" port)
+ (newline port)
+ (display "(define lexer-ungetc #f)" port)
+ (newline port)
+ (newline port)
+ (display "(define lexer-init" port)
+ (newline port)
+ (display " (lambda (input-type input)" port)
+ (newline port)
+ (display " (let ((IS (lexer-make-IS input-type input '" port)
+ (write counters port)
+ (display ")))" port)
+ (newline port)
+ (display " (set! lexer (lexer-make-lexer " port)
+ (display table-name port)
+ (display " IS))" port)
+ (newline port)
+ (if (not (eq? counters 'none))
+ (begin
+ (display " (set! lexer-get-line (lexer-get-func-line IS))"
+ port)
+ (newline port)
+ (if (eq? counters 'all)
+ (begin
+ (display
+ " (set! lexer-get-column (lexer-get-func-column IS))"
+ port)
+ (newline port)
+ (display
+ " (set! lexer-get-offset (lexer-get-func-offset IS))"
+ port)
+ (newline port)))))
+ (display " (set! lexer-getc (lexer-get-func-getc IS))" port)
+ (newline port)
+ (display " (set! lexer-ungetc (lexer-get-func-ungetc IS)))))"
+ port)
+ (newline port))))
+
+;
+; Fonction principale
+; Affiche une table ou un driver complet
+;
+
+(define output
+ (lambda (args-alist
+ <<EOF>>-action <<ERROR>>-action rules
+ nl-start no-nl-start arcs acc)
+ (let* ((fileout (cdr (assq 'fileout args-alist)))
+ (port (open-output-file fileout))
+ (complete-driver? (cdr (assq 'complete-driver? args-alist))))
+ (if complete-driver?
+ (begin
+ (out-print-run-time-lib port)
+ (newline port)))
+ (out-print-table args-alist
+ <<EOF>>-action <<ERROR>>-action rules
+ nl-start no-nl-start arcs acc
+ port)
+ (if complete-driver?
+ (begin
+ (newline port)
+ (out-print-driver-functions args-alist port)))
+ (close-output-port port))))
+
+; Module output2.scm.
+;
+; Fonction de copiage du fichier run-time
+;
+
+(define out-print-run-time-lib
+ (lambda (port)
+ (display "; *** This file start" port)
+ (display "s with a copy of the " port)
+ (display "file multilex.scm ***" port)
+ (newline port)
+ (display "; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+ (lambda (buffer read-ptr input-f counters)
+ (let ((input-f input-f) ; Entree reelle
+ (buffer buffer) ; Buffer
+ (buflen (string-length buffer))
+ (read-ptr read-ptr)
+ (start-ptr 1) ; Marque de debut de lexeme
+ (start-line 1)
+ (start-column 1)
+ (start-offset 0)
+ (end-ptr 1) ; Marque de fin de lexeme
+ (point-ptr 1) ; Le point
+ (user-ptr 1) ; Marque de l'usager
+ (user-line 1)
+ (user-column 1)
+ (user-offset 0)
+ (user-up-to-date? #t)) ; Concerne la colonne seul.
+ (letrec
+ ((start-go-to-end-none ; Fonctions de depl. des marques
+ (lambda ()
+ (set! start-ptr end-ptr)))
+ (start-go-to-end-line
+ (lambda ()
+ (let loop ((ptr start-ptr) (line start-line))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line))
+ (if (char=? (string-ref buffer ptr) #\\newline)
+ (loop (+ ptr 1) (+ line 1))
+ (loop (+ ptr 1) line))))))
+ (start-go-to-end-all
+ (lambda ()
+ (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+ (let loop ((ptr start-ptr)
+ (line start-line)
+ (column start-column))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\\newline)
+ (loop (+ ptr 1) (+ line 1) 1)
+ (loop (+ ptr 1) line (+ column 1)))))))
+ (start-go-to-user-none
+ (lambda ()
+ (set! start-ptr user-ptr)))
+ (start-go-to-user-line
+ (lambda ()
+ (set! start-ptr user-ptr)
+ (set! start-line user-line)))
+ (start-go-to-user-all
+ (lambda ()
+ (set! start-line user-line)
+ (set! start-offset user-offset)
+ (if user-up-to-date?
+ (begin
+ (set! start-ptr user-ptr)
+ (set! start-column user-column))
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1))))))))
+ (end-go-to-point
+ (lambda ()
+ (set! end-ptr point-ptr)))
+ (point-go-to-start
+ (lambda ()
+ (set! point-ptr start-ptr)))
+ (user-go-to-start-none
+ (lambda ()
+ (set! user-ptr start-ptr)))
+ (user-go-to-start-line
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)))
+ (user-go-to-start-all
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)
+ (set! user-column start-column)
+ (set! user-offset start-offset)
+ (set! user-up-to-date? #t)))
+ (init-lexeme-none ; Debute un nouveau lexeme
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-none))
+ (point-go-to-start)))
+ (init-lexeme-line
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-line))
+ (point-go-to-start)))
+ (init-lexeme-all
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-all))
+ (point-go-to-start)))
+ (get-start-line ; Obtention des stats du debut du lxm
+ (lambda ()
+ start-line))
+ (get-start-column
+ (lambda ()
+ start-column))
+ (get-start-offset
+ (lambda ()
+ start-offset))
+ (peek-left-context ; Obtention de caracteres (#f si EOF)
+ (lambda ()
+ (char->integer (string-ref buffer (- start-ptr 1)))))
+ (peek-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (char->integer (string-ref buffer point-ptr))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (read-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (let ((c (string-ref buffer point-ptr)))
+ (set! point-ptr (+ point-ptr 1))
+ (char->integer c))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (set! point-ptr read-ptr)
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (get-start-end-text ; Obtention du lexeme
+ (lambda ()
+ (substring buffer start-ptr end-ptr)))
+ (get-user-line-line ; Fonctions pour l'usager
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ user-line))
+ (get-user-line-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-line))
+ (get-user-column-all
+ (lambda ()
+ (cond ((< user-ptr start-ptr)
+ (user-go-to-start-all)
+ user-column)
+ (user-up-to-date?
+ user-column)
+ (else
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! user-column column)
+ (set! user-up-to-date? #t)
+ column)
+ (if (char=? (string-ref buffer ptr) #\\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1)))))))))
+ (get-user-offset-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-offset))
+ (user-getc-none
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-none))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-line
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-ungetc-none
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (set! user-ptr (- user-ptr 1)))))
+ (user-ungetc-line
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\\newline)
+ (set! user-line (- user-line 1))))))))
+ (user-ungetc-all
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\\newline)
+ (begin
+ (set! user-line (- user-line 1))
+ (set! user-up-to-date? #f))
+ (set! user-column (- user-column 1)))
+ (set! user-offset (- user-offset 1)))))))
+ (reorganize-buffer ; Decaler ou agrandir le buffer
+ (lambda ()
+ (if (< (* 2 start-ptr) buflen)
+ (let* ((newlen (* 2 buflen))
+ (newbuf (make-string newlen))
+ (delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! newbuf
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! buffer newbuf)
+ (set! buflen newlen)
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))
+ (let ((delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! buffer
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))))))
+ (list (cons 'start-go-to-end
+ (cond ((eq? counters 'none) start-go-to-end-none)
+ ((eq? counters 'line) start-go-to-end-line)
+ ((eq? counters 'all ) start-go-to-end-all)))
+ (cons 'end-go-to-point
+ end-go-to-point)
+ (cons 'init-lexeme
+ (cond ((eq? counters 'none) init-lexeme-none)
+ ((eq? counters 'line) init-lexeme-line)
+ ((eq? counters 'all ) init-lexeme-all)))
+ (cons 'get-start-line
+ get-start-line)
+ (cons 'get-start-column
+ get-start-column)
+ (cons 'get-start-offset
+ get-start-offset)
+ (cons 'peek-left-context
+ peek-left-context)
+ (cons 'peek-char
+ peek-char)
+ (cons 'read-char
+ read-char)
+ (cons 'get-start-end-text
+ get-start-end-text)
+ (cons 'get-user-line
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) get-user-line-line)
+ ((eq? counters 'all ) get-user-line-all)))
+ (cons 'get-user-column
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-column-all)))
+ (cons 'get-user-offset
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-offset-all)))
+ (cons 'user-getc
+ (cond ((eq? counters 'none) user-getc-none)
+ ((eq? counters 'line) user-getc-line)
+ ((eq? counters 'all ) user-getc-all)))
+ (cons 'user-ungetc
+ (cond ((eq? counters 'none) user-ungetc-none)
+ ((eq? counters 'line) user-ungetc-line)
+ ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi \"port\", \"procedure\" ou \"string\"
+; Prend un parametre facultatif qui doit etre parmi
+; \"none\", \"line\" ou \"all\"
+(define lexer-make-IS
+ (lambda (input-type input . largs)
+ (let ((counters-type (cond ((null? largs)
+ 'line)
+ ((memq (car largs) '(none line all))
+ (car largs))
+ (else
+ 'line))))
+ (cond ((and (eq? input-type 'port) (input-port? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\\newline))
+ (read-ptr 1)
+ (input-f (lambda () (read-char input))))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'procedure) (procedure? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\\newline))
+ (read-ptr 1)
+ (input-f input))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'string) (string? input))
+ (let* ((buffer (string-append (string #\\newline) input))
+ (read-ptr (string-length buffer))
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ (else
+ (let* ((buffer (string #\\newline))
+ (read-ptr 1)
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+; lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+ (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+ (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+ (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+ (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+ (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+ (lambda (tables IS)
+ (letrec
+ (; Contenu de la table
+ (counters-type (vector-ref tables 0))
+ (<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-actions (vector-ref tables 3))
+ (table-nl-start (vector-ref tables 5))
+ (table-no-nl-start (vector-ref tables 6))
+ (trees-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8))
+
+ ; Contenu du IS
+ (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
+ (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
+ (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
+ (IS-get-start-line (cdr (assq 'get-start-line IS)))
+ (IS-get-start-column (cdr (assq 'get-start-column IS)))
+ (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
+ (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
+ (IS-peek-char (cdr (assq 'peek-char IS)))
+ (IS-read-char (cdr (assq 'read-char IS)))
+ (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+ (IS-get-user-line (cdr (assq 'get-user-line IS)))
+ (IS-get-user-column (cdr (assq 'get-user-column IS)))
+ (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
+ (IS-user-getc (cdr (assq 'user-getc IS)))
+ (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
+
+ ; Resultats
+ (<<EOF>>-action #f)
+ (<<ERROR>>-action #f)
+ (rules-actions #f)
+ (states #f)
+ (final-lexer #f)
+
+ ; Gestion des hooks
+ (hook-list '())
+ (add-hook
+ (lambda (thunk)
+ (set! hook-list (cons thunk hook-list))))
+ (apply-hooks
+ (lambda ()
+ (let loop ((l hook-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))))
+
+ ; Preparation des actions
+ (set-action-statics
+ (lambda (pre-action)
+ (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+ (prepare-special-action-none
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda ()
+ (action \"\")))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-line
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline)
+ (action \"\" yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-all
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (action \"\" yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-special-action-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-special-action-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-special-action-all pre-action)))))
+ (prepare-action-yytext-none
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-line
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-all
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline yycolumn yyoffset))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-yytext-all pre-action)))))
+ (prepare-action-no-yytext-none
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (start-go-to-end)
+ (action)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-line
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (start-go-to-end)
+ (action yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-all
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (start-go-to-end)
+ (action yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-no-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-no-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-no-yytext-all pre-action)))))
+
+ ; Fabrique les fonctions de dispatch
+ (prepare-dispatch-err
+ (lambda (leaf)
+ (lambda (c)
+ #f)))
+ (prepare-dispatch-number
+ (lambda (leaf)
+ (let ((state-function #f))
+ (let ((result
+ (lambda (c)
+ state-function))
+ (hook
+ (lambda ()
+ (set! state-function (vector-ref states leaf)))))
+ (add-hook hook)
+ result))))
+ (prepare-dispatch-leaf
+ (lambda (leaf)
+ (if (eq? leaf 'err)
+ (prepare-dispatch-err leaf)
+ (prepare-dispatch-number leaf))))
+ (prepare-dispatch-<
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 1))
+ (right-tree (list-ref tree 2)))
+ (let ((bound (list-ref tree 0))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (< c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-=
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 2))
+ (right-tree (list-ref tree 3)))
+ (let ((bound (list-ref tree 1))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (= c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-tree
+ (lambda (tree)
+ (cond ((not (pair? tree))
+ (prepare-dispatch-leaf tree))
+ ((eq? (car tree) '=)
+ (prepare-dispatch-= tree))
+ (else
+ (prepare-dispatch-< tree)))))
+ (prepare-dispatch
+ (lambda (tree)
+ (let ((dicho-func (prepare-dispatch-tree tree)))
+ (lambda (c)
+ (and c (dicho-func c))))))
+
+ ; Fabrique les fonctions de transition (read & go) et (abort)
+ (prepare-read-n-go
+ (lambda (tree)
+ (let ((dispatch-func (prepare-dispatch tree))
+ (read-char IS-read-char))
+ (lambda ()
+ (dispatch-func (read-char))))))
+ (prepare-abort
+ (lambda (tree)
+ (lambda ()
+ #f)))
+ (prepare-transition
+ (lambda (tree)
+ (if (eq? tree 'err)
+ (prepare-abort tree)
+ (prepare-read-n-go tree))))
+
+ ; Fabrique les fonctions d'etats ([set-end] & trans)
+ (prepare-state-no-acc
+ (lambda (s r1 r2)
+ (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+ (lambda (action)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state action)
+ action))))))
+ (prepare-state-yes-no
+ (lambda (s r1 r2)
+ (let ((peek-char IS-peek-char)
+ (end-go-to-point IS-end-go-to-point)
+ (new-action1 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ (begin
+ (end-go-to-point)
+ new-action1)
+ action))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-diff-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (peek-char IS-peek-char)
+ (new-action1 #f)
+ (new-action2 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ new-action1
+ new-action2))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1))
+ (set! new-action2 (vector-ref rules-actions r2)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-same-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (trans-func (prepare-transition (vector-ref trees-v s)))
+ (new-action #f))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state
+ (lambda (s)
+ (let* ((acc (vector-ref acc-v s))
+ (r1 (car acc))
+ (r2 (cdr acc)))
+ (cond ((not r1) (prepare-state-no-acc s r1 r2))
+ ((not r2) (prepare-state-yes-no s r1 r2))
+ ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+ (else (prepare-state-same-acc s r1 r2))))))
+
+ ; Fabrique la fonction de lancement du lexage a l'etat de depart
+ (prepare-start-same
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (start-state #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (if (not (peek-char))
+ eof-action
+ (start-state error-action))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state (vector-ref states s1))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start-diff
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (peek-left-context IS-peek-left-context)
+ (start-state1 #f)
+ (start-state2 #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (cond ((not (peek-char))
+ eof-action)
+ ((= (peek-left-context) lexer-integer-newline)
+ (start-state1 error-action))
+ (else
+ (start-state2 error-action)))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state1 (vector-ref states s1))
+ (set! start-state2 (vector-ref states s2))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start
+ (lambda ()
+ (let ((s1 table-nl-start)
+ (s2 table-no-nl-start))
+ (if (= s1 s2)
+ (prepare-start-same s1 s2)
+ (prepare-start-diff s1 s2)))))
+
+ ; Fabrique la fonction principale
+ (prepare-lexer-none
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ ((start-func))))))
+ (prepare-lexer-line
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line)))
+ ((start-func) yyline))))))
+ (prepare-lexer-all
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (get-start-column IS-get-start-column)
+ (get-start-offset IS-get-start-offset)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line))
+ (yycolumn (get-start-column))
+ (yyoffset (get-start-offset)))
+ ((start-func) yyline yycolumn yyoffset))))))
+ (prepare-lexer
+ (lambda ()
+ (cond ((eq? counters-type 'none) (prepare-lexer-none))
+ ((eq? counters-type 'line) (prepare-lexer-line))
+ ((eq? counters-type 'all) (prepare-lexer-all))))))
+
+ ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+ (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
+ (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+ ; Calculer la valeur de rules-actions
+ (let* ((len (quotient (vector-length rules-pre-actions) 2))
+ (v (make-vector len)))
+ (let loop ((r (- len 1)))
+ (if (< r 0)
+ (set! rules-actions v)
+ (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+ (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+ (action (if yytext?
+ (prepare-action-yytext pre-action)
+ (prepare-action-no-yytext pre-action))))
+ (vector-set! v r action)
+ (loop (- r 1))))))
+
+ ; Calculer la valeur de states
+ (let* ((len (vector-length trees-v))
+ (v (make-vector len)))
+ (let loop ((s (- len 1)))
+ (if (< s 0)
+ (set! states v)
+ (begin
+ (vector-set! v s (prepare-state s))
+ (loop (- s 1))))))
+
+ ; Calculer la valeur de final-lexer
+ (set! final-lexer (prepare-lexer))
+
+ ; Executer les hooks
+ (apply-hooks)
+
+ ; Resultat
+ final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+ (let* ((char->class
+ (lambda (c)
+ (let ((n (char->integer c)))
+ (list (cons n n)))))
+ (merge-sort
+ (lambda (l combine zero-elt)
+ (if (null? l)
+ zero-elt
+ (let loop1 ((l l))
+ (if (null? (cdr l))
+ (car l)
+ (loop1
+ (let loop2 ((l l))
+ (cond ((null? l)
+ l)
+ ((null? (cdr l))
+ l)
+ (else
+ (cons (combine (car l) (cadr l))
+ (loop2 (cddr l))))))))))))
+ (finite-class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (<= r1start r2start)
+ (cond ((< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((>= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+ (char-list->class
+ (lambda (cl)
+ (let ((classes (map char->class cl)))
+ (merge-sort classes finite-class-union '()))))
+ (class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+ (finite-class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (loop (cdr c) (+ rend 1))))))))
+ (tagged-chars->class
+ (lambda (tcl)
+ (let* ((inverse? (car tcl))
+ (cl (cdr tcl))
+ (class-tmp (char-list->class cl)))
+ (if inverse? (finite-class-compl class-tmp) class-tmp))))
+ (charc->arc
+ (lambda (charc)
+ (let* ((tcl (car charc))
+ (dest (cdr charc))
+ (class (tagged-chars->class tcl)))
+ (cons class dest))))
+ (arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+ (class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+ (sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+ (merge-sharcs
+ (lambda (l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((sharc1 (car l1))
+ (sharc2 (car l2)))
+ (if (sharc-<= sharc1 sharc2)
+ (cons sharc1 (loop (cdr l1) l2))
+ (cons sharc2 (loop l1 (cdr l2))))))))))
+ (class-= eqv?)
+ (fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err)
+ (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err)
+ (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+ (charcs->tree
+ (lambda (charcs)
+ (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+ (sharcs-l (map op charcs))
+ (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+ (full-sharcs (fill-error sorted-sharcs))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op full-sharcs))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right))))))))))
+ (lambda (tables IS)
+ (let ((counters (vector-ref tables 0))
+ (<<EOF>>-action (vector-ref tables 1))
+ (<<ERROR>>-action (vector-ref tables 2))
+ (rules-actions (vector-ref tables 3))
+ (nl-start (vector-ref tables 5))
+ (no-nl-start (vector-ref tables 6))
+ (charcs-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8)))
+ (let* ((len (vector-length charcs-v))
+ (v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+ (loop (- i 1)))
+ (lexer-make-tree-lexer
+ (vector counters
+ <<EOF>>-action
+ <<ERROR>>-action
+ rules-actions
+ 'decision-trees
+ nl-start
+ no-nl-start
+ v
+ acc-v)
+ IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+ (lambda (tables IS)
+ (let ((<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-action (vector-ref tables 3))
+ (code (vector-ref tables 5)))
+ (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+ (lambda (tables IS)
+ (let ((automaton-type (vector-ref tables 4)))
+ (cond ((eq? automaton-type 'decision-trees)
+ (lexer-make-tree-lexer tables IS))
+ ((eq? automaton-type 'tagged-chars-lists)
+ (lexer-make-char-lexer tables IS))
+ ((eq? automaton-type 'code)
+ (lexer-make-code-lexer tables IS))))))
+" port)))
+
+; Module main.scm.
+; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
+; All rights reserved.
+; SILex 1.0.
+
+;
+; Gestion d'erreurs
+;
+
+(define lex-exit-continuation #f)
+(define lex-unwind-protect-list '())
+(define lex-error-filename #f)
+
+(define lex-unwind-protect
+ (lambda (proc)
+ (set! lex-unwind-protect-list (cons proc lex-unwind-protect-list))))
+
+(define lex-error
+ (lambda (line column . l)
+ (let* ((linestr (if line (number->string line) #f))
+ (colstr (if column (number->string column) #f))
+ (namelen (string-length lex-error-filename))
+ (linelen (if line (string-length linestr) -1))
+ (collen (if column (string-length colstr) -1))
+ (totallen (+ namelen 1 linelen 1 collen 2)))
+ (display "Lex error:")
+ (newline)
+ (display lex-error-filename)
+ (if line
+ (begin
+ (display ":")
+ (display linestr)))
+ (if column
+ (begin
+ (display ":")
+ (display colstr)))
+ (display ": ")
+ (let loop ((l l))
+ (if (null? l)
+ (newline)
+ (let ((item (car l)))
+ (display item)
+ (if (equal? '#\newline item)
+ (let loop2 ((i totallen))
+ (if (> i 0)
+ (begin
+ (display #\space)
+ (loop2 (- i 1))))))
+ (loop (cdr l)))))
+ (newline)
+ (let loop ((l lex-unwind-protect-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))
+ (lex-exit-continuation #f))))
+
+
+
+
+;
+; Decoupage des arguments
+;
+
+(define lex-recognized-args
+ '(complete-driver?
+ filein
+ table-name
+ fileout
+ counters
+ portable
+ code
+ pp))
+
+(define lex-valued-args
+ '(complete-driver?
+ filein
+ table-name
+ fileout
+ counters))
+
+(define lex-parse-args
+ (lambda (args)
+ (let loop ((args args))
+ (if (null? args)
+ '()
+ (let ((sym (car args)))
+ (cond ((not (symbol? sym))
+ (lex-error #f #f "bad option list."))
+ ((not (memq sym lex-recognized-args))
+ (lex-error #f #f "unrecognized option \"" sym "\"."))
+ ((not (memq sym lex-valued-args))
+ (cons (cons sym '()) (loop (cdr args))))
+ ((null? (cdr args))
+ (lex-error #f #f "the value of \"" sym "\" not specified."))
+ (else
+ (cons (cons sym (cadr args)) (loop (cddr args))))))))))
+
+
+
+
+;
+; Differentes etapes de la fabrication de l'automate
+;
+
+(define lex1
+ (lambda (filein)
+; (display "lex1: ") (write (get-internal-run-time)) (newline)
+ (parser filein)))
+
+(define lex2
+ (lambda (filein)
+ (let* ((result (lex1 filein))
+ (<<EOF>>-action (car result))
+ (<<ERROR>>-action (cadr result))
+ (rules (cddr result)))
+; (display "lex2: ") (write (get-internal-run-time)) (newline)
+ (append (list <<EOF>>-action <<ERROR>>-action rules)
+ (re2nfa rules)))))
+
+(define lex3
+ (lambda (filein)
+ (let* ((result (lex2 filein))
+ (<<EOF>>-action (list-ref result 0))
+ (<<ERROR>>-action (list-ref result 1))
+ (rules (list-ref result 2))
+ (nl-start (list-ref result 3))
+ (no-nl-start (list-ref result 4))
+ (arcs (list-ref result 5))
+ (acc (list-ref result 6)))
+; (display "lex3: ") (write (get-internal-run-time)) (newline)
+ (append (list <<EOF>>-action <<ERROR>>-action rules)
+ (noeps nl-start no-nl-start arcs acc)))))
+
+(define lex4
+ (lambda (filein)
+ (let* ((result (lex3 filein))
+ (<<EOF>>-action (list-ref result 0))
+ (<<ERROR>>-action (list-ref result 1))
+ (rules (list-ref result 2))
+ (nl-start (list-ref result 3))
+ (no-nl-start (list-ref result 4))
+ (arcs (list-ref result 5))
+ (acc (list-ref result 6)))
+; (display "lex4: ") (write (get-internal-run-time)) (newline)
+ (append (list <<EOF>>-action <<ERROR>>-action rules)
+ (sweep nl-start no-nl-start arcs acc)))))
+
+(define lex5
+ (lambda (filein)
+ (let* ((result (lex4 filein))
+ (<<EOF>>-action (list-ref result 0))
+ (<<ERROR>>-action (list-ref result 1))
+ (rules (list-ref result 2))
+ (nl-start (list-ref result 3))
+ (no-nl-start (list-ref result 4))
+ (arcs (list-ref result 5))
+ (acc (list-ref result 6)))
+; (display "lex5: ") (write (get-internal-run-time)) (newline)
+ (append (list <<EOF>>-action <<ERROR>>-action rules)
+ (nfa2dfa nl-start no-nl-start arcs acc)))))
+
+(define lex6
+ (lambda (args-alist)
+ (let* ((filein (cdr (assq 'filein args-alist)))
+ (result (lex5 filein))
+ (<<EOF>>-action (list-ref result 0))
+ (<<ERROR>>-action (list-ref result 1))
+ (rules (list-ref result 2))
+ (nl-start (list-ref result 3))
+ (no-nl-start (list-ref result 4))
+ (arcs (list-ref result 5))
+ (acc (list-ref result 6)))
+; (display "lex6: ") (write (get-internal-run-time)) (newline)
+ (prep-set-rules-yytext? rules)
+ (output args-alist
+ <<EOF>>-action <<ERROR>>-action
+ rules nl-start no-nl-start arcs acc)
+ #t)))
+
+(define lex7
+ (lambda (args)
+ (call-with-current-continuation
+ (lambda (exit)
+ (set! lex-exit-continuation exit)
+ (set! lex-unwind-protect-list '())
+ (set! lex-error-filename (cadr (memq 'filein args)))
+ (let* ((args-alist (lex-parse-args args))
+ (result (lex6 args-alist)))
+; (display "lex7: ") (write (get-internal-run-time)) (newline)
+ result)))))
+
+
+
+
+;
+; Fonctions principales
+;
+
+(define lex
+ (lambda (filein fileout . options)
+ (lex7 (append (list 'complete-driver? #t
+ 'filein filein
+ 'table-name "lexer-default-table"
+ 'fileout fileout)
+ options))))
+
+(define lex-tables
+ (lambda (filein table-name fileout . options)
+ (lex7 (append (list 'complete-driver? #f
+ 'filein filein
+ 'table-name table-name
+ 'fileout fileout)
+ options))))
+
+)
Trap