--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: boyer.sch
+; 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)
+; 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 get #F)
+(define put #F)
+
+(let ((properties '()))
+ (define (our-get x y)
+ (let ((x-cut (assq x properties)))
+ (if x-cut
+ (let ((value (assq y (cdr x-cut))))
+ (if value (cdr value) '()))
+ '())))
+ (define (our-put x y z)
+ (let ((x-cut (assq x properties)))
+ (if x-cut
+ (let ((value (assq y (cdr x-cut))))
+ (if value
+ (set-cdr! value z)
+ (set-cdr! x-cut (cons (cons y z) (cdr x-cut)))))
+ (set! properties `((,x . ((,y . ,z))) ,@properties))))
+ 'OK)
+ (set! get our-get)
+ (set! put our-put))
+
+(define unify-subst '())
+(define temp-temp '())
+
+(define (add-lemma term)
+ (cond ((and (pair? term)
+ (eq? (car term)
+ (quote _equal))
+ (pair? (cadr term)))
+ (put (car (cadr term))
+ (quote _lemmas)
+ (cons term (get (car (cadr term)) (quote _lemmas)))))
+ (else (error "ADD-LEMMA did not like term: " term))))
+
+(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)
+ '())
+ (else (cons (apply-subst alist (car lst))
+ (apply-subst-lst alist (cdr lst))))))
+
+(define (falsep x lst)
+ (or (equal? x (quote (_f)))
+ (member x lst)))
+
+(define (one-way-unify term1 term2)
+ (begin (set! unify-subst '()) ;;; JSM: was #f
+ (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)))
+ (get (car term)
+ (quote _lemmas))))))
+
+(define (rewrite-args lst)
+ (cond ((null? lst)
+ '())
+ (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
+ (quote ((_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 (_1- x))))
+ (_equal (_countps- l pred)
+ (_countps-loop l pred (_zero)))
+ (_equal (_fact- i)
+ (_fact-loop i 1))
+ (_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 (_1- x))))
+ (_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 1)
+ (_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 1)))))
+ (_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 1))
+ (_equal x (_zero))))
+ (_equal (_equal (_greatest-factor x y)
+ 1)
+ (_equal x 1))
+ (_equal (_numberp (_greatest-factor x y))
+ (_not (_and (_or (_zerop y)
+ (_equal y 1))
+ (_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 1))))
+ (_equal (_greatereqpr x y)
+ (_not (_lessp x y)))
+ (_equal (_equal x (_times x y))
+ (_or (_equal x (_zero))
+ (_and (_numberp x)
+ (_equal y 1))))
+ (_equal (_remainder (_times y x)
+ y)
+ (_zero))
+ (_equal (_equal (_times a b)
+ 1)
+ (_and (_not (_equal a (_zero)))
+ (_not (_equal b (_zero)))
+ (_numberp a)
+ (_numberp b)
+ (_equal (_1- a)
+ (_zero))
+ (_equal (_1- b)
+ (_zero))))
+ (_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 6 (_length x7)))
+ (_equal (_difference (_add1 (_add1 x))
+ 2)
+ (_fix x))
+ (_equal (_quotient (_plus x (_plus x y))
+ 2)
+ (_plus x (_quotient y 2)))
+ (_equal (_sigma (_zero)
+ i)
+ (_quotient (_times i (_add1 i))
+ 2))
+ (_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)
+ (quote _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)
+ '() '())) ;;; JSM was two #Fs
+
+(define (test)
+ (define ans '#f)
+ (define term '#f)
+ (set! term
+ (apply-subst
+ (quote ((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)))))
+ (quote (_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 (trans-of-implies n)
+ (list (quote _implies)
+ (trans-of-implies1 n)
+ (list (quote _implies)
+ 0 n)))
+
+(define (trans-of-implies1 n)
+ (cond ((equal? n 1)
+ (list (quote _implies)
+ 0 1))
+ (else (list (quote _and)
+ (list (quote _implies)
+ (- n 1)
+ n)
+ (trans-of-implies1 (- n 1))))))
+
+(define (truep x lst)
+ (or (equal? x (quote (_t)))
+ (member x lst)))
+
+(setup)
+
+;;; make sure you've run (setup) then call: (test)
+
+(lambda () (test))
--- /dev/null
+(declare (usual-integrations))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: browse.sch
+; 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)
+; 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.
+
+; The next few definitions should be omitted if the Scheme implementation
+; already provides them.
+
+(define gensym generate-uninterned-symbol)
+(define get 2d-get)
+(define put 2d-put!)
+
+(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 (match pat dat alist)
+ (cond ((null? pat)
+ (null? dat))
+ ((null? dat) '())
+ ((or (eq? (car pat) '?)
+ (eq? (car pat)
+ (car dat)))
+ (match (cdr pat) (cdr dat) alist))
+ ((eq? (car pat) '*)
+ (or (match (cdr pat) dat alist)
+ (match (cdr pat) (cdr dat) alist)
+ (match 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 (match (cons (cdr val)
+ (cdr pat))
+ dat alist))
+ (else (match (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 (match (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)
+ (match (cdr pat)
+ d
+ (cons
+ (cons (car pat) l)
+ alist)))
+ (if (null? e) '#f '#t)))))))))
+ (else (and
+ (pair? (car dat))
+ (match (car pat)
+ (car dat) alist)
+ (match (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))
+ (match (car pats) (car p) '())))))
+
+;;; call: (browse)
+
+(lambda () (browse))
--- /dev/null
+(declare (usual-integrations))
+
+;;; Functional and unstable
+
+(define (vector-copy v)
+ (let* ((length (vector-length v))
+ (result (make-vector length)))
+ (let loop ((n 0))
+ (vector-set! result n (vector-ref v n))
+ (if (= n length)
+ v
+ (loop (+ n 1))))))
+
+(define (sort 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)))))
+
+ (cond ((or (pair? obj) (null? obj))
+ (loop obj))
+ ((vector? obj)
+ (sort! (vector-copy obj) pred))
+ (else
+ (error "sort: argument should be a list or vector" obj))))
+
+;; This merge sort is stable for partial orders (for predicates like
+;; <=, rather than like <).
+
+(define (sort! v pred)
+ (define (sort-internal! vec temp low high)
+ (if (< low high)
+ (let* ((middle (quotient (+ low high) 2))
+ (next (+ middle 1)))
+ (sort-internal! temp vec low middle)
+ (sort-internal! temp vec next high)
+ (let loop ((p low) (p1 low) (p2 next))
+ (if (not (> p high))
+ (cond ((> p1 middle)
+ (vector-set! vec p (vector-ref temp p2))
+ (loop (+ p 1) p1 (+ p2 1)))
+ ((or (> p2 high)
+ (pred (vector-ref temp p1)
+ (vector-ref temp p2)))
+ (vector-set! vec p (vector-ref temp p1))
+ (loop (+ p 1) (+ p1 1) p2))
+ (else
+ (vector-set! vec p (vector-ref temp p2))
+ (loop (+ p 1) p1 (+ p2 1)))))))))
+
+ (if (not (vector? v))
+ (error "sort!: argument not a vector" v))
+
+ (sort-internal! v
+ (vector-copy v)
+ 0
+ (- (vector-length v) 1))
+ v)
+
+;; 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-structure
+; (internal-node
+; (print-procedure (unparser/standard-method
+; 'graph-node
+; (lambda (state node)
+; (unparse-object state (internal-node-name node))))))
+; name
+; (green-edges '())
+; (red-edges '())
+; blue-edges)
+
+; Above is MIT version; below is portable
+
+(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))
+
+; End of portability stuff
+
+(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))
+ (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) (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-structure
+; (blue-edge
+; (print-procedure
+; (unparser/standard-method
+; 'blue-edge
+; (lambda (state edge)
+; (unparse-object state (blue-edge-operation edge))))))
+; operation arg-node res-node)
+
+; Above is MIT version; below is portable
+
+(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))
+
+; End of portability stuff
+
+; 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))))
+
+; Add a (new) blue edge to a node
+
+; (define (adjoin-blue-edge! blue-edge node)
+; (let ((current-one (lookup-op (operation blue-edge) node)))
+; (cond ((null? current-one)
+; (set-blue-edges! node
+; (cons blue-edge (blue-edges node))))
+; ((and (eq? (arg-node current-one) (arg-node blue-edge))
+; (eq? (res-node current-one) (res-node blue-edge)))
+; 'OK)
+; (else (error "Two non-equivalent blue edges for op"
+; blue-edge node)))))
+
+;; GRAPHS
+
+; (define-structure
+; (internal-graph
+; (print-procedure
+; (unparser/standard-method 'graph
+; (lambda (state edge)
+; (unparse-object state (map name (internal-graph-nodes edge)))))))
+; nodes already-met already-joined)
+
+; Above is MIT version; below is portable
+
+(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))
+
+; End of portability stuff
+
+; 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 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) (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 (reset)
+ (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)
+ (reset)
+ (map name
+ (graph-nodes (make-lattice (make-graph a b c d any-node none-node) '#f))))
+
+(define (go)
+ (reset)
+ (test))
+
+;;; call: (go)
+
+(lambda () (go))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: cpstak.sch
+; Description: continuation-passing version of TAK
+; Author: Will Clinger
+; Created: 20-Aug-87
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
+;;; A good test of first class procedures and tail recursion.
+
+(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)))
+
+;;; call: (cpstak 18 12 6)
+
+(lambda ()
+ (cpstak 18 12 6)
+ (cpstak 18 12 6)
+ (cpstak 18 12 6)
+ (cpstak 18 12 6)
+ (cpstak 18 12 6))
\ No newline at end of file
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: ctak.sch
+; Description: The ctak benchmark
+; Author: Richard Gabriel
+; Created: 5-Apr-85
+; Modified: 10-Apr-85 14:53:02 (Bob Shaw)
+; 24-Jul-87 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; The original version of this benchmark used a continuation mechanism that
+; is less powerful than call-with-current-continuation and also relied on
+; dynamic binding, which is not provided in standard Scheme. Since the
+; intent of the benchmark seemed to be to test non-local exits, the dynamic
+; binding has been replaced here by lexical binding.
+
+; For Scheme the comment that follows should read:
+;;; CTAK -- A version of the TAK procedure that uses continuations.
+
+;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
+
+(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
+ (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)))))))
+
+;;; call: (ctak 18 12 6)
+
+(lambda () (ctak 18 12 6))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: dderiv.sch
+; 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)
+; 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 Vaughn 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.
+
+; Returns the wrong answer for quotients.
+; Fortunately these aren't used in the benchmark.
+
+(define get 2d-get)
+(define put 2d-put!)
+
+(define (dderiv-aux a)
+ (list '_/ (dderiv a) a))
+
+(define (+dderiv a)
+ (cons '_+ (map dderiv a)))
+
+(define (-dderiv a)
+ (cons '_- (map dderiv a)))
+
+(define (*dderiv a)
+ (list '_* (cons '_* a)
+ (cons '_+ (map dderiv-aux a))))
+
+(define (/dderiv a)
+ (list '_-
+ (list '_/
+ (dderiv (car a))
+ (cadr a))
+ (list '_/
+ (car a)
+ (list '_*
+ (cadr a)
+ (cadr a)
+ (dderiv (cadr a))))))
+
+(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))))
+
+(put '_+ '_dderiv +dderiv)
+(put '_- '_dderiv -dderiv)
+(put '_* '_dderiv *dderiv)
+(put '_/ '_dderiv /dderiv)
+
+;;; call: (run)
+
+(lambda () (run))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: deriv.sch
+; 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)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
+;;; It uses a simple subset of Lisp and does a lot of CONSing.
+
+; Returns the wrong answer for quotients.
+; Fortunately these aren't used in the benchmark.
+
+(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))))
+
+;;; call: (run)
+
+(lambda () (run) (run) (run) (run) (run))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: destruct.sch
+; Description: DESTRUCTIVE benchmark from Gabriel tests
+; Author: Bob Shaw, HPLabs/ATC
+; Created: 8-Apr-85
+; Modified: 10-Apr-85 14:54:12 (Bob Shaw)
+; 23-Jul-87 (Will Clinger)
+; 22-Jan-88 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; append! is no longer a standard Scheme procedure, so it must be defined
+; for implementations that don't already have it.
+
+(define (append! x y)
+ (if (null? x)
+ y
+ (do ((a x b)
+ (b (cdr x) (cdr b)))
+ ((null? b)
+ (set-cdr! a y)
+ x))))
+
+;;; DESTRU -- Destructive operation benchmark
+
+(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))))))))))))
+
+;;; call: (destructive 600 50)
+
+(lambda ()
+ (destructive 1200 100))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: div.sch
+; Description: DIV benchmarks
+; Author: Richard Gabriel
+; Created: 8-Apr-85
+; Modified: 19-Jul-85 18:28:01 (Bob Shaw)
+; 23-Jul-87 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
+;;; This file contains a recursive as well as an iterative test.
+
+(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 (recursive-div2 l)
+ (cond ((null? l) '())
+ (else (cons (car l) (recursive-div2 (cddr l))))))
+
+(define (test-1 l)
+ (do ((i 300 (- i 1)))
+ ((= i 0))
+ (iterative-div2 l)
+ (iterative-div2 l)
+ (iterative-div2 l)
+ (iterative-div2 l)))
+
+(define (test-2 l)
+ (do ((i 300 (- i 1)))
+ ((= i 0))
+ (recursive-div2 l)
+ (recursive-div2 l)
+ (recursive-div2 l)
+ (recursive-div2 l)))
+
+;;; for the iterative test call: (test-1 *ll*)
+;;; for the recursive test call: (test-2 *ll*)
+
+(lambda () (begin (test-1 *ll*) (test-2 *ll*)))
+
+(lambda ()
+ (do ((i 10 (- i 1)))
+ ((= i 0))
+ (test-1 *ll*)
+ (test-2 *ll*)))
+
--- /dev/null
+(declare (usual-integrations))
+
+; File: "earley.scm" (c) 1990, Marc Feeley
+
+; Earley parser.
+
+; (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 (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 (index 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 (index 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 (index nt nts))
+ (add-conf conf nt nts predictors)
+ (loop (cdr l) (+ conf 1)))
+ (begin
+ (vector-set! steps conf (- (index 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 (index 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 (index (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* (index 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* (index 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* (index 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)))))
+
+(lambda () (test))
--- /dev/null
+(declare (usual-integrations))
+
+(define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1))
+ (fib (- n 2)))))
+
+(lambda () (fib 30))
--- /dev/null
+(declare (usual-integrations))
+
+
+(define assq/1
+ (named-lambda (assq key alist)
+ (let loop ((alist* alist))
+ (if (pair? alist*)
+ (begin
+ (if (not (pair? (car alist*)))
+ (error:wrong-type-argument alist "alist" 'assq))
+ (if (eq? (car (car alist*)) key)
+ (car alist*)
+ (loop (cdr alist*))))
+ (begin
+ (if (not (null? alist*))
+ (error:wrong-type-argument alist "alist" 'assq))
+ #F)))))
--- /dev/null
+;;
+;; Matrix multiply using matrices represented as vectors of vectors
+;; matmul1 - integer matrix
+
+(declare (usual-integrations))
+
+(define (make-initialized-vector length initialization)
+ (let ((vector (make-vector length)))
+ (let loop ((index 0))
+ (if (< index length)
+ (begin
+ (vector-set! vector index (initialization index))
+ (loop (1+ index)))))
+ vector))
+
+(define (make-identity-matrix n)
+ (make-initialized-vector n
+ (lambda (i)
+ (make-initialized-vector n
+ (lambda (j) (if (= i j) 1 0))))))
+
+(define (matmul-1 m1 m2)
+ (let ((p (vector-length m1))
+ (q1 (vector-length (vector-ref m1 0)))
+ (q2 (vector-length m2))
+ (r (vector-length (vector-ref m2 0))))
+ (if (not (= q1 q2))
+ (error "size mismatch" p q1 q2 r))
+
+ (make-initialized-vector p
+ (lambda (i)
+ (make-initialized-vector r
+ (lambda (k)
+ (let loop ((sum 0) (j 0))
+ (if (< j q2)
+ (loop (+ (* (vector-ref (vector-ref m1 i) j)
+ (vector-ref (vector-ref m2 j) k))
+ sum)
+ (+ j 1))
+ sum))))))))
+
+(define (test1 n)
+ (let ((id (make-identity-matrix n)))
+ (matmul-1 id id)))
+
+(lambda () (test1 100) #T)
\ No newline at end of file
--- /dev/null
+;;
+;; Matrix multiply using matrices represented as vectors of vectors
+;; matmul1 - float matrix
+
+(declare (usual-integrations))
+
+(define (make-initialized-vector length initialization)
+ (let ((vector (make-vector length)))
+ (let loop ((index 0))
+ (if (< index length)
+ (begin
+ (vector-set! vector index (initialization index))
+ (loop (1+ index)))))
+ vector))
+
+(define (make-identity-matrix n)
+ (make-initialized-vector n
+ (lambda (i)
+ (make-initialized-vector n
+ (lambda (j) (if (= i j) 1.0 0.0))))))
+
+(define (matmul-1 m1 m2)
+ (let ((p (vector-length m1))
+ (q1 (vector-length (vector-ref m1 0)))
+ (q2 (vector-length m2))
+ (r (vector-length (vector-ref m2 0))))
+ (if (not (= q1 q2))
+ (error "size mismatch" p q1 q2 r))
+
+ (make-initialized-vector p
+ (lambda (i)
+ (make-initialized-vector r
+ (lambda (k)
+ (let loop ((sum 0) (j 0))
+ (if (< j q2)
+ (loop (+ (* (vector-ref (vector-ref m1 i) j)
+ (vector-ref (vector-ref m2 j) k))
+ sum)
+ (+ j 1))
+ sum))))))))
+
+(define (test1 n)
+ (let ((id (make-identity-matrix n)))
+ (matmul-1 id id)))
+
+(lambda () (test1 100) #T)
\ No newline at end of file
--- /dev/null
+(declare (usual-integrations))
+
+;------------------------------------------------------------------------------
+;
+; A simple partial evaluator
+;
+; Marc Feeley (05/15/88)
+;
+;------------------------------------------------------------------------------
+
+; Utilities
+
+(define (every? pred? l)
+ (let loop ((l l))
+ (or (null? l) (and (pred? (car l)) (loop (cdr l))))))
+
+(define (some? pred? l)
+ (let loop ((l l))
+ (if (null? l) #f (or (pred? (car l)) (loop (cdr l))))))
+
+(define (map2 f l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (if (pair? l1)
+ (cons (f (car l1) (car l2)) (loop (cdr l1) (cdr l2)))
+ '())))
+
+(define (last-pair l)
+ (let loop ((l l))
+ (let ((x (cdr l))) (if (pair? x) (loop x) l))))
+
+;------------------------------------------------------------------------------
+;
+; The partial evaluator.
+
+(define (partial-evaluate proc args)
+ (peval (alphatize proc '()) args))
+
+(define (alphatize exp env) ; return a copy of 'exp' where each bound var has
+ (define (alpha exp) ; been renamed (to prevent aliasing problems)
+ (cond ((const-expr? exp)
+ (quot (const-value exp)))
+ ((symbol? exp)
+ (let ((x (assq exp env))) (if x (cdr x) exp)))
+ ((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
+ (cons (car exp) (map alpha (cdr exp))))
+ ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+ (let ((new-env (new-variables (map car (cadr exp)) env)))
+ (list (car exp)
+ (map (lambda (x)
+ (list (cdr (assq (car x) new-env))
+ (if (eq? (car exp) 'let)
+ (alpha (cadr x))
+ (alphatize (cadr x) new-env))))
+ (cadr exp))
+ (alphatize (caddr exp) new-env))))
+ ((eq? (car exp) 'lambda)
+ (let ((new-env (new-variables (cadr exp) env)))
+ (list 'lambda
+ (map (lambda (x) (cdr (assq x new-env))) (cadr exp))
+ (alphatize (caddr exp) new-env))))
+ (else
+ (map alpha exp))))
+ (alpha exp))
+
+(define (const-expr? expr) ; is 'expr' a constant expression?
+ (and (not (symbol? expr))
+ (or (not (pair? expr))
+ (eq? (car expr) 'quote))))
+
+(define (const-value expr) ; return the value of a constant expression
+ (if (pair? expr) ; then it must be a quoted constant
+ (cadr expr)
+ expr))
+
+(define (quot val) ; make a quoted constant whose value is 'val'
+ (list 'quote val))
+
+(define (new-variables parms env)
+ (append (map (lambda (x) (cons x (new-variable x))) parms) env))
+
+(define *current-num* 0)
+
+(define (new-variable name)
+ (set! *current-num* (+ *current-num* 1))
+ (string->symbol
+ (string-append (symbol->string name)
+ "_"
+ (number->string *current-num*))))
+
+;------------------------------------------------------------------------------
+;
+; (peval proc args) will transform a procedure that is known to be called
+; with constants as some of its arguments into a specialized procedure that
+; is 'equivalent' but accepts only the non-constant parameters. 'proc' is the
+; list representation of a lambda-expression and 'args' is a list of values,
+; one for each parameter of the lambda-expression. A special value (i.e.
+; 'not-constant') is used to indicate an argument that is not a constant.
+; The returned procedure is one that has as parameters the parameters of the
+; original procedure which are NOT passed constants. Constants will have been
+; substituted for the constant parameters that are referenced in the body
+; of the procedure.
+;
+; For example:
+;
+; (peval
+; '(lambda (x y z) (f z x y)) ; the procedure
+; (list 1 not-constant #t)) ; the knowledge about x, y and z
+;
+; will return: (lambda (y) (f '#t '1 y))
+
+(define (peval proc args)
+ (simplify!
+ (let ((parms (cadr proc)) ; get the parameter list
+ (body (caddr proc))) ; get the body of the procedure
+ (list 'lambda
+ (remove-constant parms args) ; remove the constant parameters
+ (beta-subst ; in the body, replace variable refs to the constant
+ body ; parameters by the corresponding constant
+ (map2 (lambda (x y) (if (not-constant? y) '(()) (cons x (quot y))))
+ parms
+ args))))))
+
+(define not-constant (list '?)) ; special value indicating non-constant parms.
+
+(define (not-constant? x) (eq? x not-constant))
+
+(define (remove-constant l a) ; remove from list 'l' all elements whose
+ (cond ((null? l) ; corresponding element in 'a' is a constant
+ '())
+ ((not-constant? (car a))
+ (cons (car l) (remove-constant (cdr l) (cdr a))))
+ (else
+ (remove-constant (cdr l) (cdr a)))))
+
+(define (extract-constant l a) ; extract from list 'l' all elements whose
+ (cond ((null? l) ; corresponding element in 'a' is a constant
+ '())
+ ((not-constant? (car a))
+ (extract-constant (cdr l) (cdr a)))
+ (else
+ (cons (car l) (extract-constant (cdr l) (cdr a))))))
+
+(define (beta-subst exp env) ; return a modified 'exp' where each var named in
+ (define (bs exp) ; 'env' is replaced by the corresponding expr (it
+ (cond ((const-expr? exp) ; is assumed that the code has been alphatized)
+ (quot (const-value exp)))
+ ((symbol? exp)
+ (let ((x (assq exp env)))
+ (if x (cdr x) exp)))
+ ((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
+ (cons (car exp) (map bs (cdr exp))))
+ ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+ (list (car exp)
+ (map (lambda (x) (list (car x) (bs (cadr x)))) (cadr exp))
+ (bs (caddr exp))))
+ ((eq? (car exp) 'lambda)
+ (list 'lambda
+ (cadr exp)
+ (bs (caddr exp))))
+ (else
+ (map bs exp))))
+ (bs exp))
+
+;------------------------------------------------------------------------------
+;
+; The expression simplifier.
+
+(define (simplify! exp) ; simplify the expression 'exp' destructively (it
+ ; is assumed that the code has been alphatized)
+ (define (simp! where env)
+
+ (define (s! where)
+ (let ((exp (car where)))
+
+ (cond ((const-expr? exp)) ; leave constants the way they are
+
+ ((symbol? exp)) ; leave variable references the way they are
+
+ ((eq? (car exp) 'if) ; dead code removal for conditionals
+ (s! (cdr exp)) ; simplify the predicate
+ (if (const-expr? (cadr exp)) ; is the predicate a constant?
+ (begin
+ (set-car! where
+ (if (memq (const-value (cadr exp)) '(#f ())) ; false?
+ (if (= (length exp) 3) ''() (cadddr exp))
+ (caddr exp)))
+ (s! where))
+ (for-each! s! (cddr exp)))) ; simplify consequent and alt.
+
+ ((eq? (car exp) 'begin)
+ (for-each! s! (cdr exp))
+ (let loop ((exps exp)) ; remove all useless expressions
+ (if (not (null? (cddr exps))) ; not last expression?
+ (let ((x (cadr exps)))
+ (loop (if (or (const-expr? x)
+ (symbol? x)
+ (and (pair? x) (eq? (car x) 'lambda)))
+ (begin (set-cdr! exps (cddr exps)) exps)
+ (cdr exps))))))
+ (if (null? (cddr exp)) ; only one expression in the begin?
+ (set-car! where (cadr exp))))
+
+ ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+ (let ((new-env (cons exp env)))
+ (define (keep i)
+ (if (>= i (length (cadar where)))
+ '()
+ (let* ((var (car (list-ref (cadar where) i)))
+ (val (cadr (assq var (cadar where))))
+ (refs (ref-count (car where) var))
+ (self-refs (ref-count val var))
+ (total-refs (- (car refs) (car self-refs)))
+ (oper-refs (- (cadr refs) (cadr self-refs))))
+ (cond ((= total-refs 0)
+ (keep (+ i 1)))
+ ((or (const-expr? val)
+ (symbol? val)
+ (and (pair? val)
+ (eq? (car val) 'lambda)
+ (= total-refs 1)
+ (= oper-refs 1)
+ (= (car self-refs) 0))
+ (and (caddr refs)
+ (= total-refs 1)))
+ (set-car! where
+ (beta-subst (car where)
+ (list (cons var val))))
+ (keep (+ i 1)))
+ (else
+ (cons var (keep (+ i 1))))))))
+ (simp! (cddr exp) new-env)
+ (for-each! (lambda (x) (simp! (cdar x) new-env)) (cadr exp))
+ (let ((to-keep (keep 0)))
+ (if (< (length to-keep) (length (cadar where)))
+ (begin
+ (if (null? to-keep)
+ (set-car! where (caddar where))
+ (set-car! (cdar where)
+ (map (lambda (v) (assq v (cadar where))) to-keep)))
+ (s! where))
+ (if (null? to-keep)
+ (set-car! where (caddar where)))))))
+
+ ((eq? (car exp) 'lambda)
+ (simp! (cddr exp) (cons exp env)))
+
+ (else
+ (for-each! s! exp)
+ (cond ((symbol? (car exp)) ; is the operator position a var ref?
+ (let ((frame (binding-frame (car exp) env)))
+ (if frame ; is it a bound variable?
+ (let ((proc (bound-expr (car exp) frame)))
+ (if (and (pair? proc)
+ (eq? (car proc) 'lambda)
+ (some? const-expr? (cdr exp)))
+ (let* ((args (arg-pattern (cdr exp)))
+ (new-proc (peval proc args))
+ (new-args (remove-constant (cdr exp) args)))
+ (set-car! where
+ (cons (add-binding new-proc frame (car exp))
+ new-args)))))
+ (set-car! where
+ (constant-fold-global (car exp) (cdr exp))))))
+ ((not (pair? (car exp))))
+ ((eq? (caar exp) 'lambda)
+ (set-car! where
+ (list 'let
+ (map2 list (cadar exp) (cdr exp))
+ (caddar exp)))
+ (s! where)))))))
+
+ (s! where))
+
+ (define (remove-empty-calls! where env)
+
+ (define (rec! where)
+ (let ((exp (car where)))
+
+ (cond ((const-expr? exp))
+ ((symbol? exp))
+ ((eq? (car exp) 'if)
+ (rec! (cdr exp))
+ (rec! (cddr exp))
+ (rec! (cdddr exp)))
+ ((eq? (car exp) 'begin)
+ (for-each! rec! (cdr exp)))
+ ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+ (let ((new-env (cons exp env)))
+ (remove-empty-calls! (cddr exp) new-env)
+ (for-each! (lambda (x) (remove-empty-calls! (cdar x) new-env))
+ (cadr exp))))
+ ((eq? (car exp) 'lambda)
+ (rec! (cddr exp)))
+ (else
+ (for-each! rec! (cdr exp))
+ (if (and (null? (cdr exp)) (symbol? (car exp)))
+ (let ((frame (binding-frame (car exp) env)))
+ (if frame ; is it a bound variable?
+ (let ((proc (bound-expr (car exp) frame)))
+ (if (and (pair? proc)
+ (eq? (car proc) 'lambda))
+ (begin
+ (set! changed? #t)
+ (set-car! where (caddr proc))))))))))))
+
+ (rec! where))
+
+ (define changed? #f)
+
+ (let ((x (list exp)))
+ (let loop ()
+ (set! changed? #f)
+ (simp! x '())
+ (remove-empty-calls! x '())
+ (if changed? (loop) (car x)))))
+
+(define (ref-count exp var) ; compute how many references to variable 'var'
+ (let ((total 0) ; are contained in 'exp'
+ (oper 0)
+ (always-evaled #t))
+ (define (rc exp ae)
+ (cond ((const-expr? exp))
+ ((symbol? exp)
+ (if (eq? exp var)
+ (begin
+ (set! total (+ total 1))
+ (set! always-evaled (and ae always-evaled)))))
+ ((eq? (car exp) 'if)
+ (rc (cadr exp) ae)
+ (for-each (lambda (x) (rc x #f)) (cddr exp)))
+ ((eq? (car exp) 'begin)
+ (for-each (lambda (x) (rc x ae)) (cdr exp)))
+ ((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
+ (for-each (lambda (x) (rc (cadr x) ae)) (cadr exp))
+ (rc (caddr exp) ae))
+ ((eq? (car exp) 'lambda)
+ (rc (caddr exp) #f))
+ (else
+ (for-each (lambda (x) (rc x ae)) exp)
+ (if (symbol? (car exp))
+ (if (eq? (car exp) var) (set! oper (+ oper 1)))))))
+ (rc exp #t)
+ (list total oper always-evaled)))
+
+(define (binding-frame var env)
+ (cond ((null? env) #f)
+ ((or (eq? (caar env) 'let) (eq? (caar env) 'letrec))
+ (if (assq var (cadar env)) (car env) (binding-frame var (cdr env))))
+ ((eq? (caar env) 'lambda)
+ (if (memq var (cadar env)) (car env) (binding-frame var (cdr env))))
+ (else
+ (error "ill-formed environment"))))
+
+(define (bound-expr var frame)
+ (cond ((or (eq? (car frame) 'let) (eq? (car frame) 'letrec))
+ (cadr (assq var (cadr frame))))
+ ((eq? (car frame) 'lambda)
+ not-constant)
+ (else
+ (error "ill-formed frame"))))
+
+(define (add-binding val frame name)
+ (define (find-val val bindings)
+ (cond ((null? bindings) #f)
+ ((equal? val (cadar bindings)) ; *kludge* equal? is not exactly what
+ (caar bindings)) ; we want...
+ (else
+ (find-val val (cdr bindings)))))
+ (or (find-val val (cadr frame))
+ (let ((var (new-variable name)))
+ (set-cdr! (last-pair (cadr frame)) (list (list var val)))
+ var)))
+
+(define (for-each! proc! l) ; call proc! on each CONS CELL in the list 'l'
+ (if (not (null? l))
+ (begin (proc! l) (for-each! proc! (cdr l)))))
+
+(define (arg-pattern exps) ; return the argument pattern (i.e. the list of
+ (if (null? exps) ; constants in 'exps' but with the not-constant
+ '() ; value wherever the corresponding expression in
+ (cons (if (const-expr? (car exps)) ; 'exps' is not a constant)
+ (const-value (car exps))
+ not-constant)
+ (arg-pattern (cdr exps)))))
+
+;------------------------------------------------------------------------------
+;
+; Knowledge about primitive procedures.
+
+(define *primitives*
+ (list
+ (cons 'car (lambda (args)
+ (and (= (length args) 1)
+ (pair? (car args))
+ (quot (car (car args))))))
+ (cons 'cdr (lambda (args)
+ (and (= (length args) 1)
+ (pair? (car args))
+ (quot (cdr (car args))))))
+ (cons '+ (lambda (args)
+ (and (every? number? args) (quot (apply + args)))))
+ (cons '* (lambda (args)
+ (and (every? number? args) (quot (apply * args)))))
+ (cons '- (lambda (args)
+ (and (> (length args) 0)
+ (every? number? args)
+ (quot (apply - args)))))
+ (cons '/ (lambda (args)
+ (and (> (length args) 1)
+ (every? number? args)
+ (quot (apply / args)))))
+ (cons '< (lambda (args)
+ (and (= (length args) 2)
+ (every? number? args)
+ (quot (< (car args) (cadr args))))))
+ (cons '= (lambda (args)
+ (and (= (length args) 2)
+ (every? number? args)
+ (quot (= (car args) (cadr args))))))
+ (cons '> (lambda (args)
+ (and (= (length args) 2)
+ (every? number? args)
+ (quot (> (car args) (cadr args))))))
+ (cons 'eq? (lambda (args)
+ (and (= (length args) 2)
+ (quot (eq? (car args) (cadr args))))))
+ (cons 'not (lambda (args)
+ (and (= (length args) 1)
+ (quot (not (car args))))))
+ (cons 'null? (lambda (args)
+ (and (= (length args) 1)
+ (quot (null? (car args))))))
+ (cons 'pair? (lambda (args)
+ (and (= (length args) 1)
+ (quot (pair? (car args))))))
+ (cons 'symbol? (lambda (args)
+ (and (= (length args) 1)
+ (quot (symbol? (car args))))))
+ (cons 'length (lambda (args)
+ (and (= (length args) 1)
+ (proper-list? (car args))
+ (quot (length (car args))))))
+ )
+)
+
+(define (reduce-global name args)
+ (let ((x (assq name *primitives*)))
+ (and x ((cdr x) args))))
+
+(define (constant-fold-global name exprs)
+
+ (define (flatten args op)
+ (cond ((null? args)
+ '())
+ ((and (pair? (car args)) (eq? (caar args) op))
+ (append (flatten (cdar args) op) (flatten (cdr args) op)))
+ (else
+ (cons (car args) (flatten (cdr args) op)))))
+
+ (let ((args (if (or (eq? name '+) (eq? name '*)) ; associative ops
+ (flatten exprs name)
+ exprs)))
+ (or (and (every? const-expr? args)
+ (reduce-global name (map const-value args)))
+ (let ((pattern (arg-pattern args)))
+ (let ((non-const (remove-constant args pattern))
+ (const (map const-value (extract-constant args pattern))))
+ (cond ((eq? name '+) ; + is commutative
+ (let ((x (reduce-global '+ const)))
+ (if x
+ (let ((y (const-value x)))
+ (cons '+
+ (if (= y 0) non-const (cons x non-const))))
+ (cons name args))))
+ ((eq? name '*) ; * is commutative
+ (let ((x (reduce-global '* const)))
+ (if x
+ (let ((y (const-value x)))
+ (cons '*
+ (if (= y 1) non-const (cons x non-const))))
+ (cons name args))))
+ ((eq? name 'cons)
+ (cond ((and (const-expr? (cadr args))
+ (null? (const-value (cadr args))))
+ (list 'list (car args)))
+ ((and (pair? (cadr args))
+ (eq? (car (cadr args)) 'list))
+ (cons 'list (cons (car args) (cdr (cadr args)))))
+ (else
+ (cons name args))))
+ (else
+ (cons name args))))))))
+
+;------------------------------------------------------------------------------
+;
+; Examples:
+
+(define (try proc args)
+ (partial-evaluate proc args))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example1
+ '(lambda (a b c)
+ (if (null? a) b (+ (car a) c))))
+
+;(try example1 (list '(10 11) not-constant '1))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example2
+ '(lambda (x y)
+ (let ((q (lambda (a b) (if (< a 0) b (- 10 b)))))
+ (if (< x 0) (q (- y) (- x)) (q y x)))))
+
+;(try example2 (list not-constant '1))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example3
+ '(lambda (l n)
+ (letrec ((add-list
+ (lambda (l n)
+ (if (null? l)
+ '()
+ (cons (+ (car l) n) (add-list (cdr l) n))))))
+ (add-list l n))))
+
+;(try example3 (list not-constant '1))
+
+;(try example3 (list '(1 2 3) not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example4
+ '(lambda (exp env)
+ (letrec ((eval
+ (lambda (exp env)
+ (letrec ((eval-list
+ (lambda (l env)
+ (if (null? l)
+ '()
+ (cons (eval (car l) env)
+ (eval-list (cdr l) env))))))
+ (if (symbol? exp) (lookup exp env)
+ (if (not (pair? exp)) exp
+ (if (eq? (car exp) 'quote) (car (cdr exp))
+ (apply (eval (car exp) env)
+ (eval-list (cdr exp) env)))))))))
+ (eval exp env))))
+
+;(try example4 (list 'x not-constant))
+
+;(try example4 (list '(f 1 2 3) not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example5
+ '(lambda (a b)
+ (letrec ((funct
+ (lambda (x)
+ (+ x b (if (< x 1) 0 (funct (- x 1)))))))
+ (funct a))))
+
+;(try example5 (list '5 not-constant))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example6
+ '(lambda ()
+ (letrec ((fib
+ (lambda (x)
+ (if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))
+ (fib 10))))
+
+;(try example6 '())
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example7
+ '(lambda (input)
+ (letrec ((copy (lambda (in)
+ (if (pair? in)
+ (cons (copy (car in))
+ (copy (cdr in)))
+ in))))
+ (copy input))))
+
+;(try example7 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define example8
+ '(lambda (input)
+ (letrec ((reverse (lambda (in result)
+ (if (pair? in)
+ (reverse (cdr in) (cons (car in) result))
+ result))))
+ (reverse input '()))))
+
+;(try example8 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+
+; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+(define (test)
+ (list (try example1 (list '(10 11) not-constant '1))
+ (try example2 (list not-constant '1))
+ (try example3 (list not-constant '1))
+ (try example3 (list '(1 2 3) not-constant))
+ (try example4 (list 'x not-constant))
+ (try example4 (list '(f 1 2 3) not-constant))
+ (try example5 (list '5 not-constant))
+ (try example6 '())
+ (try example7
+ (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
+ (try example8
+ (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))))
+
+(lambda () (test))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: puzzle.sch
+; 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)
+; 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)))))
+
+(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)
+ (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)
+ (newline)
+ (display (string-append "Piece "
+ (number->string x)
+ " at "
+ (number->string y)
+ ".")))
+
+(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 (begin (newline) (display "Error."))))
+ (cond ((trial n)
+ (begin (newline)
+ (display "Success in ")
+ (write *kount*)
+ (display " trials.")))
+ (else (begin (newline) (display "Failure."))))))
+
+(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
+ (iota (+ typemax 1)))
+
+;;; call: (start)
+
+(lambda () (start))
--- /dev/null
+(define (time-command thunk-maker)
+ (define (say . stuff) (for-each display stuff))
+ (let ((n 5))
+ (let loop ((i n) (times '()) (value '?))
+ (if (> i 0)
+ (let ((thunk (thunk-maker)))
+ (let ((start (runtime))) ; process time - gc process time
+ (let ((value (thunk)))
+ (let ((end (runtime)))
+ (loop (- i 1) (cons (- end start) times) value)))))
+ (fluid-let ((flonum-unparser-cutoff '(absolute 3)))
+ (let* ((sum (reduce + 0 times))
+ (mean (/ sum n))
+ (serr (reduce + 0 (map (lambda (x) (abs (- mean x)))
+ times)))
+ (merr (/ serr n)))
+ (say "\nTime: " mean " mean error " merr)
+ (say " (" (round->exact (* 100 (/ merr (+ mean 1e-6)))) "%)")
+ (say "\nTimes: " times)
+ value))))))
+
+(define (make-env)
+ (the-environment))
+
+(define (benchmark-file file-name)
+ (newline)
+ (display "Benchmark: ")
+ (display file-name)
+ (write-line (time-command (lambda ()
+ (fluid-let ((load/suppress-loading-message? #f))
+ (let ((env (make-env)))
+ (load "library" env)
+ (load file-name env))))))
+ (newline))
+
+(print-gc-statistics)
+
+(for-each benchmark-file
+ '("boyer"
+ "browse"
+ "conform"
+ "cpstak"
+ "ctak"
+ "dderiv"
+ "deriv"
+ "destruct"
+ "div"
+ ;;"earley"
+ "fib"
+ ;;"flatten"
+ "matmul1"
+ "matmul2"
+ "peval"
+ "puzzle"
+ "tak"
+ "takl"
+ "traverse"
+ "triangle"))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: tak.sch
+; Description: TAK benchmark from the Gabriel tests
+; Author: Richard Gabriel
+; Created: 12-Apr-85
+; Modified: 12-Apr-85 09:58:18 (Bob Shaw)
+; 22-Jul-87 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TAK -- A vanilla version of the TAKeuchi function
+
+(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))))
+
+;;; call: (tak 18 12 6)
+
+(lambda ()
+ (list (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6)
+ (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6)
+ (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6)
+ (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6)
+ (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6)))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: takl.sch
+; Description: TAKL benchmark from the Gabriel tests
+; Author: Richard Gabriel
+; Created: 12-Apr-85
+; Modified: 12-Apr-85 10:07:00 (Bob Shaw)
+; 22-Jul-87 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TAKL -- The TAKeuchi function using lists as counters.
+
+(define (listn n)
+ (if (not (= 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)
+ (if (null? y)
+ #f
+ (or (null? x)
+ (shorterp (cdr x)
+ (cdr y)))))
+
+;;; call: (mas _18l _12l _6l)
+
+(lambda ()
+ (mas _18l _12l _6l)
+ (mas _18l _12l _6l)
+ (mas _18l _12l _6l)
+ (mas _18l _12l _6l)
+ (mas _18l _12l _6l))
\ No newline at end of file
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: traverse.sch
+; Description: TRAVERSE benchmark
+; Author: Richard Gabriel
+; Created: 12-Apr-85
+; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
+; 9-Aug-87 (Will Clinger)
+; Language: Scheme (but see note)
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; Note: This benchmark may depend upon the empty list being the same
+; as #f.
+
+;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
+
+(define (make-node)
+ (let ((node (make-vector 11)))
+ (let loop ((i 10)) (if (> i 0)
+ (begin (vector-set! node i '#f) (loop (- i 1)))))
+ (vector-set! node 0 'node)
+ (vector-set! node 1 '())
+ (vector-set! node 2 '())
+ (vector-set! node 3 (snb))
+ 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))
+ ((= n 0)
+ (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)))
+ ((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
+
+(define (traverse-select n q)
+ (do ((n n (- n 1))
+ (q (car q) (cdr q)))
+ ((= n 0) (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))
+ ((= m 0)
+ (set! a `(,(begin (set-cdr! p a) p)))
+ (do ((unused a)
+ (used (add (traverse-remove 0 a) '()))
+ (x '())
+ (y '()))
+ ((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 (= n 0) (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)))
+ ((= i 0))
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)))
+
+;;; to initialize, call: (init-traverse)
+;;; to run traverse, call: (run-traverse)
+
+(lambda () (begin (init-traverse) (run-traverse)))
--- /dev/null
+(declare (usual-integrations))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; File: triangle.sch
+; Description: TRIANGLE benchmark
+; Author: Richard Gabriel
+; Created: 12-Apr-85
+; Modified: 12-Apr-85 10:30:32 (Bob Shaw)
+; 11-Aug-87 (Will Clinger)
+; 22-Jan-88 (Will Clinger)
+; Language: Scheme
+; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TRIANG -- 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 *final* '())
+
+(define (last-position)
+ (do ((i 1 (+ i 1)))
+ ((or (= i 16) (= 1 (vector-ref *board* i)))
+ (if (= i 16) 0 i))))
+
+(define (try i depth)
+ (cond ((= depth 14)
+ (let ((lp (last-position)))
+ (if (not (member lp *final*))
+ (set! *final* (cons lp *final*))))
+ (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) (try 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 (gogogo i)
+ (let ((*answer* '())
+ (*final* '()))
+ (try i 1)))
+
+;;; call: (gogogo 22))
+
+(lambda () (gogogo 22))
projects / mit-scheme.git / commitdiff