~ chicken-core (chicken-5) 7625d978a572af6d703f398c2706d69fc6b64dbc
commit 7625d978a572af6d703f398c2706d69fc6b64dbc
Author: unknown <felix@.(none)>
AuthorDate: Tue Nov 3 14:41:14 2009 +0100
Commit: unknown <felix@.(none)>
CommitDate: Tue Nov 3 14:41:14 2009 +0100
removed benchmarks
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 8f90d37e..3cf1405a 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
Trap