#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 1 (of 2)."
# Contents:  gabriel-scheme gabriel-scheme/browse.sch
#   gabriel-scheme/cpstack.sch gabriel-scheme/ctak.sch
#   gabriel-scheme/dderiv.sch gabriel-scheme/deriv.sch
#   gabriel-scheme/destruct.sch gabriel-scheme/div.sch
#   gabriel-scheme/fft.sch gabriel-scheme/fprint.sch
#   gabriel-scheme/fread.sch gabriel-scheme/puzzle.sch
#   gabriel-scheme/runbenchmark.sch gabriel-scheme/tak.sch
#   gabriel-scheme/takl.sch gabriel-scheme/timeit.sch
#   gabriel-scheme/tprint.sch gabriel-scheme/traverse.sch
# Wrapped by oz@yunexus on Thu May  2 23:11:07 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test ! -d 'gabriel-scheme' ; then
    echo shar: Creating directory \"'gabriel-scheme'\"
    mkdir 'gabriel-scheme'
fi
if test -f 'gabriel-scheme/browse.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/browse.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/browse.sch'\" \(6874 characters\)
sed "s/^X//" >'gabriel-scheme/browse.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         browse.sch
X; Description:  The BROWSE benchmark from the Gabriel tests
X; Author:       Richard Gabriel
X; Created:      8-Apr-85
X; Modified:     14-Jun-85 18:44:49 (Bob Shaw)
X;               16-Aug-87 (Will Clinger)
X;               22-Jan-88 (Will Clinger)
X; Language:     Scheme (but see notes below)
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X; Note:  This benchmark has been run only in implementations in which
X; the empty list is the same as #f, and may not work if that is not true.
X; Note:  This benchmark uses property lists.  The procedures that must
X; be supplied are get and put, where (put x y z) is equivalent to Common
X; Lisp's (setf (get x y) z).
X; Note:  The Common Lisp version assumes that eq works on characters,
X; which is not a portable assumption but is true in most implementations.
X; This translation makes the same assumption about eq?.
X; Note:  The gensym procedure was left as in Common Lisp.  Most Scheme
X; implementations have something similar internally.
X; Note:  The original benchmark took the car or cdr of the empty list
X; 14,600 times.  Before explicit tests were added to protect the offending
X; calls to car and cdr, MacScheme was spending a quarter of its run time
X; in the exception handler recovering from those errors.
X
X; The next few definitions should be omitted if the Scheme implementation
X; already provides them.
X
X(define (append! x y)
X  (if (null? x)
X      y
X      (do ((a x b)
X           (b (cdr x) (cdr b)))
X          ((null? b)
X           (set-cdr! a y)
X           x))))
X
X(define (copy-tree x)
X  (if (not (pair? x))
X      x
X      (cons (copy-tree (car x))
X            (copy-tree (cdr x)))))
X
X;;; BROWSE -- Benchmark to create and browse through
X;;; an AI-like data base of units.
X
X;;; n is # of symbols
X;;; m is maximum amount of stuff on the plist
X;;; npats is the number of basic patterns on the unit
X;;; ipats is the instantiated copies of the patterns
X
X(define *rand* 21)
X
X(define (init n m npats ipats)
X  (let ((ipats (copy-tree ipats)))
X    (do ((p ipats (cdr p)))
X        ((null? (cdr p)) (set-cdr! p ipats)))
X    (do ((n n (- n 1))
X         (i m (cond ((zero? i) m)
X                    (else (- i 1))))
X         (name (gensym) (gensym))
X         (a #f))
X        ((= n 0) a)
X        (set! a (cons name a))
X        (do ((i i (- i 1)))
X            ((zero? i))
X            (put name (gensym) #f))
X        (put name
X             'pattern
X             (do ((i npats (- i 1))
X                  (ipats ipats (cdr ipats))
X                  (a '()))
X                 ((zero? i) a)
X                 (set! a (cons (car ipats) a))))
X        (do ((j (- m i) (- j 1)))
X            ((zero? j))
X            (put name (gensym) #f)))))
X
X(define (browse-random)
X  (set! *rand* (remainder (* *rand* 17) 251))
X  *rand*)
X
X(define (randomize l)
X  (do ((a '()))
X      ((null? l) a)
X      (let ((n (remainder (browse-random) (length l))))
X        (cond ((zero? n)
X               (set! a (cons (car l) a))
X               (set! l (cdr l))
X               l)
X              (else
X               (do ((n n (- n 1))
X                    (x l (cdr x)))
X                   ((= n 1)
X                    (set! a (cons (cadr x) a))
X                    (set-cdr! x (cddr x))
X                    x)))))))
X
X(define (match pat dat alist)
X  (cond ((null? pat)
X         (null? dat))
X        ((null? dat) '())
X        ((or (eq? (car pat) '?)
X             (eq? (car pat)
X                  (car dat)))
X         (match (cdr pat) (cdr dat) alist))
X        ((eq? (car pat) '*)
X         (or (match (cdr pat) dat alist)
X             (match (cdr pat) (cdr dat) alist)
X             (match pat (cdr dat) alist)))
X        (else (cond ((not (pair? (car pat)))
X                     (cond ((eq? (string-ref (symbol->string (car pat)) 0)
X                                 #\?)
X                            (let ((val (assv (car pat) alist)))
X                              (cond (val (match (cons (cdr val)
X                                                      (cdr pat))
X                                                dat alist))
X                                    (else (match (cdr pat)
X                                                 (cdr dat)
X                                                 (cons (cons (car pat)
X                                                             (car dat))
X                                                       alist))))))
X                           ((eq? (string-ref (symbol->string (car pat)) 0)
X                                 #\*)
X                            (let ((val (assv (car pat) alist)))
X                              (cond (val (match (append (cdr val)
X                                                        (cdr pat))
X                                                dat alist))
X                                    (else
X                                     (do ((l '()
X                                             (append! l
X                                                      (cons (if (null? d)
X                                                                '()
X                                                                (car d))
X                                                            '())))
X                                          (e (cons '() dat) (cdr e))
X                                          (d dat (if (null? d) '() (cdr d))))
X                                         ((or (null? e)
X                                              (match (cdr pat)
X                                                       d
X                                                       (cons
X                                                        (cons (car pat) l)
X                                                        alist)))
X                                          (if (null? e) #f #t)))))))))
X                    (else (and
X                           (pair? (car dat))
X                           (match (car pat)
X                                  (car dat) alist)
X                           (match (cdr pat)
X                                  (cdr dat) alist)))))))
X
X(define (browse)
X  (investigate
X   (randomize
X    (init 100 10 4 '((a a a b b b b a a a a a b b a a a)
X                     (a a b b b b a a
X                                    (a a)(b b))
X                     (a a a b (b a) b a b a))))
X   '((*a ?b *b ?b a *a a *b *a)
X     (*a *b *b *a (*a) (*b))
X     (? ? * (b a) * ? ?))))
X
X(define (investigate units pats)
X  (do ((units units (cdr units)))
X      ((null? units))
X      (do ((pats pats (cdr pats)))
X          ((null? pats))
X          (do ((p (get (car units) 'pattern)
X                  (cdr p)))
X              ((null? p))
X              (match (car pats) (car p) '())))))
X
X;;; call: (browse)
X
X(run-benchmark "Browse" (lambda () (browse)))
END_OF_FILE
if test 6874 -ne `wc -c <'gabriel-scheme/browse.sch'`; then
    echo shar: \"'gabriel-scheme/browse.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/browse.sch'
fi
if test -f 'gabriel-scheme/cpstack.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/cpstack.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/cpstack.sch'\" \(1047 characters\)
sed "s/^X//" >'gabriel-scheme/cpstack.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         cpstak.sch
X; Description:  continuation-passing version of TAK
X; Author:       Will Clinger
X; Created:      20-Aug-87
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
X;;; A good test of first class procedures and tail recursion.
X 
X(define (cpstak x y z)
X  (define (tak x y z k)
X    (if (not (< y x))
X        (k z)
X        (tak (- x 1)
X             y
X             z
X             (lambda (v1)
X               (tak (- y 1)
X                    z
X                    x
X                    (lambda (v2)
X                      (tak (- z 1)
X                           x
X                           y
X                           (lambda (v3)
X                             (tak v1 v2 v3 k)))))))))
X  (tak x y z (lambda (a) a)))
X 
X;;; call: (cpstak 18 12 6)
X 
X(run-benchmark "CPSTAK" (lambda () (cpstak 18 12 6)))
END_OF_FILE
if test 1047 -ne `wc -c <'gabriel-scheme/cpstack.sch'`; then
    echo shar: \"'gabriel-scheme/cpstack.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/cpstack.sch'
fi
if test -f 'gabriel-scheme/ctak.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/ctak.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/ctak.sch'\" \(1937 characters\)
sed "s/^X//" >'gabriel-scheme/ctak.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         ctak.sch
X; Description:  The ctak benchmark
X; Author:       Richard Gabriel
X; Created:      5-Apr-85
X; Modified:     10-Apr-85 14:53:02 (Bob Shaw)
X;               24-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X; The original version of this benchmark used a continuation mechanism that
X; is less powerful than call-with-current-continuation and also relied on
X; dynamic binding, which is not provided in standard Scheme.  Since the
X; intent of the benchmark seemed to be to test non-local exits, the dynamic
X; binding has been replaced here by lexical binding.
X
X; For Scheme the comment that follows should read:
X;;; CTAK -- A version of the TAK procedure that uses continuations.
X
X;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
X
X(define (ctak x y z)
X  (call-with-current-continuation
X   (lambda (k)
X     (ctak-aux k x y z))))
X
X(define (ctak-aux k x y z)
X  (cond ((not (< y x))  ;xy
X         (k z))
X        (else (call-with-current-continuation
X               (ctak-aux
X                k
X                (call-with-current-continuation
X                 (lambda (k)
X                   (ctak-aux k
X                             (- x 1)
X                             y
X                             z)))
X                (call-with-current-continuation
X                 (lambda (k)
X                   (ctak-aux k
X                             (- y 1)
X                             z
X                             x)))
X                (call-with-current-continuation
X                 (lambda (k)
X                   (ctak-aux k
X                             (- z 1)
X                             x
X                             y))))))))
X
X;;; call: (ctak 18 12 6)
X
X(run-benchmark "CTAK" (lambda () (ctak 18 12 6)))
END_OF_FILE
if test 1937 -ne `wc -c <'gabriel-scheme/ctak.sch'`; then
    echo shar: \"'gabriel-scheme/ctak.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/ctak.sch'
fi
if test -f 'gabriel-scheme/dderiv.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/dderiv.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/dderiv.sch'\" \(3099 characters\)
sed "s/^X//" >'gabriel-scheme/dderiv.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         dderiv.sch
X; Description:  DDERIV benchmark from the Gabriel tests
X; Author:       Vaughan Pratt
X; Created:      8-Apr-85
X; Modified:     10-Apr-85 14:53:29 (Bob Shaw)
X;               23-Jul-87 (Will Clinger)
X;               9-Feb-88 (Will Clinger)
X; Language:     Scheme (but see note below)
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X; Note:  This benchmark uses property lists.  The procedures that must
X; be supplied are get and put, where (put x y z) is equivalent to Common
X; Lisp's (setf (get x y) z).
X
X;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
X 
X;;; This benchmark is a variant of the simple symbolic derivative program
X;;; (DERIV). The main change is that it is `table-driven.'  Instead of using a
X;;; large COND that branches on the CAR of the expression, this program finds
X;;; the code that will take the derivative on the property list of the atom in
X;;; the CAR position. So, when the expression is (+ . <rest>), the code
X;;; stored under the atom '+ with indicator DERIV will take <rest> and
X;;; return the derivative for '+. The way that MacLisp does this is with the
X;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
X;;; atomic name in that it expects an argument list and the compiler compiles
X;;; code, but the name of the function with that code is stored on the
X;;; property list of FOO under the indicator BAR, in this case. You may have
X;;; to do something like:
X 
X;;; :property keyword is not Common Lisp.
X 
X; Returns the wrong answer for quotients.
X; Fortunately these aren't used in the benchmark.
X 
X(define (dderiv-aux a)
X  (list '/ (dderiv a) a))
X 
X(define (+dderiv a)
X  (cons '+ (map dderiv a)))
X 
X(put '+ 'dderiv +dderiv)    ; install procedure on the property list
X 
X(define (-dderiv a)
X  (cons '- (map dderiv a)))
X 
X(put '- 'dderiv -dderiv)    ; install procedure on the property list
X 
X(define (*dderiv a)
X  (list '* (cons '* a)
X        (cons '+ (map dderiv-aux a))))
X 
X(put '* 'dderiv *dderiv)    ; install procedure on the property list
X 
X(define (/dderiv a)
X  (list '-
X        (list '/
X              (dderiv (car a))
X              (cadr a))
X        (list '/
X              (car a)
X              (list '*
X                    (cadr a)
X                    (cadr a)
X                    (dderiv (cadr a))))))
X 
X(put '/ 'dderiv /dderiv)    ; install procedure on the property list
X 
X(define (dderiv a)
X  (cond
X    ((not (pair? a))
X     (cond ((eq? a 'x) 1) (else 0)))
X    (else (let ((dderiv (get (car a) 'dderiv)))
X         (cond (dderiv (dderiv (cdr a)))
X               (else 'error))))))
X 
X(define (run)
X  (do ((i 0 (+ i 1)))
X      ((= i 1000))
X    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
X 
X;;; call:  (run)
X 
X(run-benchmark "Dderiv" (lambda () (run)))
END_OF_FILE
if test 3099 -ne `wc -c <'gabriel-scheme/dderiv.sch'`; then
    echo shar: \"'gabriel-scheme/dderiv.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/dderiv.sch'
fi
if test -f 'gabriel-scheme/deriv.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/deriv.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/deriv.sch'\" \(1751 characters\)
sed "s/^X//" >'gabriel-scheme/deriv.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         deriv.sch
X; Description:  The DERIV benchmark from the Gabriel tests.
X; Author:       Vaughan Pratt
X; Created:      8-Apr-85
X; Modified:     10-Apr-85 14:53:50 (Bob Shaw)
X;               23-Jul-87 (Will Clinger)
X;               9-Feb-88 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
X;;; It uses a simple subset of Lisp and does a lot of  CONSing.
X
X; Returns the wrong answer for quotients.
X; Fortunately these aren't used in the benchmark.
X 
X(define (deriv-aux a) (list '/ (deriv a) a))
X 
X(define (deriv a)
X  (cond
X    ((not (pair? a))
X     (cond ((eq? a 'x) 1) (else 0)))
X    ((eq? (car a) '+)
X     (cons '+ (map deriv (cdr a))))
X    ((eq? (car a) '-)
X     (cons '- (map deriv
X                      (cdr a))))
X    ((eq? (car a) '*)
X     (list '*
X           a
X           (cons '+ (map deriv-aux (cdr a)))))
X    ((eq? (car a) '/)
X     (list '-
X           (list '/
X                 (deriv (cadr a))
X                 (caddr a))
X           (list '/
X                 (cadr a)
X                 (list '*
X                       (caddr a)
X                       (caddr a)
X                       (deriv (caddr a))))))
X    (else 'error)))
X 
X(define (run)
X  (do ((i 0 (+ i 1)))
X      ((= i 1000))
X    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
X    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
X 
X;;; call:  (run)
X 
X(run-benchmark "Deriv" (lambda () (run)))
END_OF_FILE
if test 1751 -ne `wc -c <'gabriel-scheme/deriv.sch'`; then
    echo shar: \"'gabriel-scheme/deriv.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/deriv.sch'
fi
if test -f 'gabriel-scheme/destruct.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/destruct.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/destruct.sch'\" \(2328 characters\)
sed "s/^X//" >'gabriel-scheme/destruct.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         destruct.sch
X; Description:  DESTRUCTIVE benchmark from Gabriel tests
X; Author:       Bob Shaw, HPLabs/ATC
X; Created:      8-Apr-85
X; Modified:     10-Apr-85 14:54:12 (Bob Shaw)
X;               23-Jul-87 (Will Clinger)
X;               22-Jan-88 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X; append! is no longer a standard Scheme procedure, so it must be defined
X; for implementations that don't already have it.
X
X(define (append! x y)
X  (if (null? x)
X      y
X      (do ((a x b)
X           (b (cdr x) (cdr b)))
X          ((null? b)
X           (set-cdr! a y)
X           x))))
X
X;;; DESTRU -- Destructive operation benchmark
X 
X(define (destructive n m)
X  (let ((l (do ((i 10 (- i 1))
X                (a '() (cons '() a)))
X               ((= i 0) a))))
X    (do ((i n (- i 1)))
X        ((= i 0))
X      (cond ((null? (car l))
X             (do ((l l (cdr l)))
X                 ((null? l))
X               (or (car l)
X                   (set-car! l (cons '() '())))
X               (append! (car l)
X                      (do ((j m (- j 1))
X                           (a '() (cons '() a)))
X                          ((= j 0) a)))))
X            (else
X             (do ((l1 l (cdr l1))
X                  (l2 (cdr l) (cdr l2)))
X                 ((null? l2))
X               (set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
X                            (a (car l2) (cdr a)))
X                           ((zero? j) a)
X                         (set-car! a i))
X                       (let ((n (quotient (length (car l1)) 2)))
X                         (cond ((= n 0) (set-car! l1 '())
X                                (car l1))
X                               (else
X                                (do ((j n (- j 1))
X                                     (a (car l1) (cdr a)))
X                                    ((= j 1)
X                                     (let ((x (cdr a)))
X                                            (set-cdr! a '())
X                                          x))
X                                  (set-car! a i))))))))))))
X 
X;;; call:  (destructive 600 50)
X 
X(run-benchmark "Destructive" (lambda () (destructive 600 50)))
END_OF_FILE
if test 2328 -ne `wc -c <'gabriel-scheme/destruct.sch'`; then
    echo shar: \"'gabriel-scheme/destruct.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/destruct.sch'
fi
if test -f 'gabriel-scheme/div.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/div.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/div.sch'\" \(1398 characters\)
sed "s/^X//" >'gabriel-scheme/div.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         div.sch
X; Description:  DIV benchmarks
X; Author:       Richard Gabriel
X; Created:      8-Apr-85
X; Modified:     19-Jul-85 18:28:01 (Bob Shaw)
X;               23-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
X;;; This file contains a recursive as well as an iterative test.
X 
X(define (create-n n)
X  (do ((n n (- n 1))
X       (a '() (cons '() a)))
X      ((= n 0) a)))
X 
X(define *ll* (create-n 200))
X 
X(define (iterative-div2 l)
X  (do ((l l (cddr l))
X       (a '() (cons (car l) a)))
X      ((null? l) a)))
X 
X(define (recursive-div2 l)
X  (cond ((null? l) '())
X        (else (cons (car l) (recursive-div2 (cddr l))))))
X 
X(define (test-1 l)
X  (do ((i 300 (- i 1)))
X      ((= i 0))
X    (iterative-div2 l)
X    (iterative-div2 l)
X    (iterative-div2 l)
X    (iterative-div2 l)))
X 
X(define (test-2 l)
X  (do ((i 300 (- i 1)))
X      ((= i 0))
X    (recursive-div2 l)
X    (recursive-div2 l)
X    (recursive-div2 l)
X    (recursive-div2 l)))
X 
X;;; for the iterative test call: (test-1 *ll*)
X;;; for the recursive test call: (test-2 *ll*)
X 
X(run-benchmark "Div-iter" (lambda () (test-1 *ll*)))
X(run-benchmark "Div-rec" (lambda () (test-2 *ll*)))
X 
END_OF_FILE
if test 1398 -ne `wc -c <'gabriel-scheme/div.sch'`; then
    echo shar: \"'gabriel-scheme/div.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/div.sch'
fi
if test -f 'gabriel-scheme/fft.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/fft.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/fft.sch'\" \(3394 characters\)
sed "s/^X//" >'gabriel-scheme/fft.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         fft.cl
X; Description:  FFT benchmark from the Gabriel tests.
X; Author:       Harry Barrow
X; Created:      8-Apr-85
X; Modified:     6-May-85 09:29:22 (Bob Shaw)
X;               11-Aug-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X(define pi (atan 0 -1))
X
X;;; FFT -- This is an FFT benchmark written by Harry Barrow.
X;;; It tests a variety of floating point operations,
X;;; including array references.
X 
X(define *re* (make-vector 1025 0.0))
X 
X(define *im* (make-vector 1025 0.0))
X 
X(define (fft areal aimag)
X  (let ((ar 0)
X        (ai 0)
X        (i 0)
X        (j 0)
X        (k 0)
X        (m 0)
X        (n 0)
X        (le 0)
X        (le1 0)
X        (ip 0)
X        (nv2 0)
X        (nm1 0)
X        (ur 0)
X        (ui 0)
X        (wr 0)
X        (wi 0)
X        (tr 0)
X        (ti 0))
X    ;; initialize
X    (set! ar areal)
X    (set! ai aimag)
X    (set! n (vector-length ar))
X    (set! n (- n 1))
X    (set! nv2 (quotient n 2))
X    (set! nm1 (- n 1))
X    (set! m 0)                                  ;compute m = log(n)
X    (set! i 1)
X    (let loop ()
X      (if (< i n)
X          (begin (set! m (+ m 1))
X                 (set! i (+ i i))
X                 (loop))))
X    (cond ((not (= n (expt 2 m)))
X           (error "array size not a power of two.")))
X    ;; interchange elements in bit-reversed order
X    (set! j 1)
X    (set! i 1)
X    (let l3 ()
X      (cond ((< i j)
X             (set! tr (vector-ref ar j))
X             (set! ti (vector-ref ai j))
X             (vector-set! ar j (vector-ref ar i))
X             (vector-set! ai j (vector-ref ai i))
X             (vector-set! ar i tr)
X             (vector-set! ai i ti)))
X      (set! k nv2)
X      (let l6 ()
X        (cond ((< k j)
X               (set! j (- j k))
X               (set! k (/ k 2))
X               (l6))))
X      (set! j (+ j k))
X      (set! i (+ i 1))
X      (cond ((< i n)
X             (l3))))
X    (do ((l 1 (+ l 1)))                 ;loop thru stages (syntax converted
X        ((> l m))                       ; from old MACLISP style \bs)
X        (set! le (expt 2 l))
X        (set! le1 (quotient le 2))
X        (set! ur 1.0)
X        (set! ui 0.)
X        (set! wr (cos (/ pi le1)))
X        (set! wi (sin (/ pi le1)))
X        ;; loop thru butterflies
X        (do ((j 1 (+ j 1)))
X            ((> j le1))
X            ;; do a butterfly
X            (do ((i j (+ i le)))
X                ((> i n))
X                (set! ip (+ i le1))
X                (set! tr (- (* (vector-ref ar ip) ur)
X                            (* (vector-ref ai ip) ui)))
X                (set! ti (+ (* (vector-ref ar ip) ui)
X                            (* (vector-ref ai ip) ur)))
X                (vector-set! ar ip (- (vector-ref ar i) tr))
X                (vector-set! ai ip (- (vector-ref ai i) ti))
X                (vector-set! ar i (+ (vector-ref ar i) tr))
X                (vector-set! ai i (+ (vector-ref ai i) ti))))
X        (set! tr (- (* ur wr) (* ui wi)))
X        (set! ti (+ (* ur wi) (* ui wr)))
X        (set! ur tr)
X        (set! ui ti))
X    #t))
X 
X;;; the timer which does 10 calls on fft
X 
X(define (fft-bench)
X  (do ((ntimes 0 (+ ntimes 1)))
X      ((= ntimes 10))
X      (fft *re* *im*)))
X 
X;;; call:  (fft-bench)
X 
X(run-benchmark "FFT" (lambda () (fft-bench)))
END_OF_FILE
if test 3394 -ne `wc -c <'gabriel-scheme/fft.sch'`; then
    echo shar: \"'gabriel-scheme/fft.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/fft.sch'
fi
if test -f 'gabriel-scheme/fprint.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/fprint.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/fprint.sch'\" \(1549 characters\)
sed "s/^X//" >'gabriel-scheme/fprint.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         fprint.sch
X; Description:  FPRINT benchmark
X; Author:       Richard Gabriel
X; Created:      11-Apr-85
X; Modified:     9-Jul-85 21:11:33 (Bob Shaw)
X;               24-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; FPRINT -- Benchmark to print to a file.
X
X(define test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
X                     mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
X                     wxyzab23 xyzabc34 123456ab 234567bc 345678cd
X                     456789de 567890ef 678901fg 789012gh 890123hi)
X  )
X
X(define (init-aux m n atoms)
X  (cond ((= m 0) (car atoms))
X        (else (do ((i n (- i 2))
X                   (a '()))
X                  ((< i 1) a)
X                  (set! a (cons (car atoms) a))
X                  (set! atoms (cdr atoms))
X                  (set! a (cons (init-aux (- m 1) n atoms) a))))))
X
X(define (init m n atoms)
X  (define (copy x)
X    (if (pair? x)
X        (cons (copy (car x)) (copy (cdr x)))
X        x))
X  (let ((atoms (copy atoms)))
X    (do ((a atoms (cdr a)))
X        ((null? (cdr a)) (set-cdr! a atoms)))
X    (init-aux m n atoms)))
X
X(define test-pattern (init 6 6 test-atoms))
X
X(define (fprint)
X  (call-with-output-file
X   "fprint.tst"
X   (lambda (stream)
X     (newline stream)
X     (write test-pattern stream))))
X
X;;; call:  (fprint)
X
X(run-benchmark "Fprint" (lambda () (fprint)))
END_OF_FILE
if test 1549 -ne `wc -c <'gabriel-scheme/fprint.sch'`; then
    echo shar: \"'gabriel-scheme/fprint.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/fprint.sch'
fi
if test -f 'gabriel-scheme/fread.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/fread.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/fread.sch'\" \(707 characters\)
sed "s/^X//" >'gabriel-scheme/fread.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         fread.sch
X; Description:  FREAD benchmark
X; Author:       Richard Gabriel
X; Created:      11-Apr-85
X; Modified:     11-Apr-85 20:39:09 (Bob Shaw)
X;               24-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; FREAD -- Benchmark to read from a file.
X;;; Requires the existence of FPRINT.TST which is created
X;;; by FPRINT.
X 
X(define (fread)
X  (call-with-input-file
X   "fprint.tst"
X    (lambda (stream)
X      (read stream))))
X 
X;;; call: (fread))
X
X 
X(run-benchmark "Fread" (lambda () (fread)))
X
X 
END_OF_FILE
if test 707 -ne `wc -c <'gabriel-scheme/fread.sch'`; then
    echo shar: \"'gabriel-scheme/fread.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/fread.sch'
fi
if test -f 'gabriel-scheme/puzzle.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/puzzle.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/puzzle.sch'\" \(5004 characters\)
sed "s/^X//" >'gabriel-scheme/puzzle.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         puzzle.sch
X; Description:  PUZZLE benchmark
X; Author:       Richard Gabriel, after Forrest Baskett
X; Created:      12-Apr-85
X; Modified:     12-Apr-85 14:20:23 (Bob Shaw)
X;               11-Aug-87 (Will Clinger)
X;               22-Jan-88 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(define (iota n)
X  (do ((n n (- n 1))
X       (list '() (cons (- n 1) list)))
X      ((zero? n) list)))
X
X;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
X
X(define size 511)
X(define classmax 3)
X(define typemax 12)
X
X(define *iii* 0)
X(define *kount* 0)
X(define *d* 8)
X
X(define *piececount* (make-vector (+ classmax 1) 0))
X(define *class* (make-vector (+ typemax 1) 0))
X(define *piecemax* (make-vector (+ typemax 1) 0))
X(define *puzzle* (make-vector (+ size 1)))
X(define *p* (make-vector (+ typemax 1)))
X(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
X          (iota (+ typemax 1)))
X
X(define (fit i j)
X  (let ((end (vector-ref *piecemax* i)))
X    (do ((k 0 (+ k 1)))
X        ((or (> k end)
X             (and (vector-ref (vector-ref *p* i) k)
X                  (vector-ref *puzzle* (+ j k))))
X         (if (> k end) #t #f)))))
X
X(define (place i j)
X  (let ((end (vector-ref *piecemax* i)))
X    (do ((k 0 (+ k 1)))
X        ((> k end))
X        (cond ((vector-ref (vector-ref *p* i) k)
X               (vector-set! *puzzle* (+ j k) #t)
X               #t)))
X    (vector-set! *piececount*
X                 (vector-ref *class* i)
X                 (- (vector-ref *piececount* (vector-ref *class* i)) 1))
X    (do ((k j (+ k 1)))
X        ((or (> k size) (not (vector-ref *puzzle* k)))
X         ;        (newline)
X         ;        (display "*Puzzle* filled")
X         (if (> k size) 0 k)))))
X
X(define (puzzle-remove i j)
X  (let ((end (vector-ref *piecemax* i)))
X    (do ((k 0 (+ k 1)))
X        ((> k end))
X        (cond ((vector-ref (vector-ref *p* i) k)
X               (vector-set! *puzzle* (+ j k) #f)
X               #f)))
X    (vector-set! *piececount*
X                 (vector-ref *class* i)
X                 (+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
X
X
X(define (trial j)
X  (let ((k 0))
X    (call-with-current-continuation
X     (lambda (return)
X       (do ((i 0 (+ i 1)))
X           ((> i typemax) (set! *kount* (+ *kount* 1)) ())
X           (cond
X            ((not
X              (zero?
X               (vector-ref *piececount* (vector-ref *class* i))))
X             (cond
X              ((fit i j)
X               (set! k (place i j))
X               (cond
X                ((or (trial k) (zero? k))
X                 ;(trial-output (+ i 1) (+ k 1))
X                 (set! *kount* (+ *kount* 1))
X                 (return #t))
X                (else (puzzle-remove i j))))))))))))
X
X(define (trial-output x y)
X  (newline)
X  (display (string-append "Piece "
X                          (number->string x '(int))
X                          " at "
X                          (number->string y '(int))
X                          ".")))
X
X(define (definepiece iclass ii jj kk)
X  (let ((index 0))
X    (do ((i 0 (+ i 1)))
X        ((> i ii))
X        (do ((j 0 (+ j 1)))
X            ((> j jj))
X            (do ((k 0 (+ k 1)))
X                ((> k kk))
X                (set! index (+ i (* *d* (+ j (* *d* k)))))
X                (vector-set! (vector-ref *p* *iii*) index  #t))))
X    (vector-set! *class* *iii* iclass)
X    (vector-set! *piecemax* *iii* index)
X    (cond ((not (= *iii* typemax))
X           (set! *iii* (+ *iii* 1))))))
X
X(define (start)
X  (do ((m 0 (+ m 1)))
X      ((> m size))
X      (vector-set! *puzzle* m #t))
X  (do ((i 1 (+ i 1)))
X      ((> i 5))
X      (do ((j 1 (+ j 1)))
X          ((> j 5))
X          (do ((k 1 (+ k 1)))
X              ((> k 5))
X              (vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
X  (do ((i 0 (+ i 1)))
X      ((> i typemax))
X      (do ((m 0 (+ m 1)))
X          ((> m size))
X          (vector-set! (vector-ref *p* i) m #f)))
X  (set! *iii* 0)
X  (definePiece 0 3 1 0)
X  (definePiece 0 1 0 3)
X  (definePiece 0 0 3 1)
X  (definePiece 0 1 3 0)
X  (definePiece 0 3 0 1)
X  (definePiece 0 0 1 3)
X  
X  (definePiece 1 2 0 0)
X  (definePiece 1 0 2 0)
X  (definePiece 1 0 0 2)
X  
X  (definePiece 2 1 1 0)
X  (definePiece 2 1 0 1)
X  (definePiece 2 0 1 1)
X  
X  (definePiece 3 1 1 1)
X  
X  (vector-set! *piececount* 0 13)
X  (vector-set! *piececount* 1 3)
X  (vector-set! *piececount* 2 1)
X  (vector-set! *piececount* 3 1)
X  (let ((m (+ (* *d* (+ *d* 1)) 1))
X        (n 0))
X    (cond ((fit 0 m) (set! n (place 0 m)))
X          (else (begin (newline) (display "Error."))))
X    (cond ((trial n)
X           (begin (newline)
X                  (display "Success in ")
X                  (write *kount*)
X                  (display " trials.")))
X          (else (begin (newline) (display "Failure."))))))
X
X;;; call:  (start)
X
X(run-benchmark "Puzzle" (lambda () (start)))
END_OF_FILE
if test 5004 -ne `wc -c <'gabriel-scheme/puzzle.sch'`; then
    echo shar: \"'gabriel-scheme/puzzle.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/puzzle.sch'
fi
if test -f 'gabriel-scheme/runbenchmark.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/runbenchmark.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/runbenchmark.sch'\" \(354 characters\)
sed "s/^X//" >'gabriel-scheme/runbenchmark.sch' <<'END_OF_FILE'
X;;;
X;;; You need to write a procedure named "run-benchmark" that takes
X;;; two arguments.  The first is a string identifying the particular
X;;; benchmark being run.  The second is a thunk, a procedure of no
X;;; arguments, that will actually run the benchmark.
X;;;
X
X(define (run-benchmark benchmark-name benchmark-thunk)
X  ;;; your code goes here
X  #t
X)
X
END_OF_FILE
if test 354 -ne `wc -c <'gabriel-scheme/runbenchmark.sch'`; then
    echo shar: \"'gabriel-scheme/runbenchmark.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/runbenchmark.sch'
fi
if test -f 'gabriel-scheme/tak.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/tak.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/tak.sch'\" \(707 characters\)
sed "s/^X//" >'gabriel-scheme/tak.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         tak.sch
X; Description:  TAK benchmark from the Gabriel tests
X; Author:       Richard Gabriel
X; Created:      12-Apr-85
X; Modified:     12-Apr-85 09:58:18 (Bob Shaw)
X;               22-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; TAK -- A vanilla version of the TAKeuchi function
X 
X(define (tak x y z)
X  (if (not (< y x))
X      z
X      (tak (tak (- x 1) y z)
X           (tak (- y 1) z x)
X           (tak (- z 1) x y))))
X 
X;;; call: (tak 18 12 6)
X 
X(run-benchmark "TAK" (lambda () (tak 18 12 6)))
END_OF_FILE
if test 707 -ne `wc -c <'gabriel-scheme/tak.sch'`; then
    echo shar: \"'gabriel-scheme/tak.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/tak.sch'
fi
if test -f 'gabriel-scheme/takl.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/takl.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/takl.sch'\" \(1041 characters\)
sed "s/^X//" >'gabriel-scheme/takl.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         takl.sch
X; Description:  TAKL benchmark from the Gabriel tests
X; Author:       Richard Gabriel
X; Created:      12-Apr-85
X; Modified:     12-Apr-85 10:07:00 (Bob Shaw)
X;               22-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; TAKL -- The TAKeuchi function using lists as counters.
X 
X(define (listn n)
X  (if (not (= 0 n))
X      (cons n (listn (- n 1)))))
X 
X(define 18l (listn 18))
X(define 12l (listn 12))
X(define  6l (listn 6))
X 
X(define (mas x y z)
X  (if (not (shorterp y x))
X      z
X      (mas (mas (cdr x)
X                 y z)
X            (mas (cdr y)
X                 z x)
X            (mas (cdr z)
X                 x y))))
X 
X(define (shorterp x y)
X  (and y (or (null? x)
X             (shorterp (cdr x)
X                       (cdr y)))))
X 
X;;; call: (mas 18l 12l 6l)
X 
X(run-benchmark "TAKL" (lambda () (mas 18l 12l 6l)))
END_OF_FILE
if test 1041 -ne `wc -c <'gabriel-scheme/takl.sch'`; then
    echo shar: \"'gabriel-scheme/takl.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/takl.sch'
fi
if test -f 'gabriel-scheme/timeit.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/timeit.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/timeit.sch'\" \(1405 characters\)
sed "s/^X//" >'gabriel-scheme/timeit.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         timer.sch
X; Description:  The timer function for Gabriel's test suite.
X; Author:       Robert Kessler, Will Galway and Stan Shebs
X; Created:      05-Mar-84
X; Modified:     16-Dec-85 (Stan Shebs)
X;               4-Aug-87 (Will Clinger)
X;               28-Mar-88 (Eric Ost)
X; Language:     Chez Scheme
X; Status:       Experimental
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; Invoke this function to run a benchmark.  The first argument is a string
X;;; identifying the benchmark, while the second is a thunk to be called.
X(define-macro! comment () #t)
X 
X(comment
X(define (run-benchmark name thunk)
X  (newline)
X  (display "--------------------------------------------------------")
X  (newline)
X  (display name)
X  (newline)
X  (display "Timing performed on an Apple Macintosh II with 5 Mby RAM")
X  (newline)
X  (display "running Finder 6.0 System 4.2 at Semantic Microsystems.")
X  (newline)
X  (gc)
X  ; timeit is a macro supplied by MacScheme
X  (timeit (thunk)))
X)
X
X(define (run-benchmark name thunk)
X  (newline)
X  (display "--------------------------------------------------------")
X  (newline)
X  (display name)
X  (newline)
X  (display "Timing performed on a Vax-8800 with 32MB RAM, Ultrix 2.0")
X  (newline)
X  (collect)
X  ; time is a macro supplied by Chez
X  (time (thunk)))
END_OF_FILE
if test 1405 -ne `wc -c <'gabriel-scheme/timeit.sch'`; then
    echo shar: \"'gabriel-scheme/timeit.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/timeit.sch'
fi
if test -f 'gabriel-scheme/tprint.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/tprint.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/tprint.sch'\" \(1364 characters\)
sed "s/^X//" >'gabriel-scheme/tprint.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         tprint.sch
X; Description:  TPRINT benchmark from the Gabriel tests
X; Author:       Richard Gabriel
X; Created:      12-Apr-85
X; Modified:     19-Jul-85 19:05:26 (Bob Shaw)
X;               23-Jul-87 (Will Clinger)
X; Language:     Scheme
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X 
X;;; TPRINT -- Benchmark to print and read to the terminal.
X 
X(define ttest-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
X                          stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d
X                          567d 678e 789f 890g))
X 
X(define (init m n atoms)
X(define (copy x)
X   (if (pair? x)
X       (cons (copy (car x)) (copy (cdr x)))
X       x))
X  (let ((atoms (copy atoms)))
X    (do ((a atoms (cdr a)))
X        ((null? (cdr a)) (set-cdr! a atoms) a))
X    (init-aux m n atoms)))
X 
X(define (init-aux m n atoms)
X  (cond ((= m 0) (car atoms))
X        (else (do ((i n (- i 2))
X                (a '()))
X               ((< i 1) a)
X             (set! a (cons (car atoms) a))
X             (set! atoms (cdr atoms))
X             (set! a (cons (init-aux (1- m) n atoms) a))))))
X 
X(define ttest-pattern (init 6 6 ttest-atoms))
X 
X;;; call:  (print ttest-pattern)
X 
X(run-benchmark "Tprint" (lambda () (write ttest-pattern)))
END_OF_FILE
if test 1364 -ne `wc -c <'gabriel-scheme/tprint.sch'`; then
    echo shar: \"'gabriel-scheme/tprint.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/tprint.sch'
fi
if test -f 'gabriel-scheme/traverse.sch' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'gabriel-scheme/traverse.sch'\"
else
echo shar: Extracting \"'gabriel-scheme/traverse.sch'\" \(5195 characters\)
sed "s/^X//" >'gabriel-scheme/traverse.sch' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; File:         traverse.sch
X; Description:  TRAVERSE benchmark
X; Author:       Richard Gabriel
X; Created:      12-Apr-85
X; Modified:     12-Apr-85 10:24:04 (Bob Shaw)
X;               9-Aug-87 (Will Clinger)
X; Language:     Scheme (but see note)
X; Status:       Public Domain
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X; Note:  This benchmark may depend upon the empty list being the same
X; as #f.
X 
X;;; TRAVERSE --  Benchmark which creates and traverses a tree structure.
X 
X(define (make-node)
X  (let ((node (make-vector 11 '())))
X    (vector-set! node 0 'node)
X    (vector-set! node 3 (snb))
X    node))
X
X(define (node-parents node) (vector-ref node 1))
X(define (node-sons node) (vector-ref node 2))
X(define (node-sn node) (vector-ref node 3))
X(define (node-entry1 node) (vector-ref node 4))
X(define (node-entry2 node) (vector-ref node 5))
X(define (node-entry3 node) (vector-ref node 6))
X(define (node-entry4 node) (vector-ref node 7))
X(define (node-entry5 node) (vector-ref node 8))
X(define (node-entry6 node) (vector-ref node 9))
X(define (node-mark node) (vector-ref node 10))
X
X(define (node-parents-set! node v) (vector-set! node 1 v))
X(define (node-sons-set! node v) (vector-set! node 2 v))
X(define (node-sn-set! node v) (vector-set! node 3 v))
X(define (node-entry1-set! node v) (vector-set! node 4 v))
X(define (node-entry2-set! node v) (vector-set! node 5 v))
X(define (node-entry3-set! node v) (vector-set! node 6 v))
X(define (node-entry4-set! node v) (vector-set! node 7 v))
X(define (node-entry5-set! node v) (vector-set! node 8 v))
X(define (node-entry6-set! node v) (vector-set! node 9 v))
X(define (node-mark-set! node v) (vector-set! node 10 v))
X
X(define *sn* 0)
X(define *rand* 21)
X(define *count* 0)
X(define *marker* #f)
X(define *root* '())
X
X(define (snb)
X  (set! *sn* (+ 1 *sn*))
X  *sn*)
X 
X(define (seed)
X  (set! *rand* 21)
X  *rand*)
X 
X(define (traverse-random)
X  (set! *rand* (remainder (* *rand* 17) 251))
X  *rand*)
X 
X(define (traverse-remove n q)
X  (cond ((eq? (cdr (car q)) (car q))
X         (let ((x (caar q))) (set-car! q #f) x))
X        ((zero? n)
X         (let ((x (caar q)))
X           (do ((p (car q) (cdr p)))
X               ((eq? (cdr p) (car q))
X                (set-cdr! p (cdr (car q)))
X                (set-car! q p)))
X           x))
X        (else (do ((n n (- n 1))
X                (q (car q) (cdr q))
X                (p (cdr (car q)) (cdr p)))
X               ((zero? n) (let ((x (car q))) (set-cdr! q p) x))))))
X 
X(define (traverse-select n q)
X  (do ((n n (- n 1))
X       (q (car q) (cdr q)))
X      ((zero? n) (car q))))
X 
X(define (add a q)
X  (cond ((null? q)
X         `(,(let ((x `(,a)))
X              (set-cdr! x x) x)))
X        ((null? (car q))
X         (let ((x `(,a)))
X           (set-cdr! x x)
X           (set-car! q x)
X           q))
X        ; the CL version had a useless set-car! in the next line (wc)
X        (else (set-cdr! (car q) `(,a . ,(cdr (car q))))
X              q)))
X 
X(define (create-structure n)
X  (let ((a `(,(make-node))))
X    (do ((m (- n 1) (- m 1))
X         (p a))
X        ((zero? m)
X         (set! a `(,(begin (set-cdr! p a) p)))
X         (do ((unused a)
X              (used (add (traverse-remove 0 a) #f))
X              (x 0)
X              (y 0))
X             ((null? (car unused))
X              (find-root (traverse-select 0 used) n))
X           (set! x (traverse-remove (remainder (traverse-random) n) unused))
X           (set! y (traverse-select (remainder (traverse-random) n) used))
X           (add x used)
X           (node-sons-set! y `(,x . ,(node-sons y)))
X           (node-parents-set! x `(,y . ,(node-parents x))) ))
X      (set! a (cons (make-node) a)))))
X 
X(define (find-root node n)
X  (do ((n n (- n 1)))
X      ((or (zero? n) (null? (node-parents node)))
X       node)
X    (set! node (car (node-parents node)))))
X 
X(define (travers node mark)
X  (cond ((eq? (node-mark node) mark) #f)
X        (else (node-mark-set! node mark)
X           (set! *count* (+ 1 *count*))
X           (node-entry1-set! node (not (node-entry1 node)))
X           (node-entry2-set! node (not (node-entry2 node)))
X           (node-entry3-set! node (not (node-entry3 node)))
X           (node-entry4-set! node (not (node-entry4 node)))
X           (node-entry5-set! node (not (node-entry5 node)))
X           (node-entry6-set! node (not (node-entry6 node)))
X           (do ((sons (node-sons node) (cdr sons)))
X               ((null? sons) #f)
X             (travers (car sons) mark)))))
X 
X(define (traverse root)
X  (let ((*count* 0))
X    (travers root (begin (set! *marker* (not *marker*)) *marker*))
X    *count*))
X 
X(define (init-traverse)  ; Changed from defmacro to defun \bs
X  (set! *root* (create-structure 100))
X  #f)
X 
X(define (run-traverse)  ; Changed from defmacro to defun \bs
X  (do ((i 50 (- i 1)))
X      ((zero? i))
X    (traverse *root*)
X    (traverse *root*)
X    (traverse *root*)
X    (traverse *root*)
X    (traverse *root*)))
X 
X;;; to initialize, call:  (init-traverse)
X;;; to run traverse, call:  (run-traverse)
X 
X(run-benchmark "Traverse-init" (lambda () (init-traverse)))
X(run-benchmark "Traverse" (lambda () (run-traverse)))
END_OF_FILE
if test 5195 -ne `wc -c <'gabriel-scheme/traverse.sch'`; then
    echo shar: \"'gabriel-scheme/traverse.sch'\" unpacked with wrong size!
fi
# end of 'gabriel-scheme/traverse.sch'
fi
echo shar: End of archive 1 \(of 2\).
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked both archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0