suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

absorbing the source for the test suite of js-vm. This will need to run eventually.

Browse Source
This commit is contained in:
Danny Yoo 2011-06-10 12:20:02 -04:00
parent 328d4278fc
commit d5e1f65170
98 changed files with 20473 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
tests/older-tests/all-tests.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp "../lang/base.rkt"
(require "mz-tests/all-tests.rkt"
"moby-programs/all-tests.rkt")

621
tests/older-tests/benchmarks/conform.rkt Normal file
View File

@ -0,0 +1,621 @@
#lang s-exp "../../lang/base.rkt"
(require "run-benchmark.rkt")
(provide confirm-benchmark)
;
; conform.scm [portable/R^399RS version]
; By Jim Miller [mods by oz]
; [call to run-benchmark added by wdc 14 Feb 1997]
; (declare (usual-integrations))
;; SORT
(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)
(when (< 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))
(when (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)))))))))
(when (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)
(when (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))))
(when (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) #t))))
;;; note printflag #t
;(define (time-test)
; (let ((t (runtime)))
; (let ((ans (test)))
; (cons ans (- (runtime) t)))))
;
; run and make sure result is correct
;
(define (go)
(reset)
(let ((result '("(((b v d) ^ a) v c)"
"(c ^ d)"
"(b v (a ^ d))"
"((a v d) ^ b)"
"(b v d)"
"(b ^ (a v c))"
"(a v (c ^ d))"
"((b v d) ^ a)"
"(c v (a v d))"
"(a v c)"
"(d v (b ^ (a v c)))"
"(d ^ (a v c))"
"((a ^ d) v c)"
"((a ^ b) v d)"
"(((a v d) ^ b) v (a ^ d))"
"(b ^ d)"
"(b v (a v d))"
"(a ^ c)"
"(b ^ (c v d))"
"(a ^ b)"
"(a v b)"
"((a ^ d) ^ b)"
"(a ^ d)"
"(a v d)"
"d"
"(c v d)"
"a"
"b"
"c"
"any"
"none")))
(if (equal? (test) result)
(display " ok.")
(display " um."))
(newline)))
;[mods made by wdc]
;(go)
;(exit)
(define (conform-benchmark . rest)
(apply run-benchmark "conform" go rest))

22
tests/older-tests/benchmarks/do-measures.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang s-exp "../../lang/base.rkt"
(require "nboyer.rkt"
"sboyer.rkt"
"tak.rkt"
"nfa.rkt"
"graphs.rkt")
"(tak-benchmark)"
(tak-benchmark)
"(nboyer-benchmark 0)"
(nboyer-benchmark 0)
"(nboyer-benchmark 4)"
(nboyer-benchmark 4)
"sboyer"

650
tests/older-tests/benchmarks/graphs.rkt Normal file
View File

@ -0,0 +1,650 @@
#lang s-exp "../../lang/base.rkt"
(require "run-benchmark.rkt")
(provide graphs-benchmark)
; Modified 2 March 1997 by Will Clinger to add graphs-benchmark
; and to expand the four macros below.
; Modified 11 June 1997 by Will Clinger to eliminate assertions
; and to replace a use of "recur" with a named let.
;
; Performance note: (graphs-benchmark 7) allocates
; 34509143 pairs
; 389625 vectors with 2551590 elements
; 56653504 closures (not counting top level and known procedures)
(define (graphs-benchmark . rest)
(let ((N (if (null? rest) 7 (car rest))))
(run-benchmark (string-append "graphs" (number->string N))
(lambda ()
(fold-over-rdg N
2
cons
'())))))
; End of new code.
;;; ==== std.ss ====
; (define-syntax assert
; (syntax-rules ()
; ((assert test info-rest ...)
; #F)))
;
; (define-syntax deny
; (syntax-rules ()
; ((deny test info-rest ...)
; #F)))
;
; (define-syntax when
; (syntax-rules ()
; ((when test e-first e-rest ...)
; (if test
; (begin e-first
; e-rest ...)))))
;
; (define-syntax unless
; (syntax-rules ()
; ((unless test e-first e-rest ...)
; (if (not test)
; (begin e-first
; e-rest ...)))))
(define assert
(lambda (test . info)
#f))
;;; ==== util.ss ====
; Fold over list elements, associating to the left.
(define fold
(lambda (lst folder state)
'(assert (list? lst)
lst)
'(assert (procedure? folder)
folder)
(do ((lst lst
(cdr lst))
(state state
(folder (car lst)
state)))
((null? lst)
state))))
; Given the size of a vector and a procedure which
; sends indicies to desired vector elements, create
; and return the vector.
(define proc->vector
(lambda (size f)
'(assert (and (integer? size)
(exact? size)
(>= size 0))
size)
'(assert (procedure? f)
f)
(if (zero? size)
(vector)
(let ((x (make-vector size (f 0))))
(let loop ((i 1))
(when (< i size) (begin ; [wdc - was when]
(vector-set! x i (f i))
(loop (+ i 1)))))
x))))
(define vector-fold
(lambda (vec folder state)
'(assert (vector? vec)
vec)
'(assert (procedure? folder)
folder)
(let ((len
(vector-length vec)))
(do ((i 0
(+ i 1))
(state state
(folder (vector-ref vec i)
state)))
((= i len)
state)))))
(define vector-map
(lambda (vec proc)
(proc->vector (vector-length vec)
(lambda (i)
(proc (vector-ref vec i))))))
; Given limit, return the list 0, 1, ..., limit-1.
(define giota
(lambda (limit)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
(let -*-
((limit
limit)
(res
'()))
(if (zero? limit)
res
(let ((limit
(- limit 1)))
(-*- limit
(cons limit res)))))))
; Fold over the integers [0, limit).
(define gnatural-fold
(lambda (limit folder state)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? folder)
folder)
(do ((i 0
(+ i 1))
(state state
(folder i state)))
((= i limit)
state))))
; Iterate over the integers [0, limit).
(define gnatural-for-each
(lambda (limit proc!)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? proc!)
proc!)
(do ((i 0
(+ i 1)))
((= i limit))
(proc! i))))
(define natural-for-all?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let -*-
((i 0))
(or (= i limit)
(and (ok? i)
(-*- (+ i 1)))))))
(define natural-there-exists?
(lambda (limit ok?)
'(assert (and (integer? limit)
(exact? limit)
(>= limit 0))
limit)
'(assert (procedure? ok?)
ok?)
(let -*-
((i 0))
(and (not (= i limit))
(or (ok? i)
(-*- (+ i 1)))))))
(define there-exists?
(lambda (lst ok?)
'(assert (list? lst)
lst)
'(assert (procedure? ok?)
ok?)
(let -*-
((lst lst))
(and (not (null? lst))
(or (ok? (car lst))
(-*- (cdr lst)))))))
;;; ==== ptfold.ss ====
; Fold over the tree of permutations of a universe.
; Each branch (from the root) is a permutation of universe.
; Each node at depth d corresponds to all permutations which pick the
; elements spelled out on the branch from the root to that node as
; the first d elements.
; Their are two components to the state:
; The b-state is only a function of the branch from the root.
; The t-state is a function of all nodes seen so far.
; At each node, b-folder is called via
; (b-folder elem b-state t-state deeper accross)
; where elem is the next element of the universe picked.
; If b-folder can determine the result of the total tree fold at this stage,
; it should simply return the result.
; If b-folder can determine the result of folding over the sub-tree
; rooted at the resulting node, it should call accross via
; (accross new-t-state)
; where new-t-state is that result.
; Otherwise, b-folder should call deeper via
; (deeper new-b-state new-t-state)
; where new-b-state is the b-state for the new node and new-t-state is
; the new folded t-state.
; At the leaves of the tree, t-folder is called via
; (t-folder b-state t-state accross)
; If t-folder can determine the result of the total tree fold at this stage,
; it should simply return that result.
; If not, it should call accross via
; (accross new-t-state)
; Note, fold-over-perm-tree always calls b-folder in depth-first order.
; I.e., when b-folder is called at depth d, the branch leading to that
; node is the most recent calls to b-folder at all the depths less than d.
; This is a gross efficiency hack so that b-folder can use mutation to
; keep the current branch.
(define fold-over-perm-tree
(lambda (universe b-folder b-state t-folder t-state)
'(assert (list? universe)
universe)
'(assert (procedure? b-folder)
b-folder)
'(assert (procedure? t-folder)
t-folder)
(let -*-
((universe
universe)
(b-state
b-state)
(t-state
t-state)
(accross
(lambda (final-t-state)
final-t-state)))
(if (null? universe)
(t-folder b-state t-state accross)
(let -**-
((in
universe)
(out
'())
(t-state
t-state))
(let* ((first
(car in))
(rest
(cdr in))
(accross
(if (null? rest)
accross
(lambda (new-t-state)
(-**- rest
(cons first out)
new-t-state)))))
(b-folder first
b-state
t-state
(lambda (new-b-state new-t-state)
(-*- (fold out cons rest)
new-b-state
new-t-state
accross))
accross)))))))
;;; ==== minimal.ss ====
; A directed graph is stored as a connection matrix (vector-of-vectors)
; where the first index is the `from' vertex and the second is the `to'
; vertex. Each entry is a bool indicating if the edge exists.
; The diagonal of the matrix is never examined.
; Make-minimal? returns a procedure which tests if a labelling
; of the verticies is such that the matrix is minimal.
; If it is, then the procedure returns the result of folding over
; the elements of the automoriphism group. If not, it returns #F.
; The folding is done by calling folder via
; (folder perm state accross)
; If the folder wants to continue, it should call accross via
; (accross new-state)
; If it just wants the entire minimal? procedure to return something,
; it should return that.
; The ordering used is lexicographic (with #T > #F) and entries
; are examined in the following order:
; 1->0, 0->1
;
; 2->0, 0->2
; 2->1, 1->2
;
; 3->0, 0->3
; 3->1, 1->3
; 3->2, 2->3
; ...
(define make-minimal?
(lambda (max-size)
'(assert (and (integer? max-size)
(exact? max-size)
(>= max-size 0))
max-size)
(let ((iotas
(proc->vector (+ max-size 1)
giota))
(perm
(make-vector max-size 0)))
(lambda (size graph folder state)
'(assert (and (integer? size)
(exact? size)
(<= 0 size max-size))
size
max-size)
'(assert (vector? graph)
graph)
'(assert (procedure? folder)
folder)
(fold-over-perm-tree (vector-ref iotas size)
(lambda (perm-x x state deeper accross)
(case (cmp-next-vertex graph perm x perm-x)
((less)
#F)
((equal)
(vector-set! perm x perm-x)
(deeper (+ x 1)
state))
((more)
(accross state))
(else
(assert #F))))
0
(lambda (leaf-depth state accross)
'(assert (eqv? leaf-depth size)
leaf-depth
size)
(folder perm state accross))
state)))))
; Given a graph, a partial permutation vector, the next input and the next
; output, return 'less, 'equal or 'more depending on the lexicographic
; comparison between the permuted and un-permuted graph.
(define cmp-next-vertex
(lambda (graph perm x perm-x)
(let ((from-x
(vector-ref graph x))
(from-perm-x
(vector-ref graph perm-x)))
(let -*-
((y
0))
(if (= x y)
'equal
(let ((x->y?
(vector-ref from-x y))
(perm-y
(vector-ref perm y)))
(cond ((eq? x->y?
(vector-ref from-perm-x perm-y))
(let ((y->x?
(vector-ref (vector-ref graph y)
x)))
(cond ((eq? y->x?
(vector-ref (vector-ref graph perm-y)
perm-x))
(-*- (+ y 1)))
(y->x?
'less)
(else
'more))))
(x->y?
'less)
(else
'more))))))))
;;; ==== rdg.ss ====
; Fold over rooted directed graphs with bounded out-degree.
; Size is the number of verticies (including the root). Max-out is the
; maximum out-degree for any vertex. Folder is called via
; (folder edges state)
; where edges is a list of length size. The ith element of the list is
; a list of the verticies j for which there is an edge from i to j.
; The last vertex is the root.
(define fold-over-rdg
(lambda (size max-out folder state)
'(assert (and (exact? size)
(integer? size)
(> size 0))
size)
'(assert (and (exact? max-out)
(integer? max-out)
(>= max-out 0))
max-out)
'(assert (procedure? folder)
folder)
(let* ((root
(- size 1))
(edge?
(proc->vector size
(lambda (from)
(make-vector size #F))))
(edges
(make-vector size '()))
(out-degrees
(make-vector size 0))
(minimal-folder
(make-minimal? root))
(non-root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #T)
state)
(accross #T))))
(lambda (size)
(minimal-folder size
edge?
cont
#T))))
(root-minimal?
(let ((cont
(lambda (perm state accross)
'(assert (eq? state #T)
state)
(case (cmp-next-vertex edge? perm root root)
((less)
#F)
((equal more)
(accross #T))
(else
(assert #F))))))
(lambda ()
(minimal-folder root
edge?
cont
#T)))))
(let -*-
((vertex
0)
(state
state))
(cond ((not (non-root-minimal? vertex))
state)
((= vertex root)
'(assert
(begin
(gnatural-for-each root
(lambda (v)
'(assert (= (vector-ref out-degrees v)
(length (vector-ref edges v)))
v
(vector-ref out-degrees v)
(vector-ref edges v))))
#T))
(let ((reach?
(make-reach? root edges))
(from-root
(vector-ref edge? root)))
(let -*-
((v
0)
(outs
0)
(efr
'())
(efrr
'())
(state
state))
(cond ((not (or (= v root)
(= outs max-out)))
(vector-set! from-root v #T)
(let ((state
(-*- (+ v 1)
(+ outs 1)
(cons v efr)
(cons (vector-ref reach? v)
efrr)
state)))
(vector-set! from-root v #F)
(-*- (+ v 1)
outs
efr
efrr
state)))
((and (natural-for-all? root
(lambda (v)
(there-exists? efrr
(lambda (r)
(vector-ref r v)))))
(root-minimal?))
(vector-set! edges root efr)
(folder
(proc->vector size
(lambda (i)
(vector-ref edges i)))
state))
(else
state)))))
(else
(let ((from-vertex
(vector-ref edge? vertex)))
(let -**-
((sv
0)
(outs
0)
(state
state))
(if (= sv vertex)
(begin
(vector-set! out-degrees vertex outs)
(-*- (+ vertex 1)
state))
(let* ((state
; no sv->vertex, no vertex->sv
(-**- (+ sv 1)
outs
state))
(from-sv
(vector-ref edge? sv))
(sv-out
(vector-ref out-degrees sv))
(state
(if (= sv-out max-out)
state
(begin
(vector-set! edges
sv
(cons vertex
(vector-ref edges sv)))
(vector-set! from-sv vertex #T)
(vector-set! out-degrees sv (+ sv-out 1))
(let* ((state
; sv->vertex, no vertex->sv
(-**- (+ sv 1)
outs
state))
(state
(if (= outs max-out)
state
(begin
(vector-set! from-vertex sv #T)
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(let ((state
; sv->vertex, vertex->sv
(-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
(vector-set! from-vertex sv #F)
state)))))
(vector-set! out-degrees sv sv-out)
(vector-set! from-sv vertex #F)
(vector-set! edges
sv
(cdr (vector-ref edges sv)))
state)))))
(if (= outs max-out)
state
(begin
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(vector-set! from-vertex sv #T)
(let ((state
; no sv->vertex, vertex->sv
(-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! from-vertex sv #F)
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
state)))))))))))))
; Given a vector which maps vertex to out-going-edge list,
; return a vector which gives reachability.
(define make-reach?
(lambda (size vertex->out)
(let ((res
(proc->vector size
(lambda (v)
(let ((from-v
(make-vector size #F)))
(vector-set! from-v v #T)
(for-each
(lambda (x)
(vector-set! from-v x #T))
(vector-ref vertex->out v))
from-v)))))
(gnatural-for-each size
(lambda (m)
(let ((from-m
(vector-ref res m)))
(gnatural-for-each size
(lambda (f)
(let ((from-f
(vector-ref res f)))
(when (vector-ref from-f m); [wdc - was when]
(begin
(gnatural-for-each size
(lambda (t)
(when (vector-ref from-m t)
(begin ; [wdc - was when]
(vector-set! from-f t #T)))))))))))))
res)))
;;; ==== test input ====
; Produces all directed graphs with N verticies, distinguished root,
; and out-degree bounded by 2, upto isomorphism (there are 44).
;(define go
; (let ((N 7))
; (fold-over-rdg N
; 2
; cons
; '())))

777
tests/older-tests/benchmarks/nboyer.rkt Normal file
View File

@ -0,0 +1,777 @@
#lang s-exp "../../lang/base.rkt"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: nboyer.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)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024 520,000
; 1 591777 2,085,000
; 2 1813975 5,175,000
; 3 5375678
; 4 16445406
; 5 51507739
; Nboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(require "run-benchmark.rkt")
(provide nboyer-benchmark)
(define (nboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark (string-append "nboyer"
(number->string n))
1
(lambda () (test-boyer n))
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t)))))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(void
(let ()
(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 (sub1 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 (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(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 (greatereqp 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 (sub1 a)
(zero))
(equal (sub1 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 (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(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))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
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 (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(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 if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get-lemmas (car term))))))
(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 unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(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)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(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))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f))))))

50
tests/older-tests/benchmarks/nfa.rkt Normal file
View File

@ -0,0 +1,50 @@
#lang s-exp "../../lang/base.rkt"
(require "run-benchmark.rkt")
(provide recursive-nfa-benchmark)
; The recursive-nfa benchmark. (Figure 45, page 143.)
(define (recursive-nfa input)
(define (state0 input)
(or (state1 input) (state3 input) #f))
(define (state1 input)
(and (not (null? input))
(or (and (char=? (car input) #\a)
(state1 (cdr input)))
(and (char=? (car input) #\c)
(state1 input))
(state2 input))))
(define (state2 input)
(and (not (null? input))
(char=? (car input) #\b)
(not (null? (cdr input)))
(char=? (cadr input) #\c)
(not (null? (cddr input)))
(char=? (caddr input) #\d)
'state2))
(define (state3 input)
(and (not (null? input))
(or (and (char=? (car input) #\a)
(state3 (cdr input)))
(state4 input))))
(define (state4 input)
(and (not (null? input))
(char=? (car input) #\b)
(not (null? (cdr input)))
(char=? (cadr input) #\c)
'state4))
(or (state0 (string->list input))
'fail))
(define (recursive-nfa-benchmark)
(let ((input (string-append (make-string 133 #\a) "bc")))
(run-benchmark "Recursive nfa"
(lambda () (recursive-nfa input))
1000)))

3779
tests/older-tests/benchmarks/nucleic2.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

56
tests/older-tests/benchmarks/run-benchmark.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang s-exp "../../lang/base.rkt"
(provide run-benchmark)
;;; Gambit-style run-benchmark.
;;;
;;; Invoke this procedure to run a benchmark.
;;; The first argument is a string identifying the benchmark.
;;; The second argument is the number of times to run the benchmark.
;;; The third argument is a thunk that runs the benchmark.
;;; The fourth argument is a unary predicate that warns if the result
;;; returned by the benchmark is incorrect.
;;;
;;; Example:
;;; (run-benchmark "make-vector"
;;; 1
;;; (lambda () (make-vector 1000000))
;;; (lambda (v) (and (vector? v) (= (vector-length v) #e1e6))))
;;; For backward compatibility, this procedure also works with the
;;; arguments that we once used to run benchmarks in Larceny.
(define (run-benchmark name arg2 . rest)
(let* ((old-style (procedure? arg2))
(thunk (if old-style arg2 (car rest)))
(n (if old-style
(if (null? rest) 1 (car rest))
arg2))
(ok? (if (or old-style (null? (cdr rest)))
(lambda (result) #t)
(cadr rest)))
(result '*))
(define (loop n)
(cond ((zero? n) #t)
((= n 1)
(set! result (thunk)))
(else
(thunk)
(loop (- n 1)))))
(when old-style
(begin (newline)
(display "Warning: Using old-style run-benchmark")
(newline)))
(newline)
(display "--------------------------------------------------------")
(newline)
(display name)
(newline)
; time is a macro supplied by Chez Scheme
(time (loop n))
(when (not (ok? result))
(begin (display "Error: Benchmark program returned wrong result: ")
(write result)
(newline)))))

4
tests/older-tests/benchmarks/run-do-measures.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(require "../../main.rkt")
(run-in-browser "do-measures.rkt")

3
tests/older-tests/benchmarks/run-nboyer.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket
(require (planet dyoo/js-vm))
(run-in-browser "nboyer.rkt")

790
tests/older-tests/benchmarks/sboyer.rkt Normal file
View File

@ -0,0 +1,790 @@
#lang s-exp "../../lang/base.rkt"
(require "run-benchmark.rkt")
(provide sboyer-benchmark)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: sboyer.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)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
;;; "sharing cons".
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024
; 1 591777
; 2 1813975
; 3 5375678
; 4 16445406
; 5 51507739
; Sboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (sboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark (string-append "sboyer"
(number->string n))
1
(lambda () (test-boyer n))
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t)))))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(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 (sub1 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 (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(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 (greatereqp 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 (sub1 a)
(zero))
(equal (sub1 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 (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(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))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
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 (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(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 if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
; The next procedure is Henry Baker's sharing CONS, which avoids
; allocation if the result is already in hand.
; The REWRITE and REWRITE-ARGS procedures have been modified to
; use SCONS instead of CONS.
(define (scons x y original)
(if (and (eq? x (car original))
(eq? y (cdr original)))
original
(cons x y)))
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (scons (car term)
(rewrite-args (cdr term))
term)
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (scons (rewrite (car lst))
(rewrite-args (cdr lst))
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 unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(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)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(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))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))

17
tests/older-tests/benchmarks/tak.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang s-exp "../../lang/base.rkt"
(provide tak-benchmark)
(require "run-benchmark.rkt")
(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)
(define (tak-benchmark)
(run-benchmark "Tak" (lambda () (tak 18 12 6)) 10))

78
tests/older-tests/check-coverage.rkt Normal file
View File

@ -0,0 +1,78 @@
#lang racket/base
(require "../private/get-wescheme-primitive-names.rkt"
racket/runtime-path
racket/path
racket/list)
(provide print-coverage-report untouched-wescheme-primitives)
(define-runtime-path program-path "moby-programs")
(define (read-module f)
(parameterize ([read-accept-reader #t])
(let loop ([sexp
(rest (first (rest (rest (rest (read
(open-input-file f)))))))])
sexp)))
(define moby-program-sources
(let loop ([files (directory-list program-path)])
(cond
[(empty? files)
'()]
[(and (file-exists? (build-path program-path (first files)))
(bytes=? (or (filename-extension (first files)) #"")
#"rkt"))
(cons (read-module (build-path program-path (first files)))
(loop (rest files)))]
[else
(loop (rest files))])))
(define (sexp-symbols an-sexp)
(cond
[(symbol? an-sexp)
(list an-sexp)]
[(pair? an-sexp)
(append (sexp-symbols (car an-sexp))
(sexp-symbols (cdr an-sexp)))]
[else
'()]))
;; untouched-wescheme-primitives: (listof symbol)
(define (untouched-wescheme-primitives)
(let ([ht (make-hash)])
(for ([sym wescheme-primitive-names])
(hash-set! ht sym #t))
(for ([sym (sexp-symbols moby-program-sources)])
(hash-remove! ht sym))
;; manually remove some
(hash-remove! ht '#%module-begin)
(hash-remove! ht '#%app)
(hash-remove! ht '#%datum)
(hash-remove! ht '#%top)
(hash-remove! ht '#%top-interaction)
(hash-remove! ht 'planet)
(for/list ([key (in-hash-keys ht)])
key)))
(define (print-coverage-report)
(let ([los (untouched-wescheme-primitives)])
(unless (empty? los)
(printf "~a PRIMITIVES UNTOUCHED BY TESTS!!!\nList below:\n" (length los))
(for ([sym (sort los (lambda (x y) (string<? (symbol->string x)
(symbol->string y))))])
(printf "~a\n" sym))
(printf "\n"))))
(print-coverage-report)

12
tests/older-tests/moby-programs/42.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp "../../lang/wescheme.rkt"
(printf "42.rkt\n")
(define (f x)
(* x x))
(check-expect (format "~s ~s ~s\n"
(f 16)
(f -5)
(f 42))
"256 25 1764\n")

67
tests/older-tests/moby-programs/all-tests.rkt Normal file
View File

@ -0,0 +1,67 @@
#lang s-exp "../../lang/base.rkt"
;; This module requires the majority of tests here.
;; NOTE: js-input.rkt is not being tested here. Must be handled interactively.
;; NOTE: continuation-prompts.rkt is not being tested here. Must be handled interactively.
;; NOTE: continuation-prompts-3.rkt is not being tested here. Must be handled interactively.
(require "sleep.rkt"
"display-and-write.rkt"
"repeating-decimals.rkt"
"ffi.rkt"
"ffi-2.rkt"
"continuation-marks.rkt"
"atan.rkt"
"with-handlers-1.rkt"
"with-handlers-2.rkt"
"when-unless.rkt"
"setbang.rkt"
"require.rkt"
"quasiquote.rkt"
"permissions.rkt"
"local.rkt"
"for-each.rkt"
"letrec.rkt"
"recur.rkt"
"math.rkt"
"eof.rkt"
"js-big-bang-timer.rkt"
"images.rkt"
"image-equality.rkt"
"falling-ball.rkt"
"exercise-control.rkt"
"double-client.rkt"
"define-struct.rkt"
"continuation-prompts-2.rkt"
"case-lambda.rkt"
"begin.rkt"
"and-or.rkt"
"42.rkt"
"cycles.rkt"
"list.rkt"
"vararity.rkt"
"check-error.rkt"
"vector.rkt"
"struct.rkt"
"arity.rkt"
"apply.rkt"
"values.rkt"
"compose.rkt"
"seconds.rkt"
"random.rkt"
"identity.rkt"
"raise.rkt"
"exn.rkt"
"misc.rkt"
"jsworld.rkt"
"location.rkt"
"rotate.rkt"
"more-jsworld.ss")
(printf "all-tests completed\n")

13
tests/older-tests/moby-programs/and-or.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "and-or.rkt\n")
(check-expect (and true "hello") "hello")
(check-expect (or #f #f "world" 'dontcomehere)
"world")
(check-expect (not 3) false)
(check-expect (not (not 3)) true)
(printf "and-or.rkt end\n")

18
tests/older-tests/moby-programs/apply.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"apply.rkt"
(check-expect (apply + '()) 0)
(check-expect (apply + '(1 2 3)) 6)
(check-expect (apply + 4 6 '(1 2 3)) 16)
(define f (lambda args args))
(check-expect (apply f 'hello 'world '()) '(hello world))
(let ([g (λ (x) (* x x))])
(test-expect (apply g 3 '()) 9))
"apply.rkt end"

31
tests/older-tests/moby-programs/arity.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang s-exp "../../lang/wescheme.rkt"
"arity.rkt"
(check-expect (procedure-arity (lambda () (void))) 0)
(check-expect (procedure-arity (lambda (x) (void))) 1)
(check-expect (procedure-arity (lambda (x y . z) (void)))
(make-arity-at-least 2))
(check-expect (arity-at-least? (make-arity-at-least 0))
true)
(check-expect (arity-at-least? 'not-an-arity)
false)
(check-expect (arity-at-least-value
(make-arity-at-least 7))
7)
(define f
(case-lambda [(x y) (list x y)]
[(x y z) (list x y z)]))
(check-expect (procedure-arity-includes? f 2) true)
(check-expect (procedure-arity-includes? f 3) true)
(check-expect (procedure-arity-includes? f 4) false)
(check-expect (procedure-arity-includes? f 0) false)
(check-expect (procedure-arity-includes? (lambda (x) (* x x)) 1) true)
(check-expect (procedure-arity-includes? (lambda (x) (* x x)) 0) false)
(check-expect (procedure-arity-includes? (lambda args (void)) 0) true)
"arity.rkt end"

27
tests/older-tests/moby-programs/atan.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang s-exp "../../lang/wescheme.rkt"
"atan.rkt tests"
(define delta 0.000001)
(check-within (atan 0.5)
0.4636476090008061
delta)
(check-within (atan 2 1)
1.1071487177940904
delta)
(check-within (atan -2 -1)
-2.0344439357957027
delta)
(check-within (real-part (atan 1.0+5.0i))
1.530881333938778
delta)
(check-within (imag-part (atan 1.0+5.0i))
0.19442614214700213
delta)
(check-within (atan +inf.0 -inf.0)
2.356194490192345
delta)
"atan.rkt tests done"

27
tests/older-tests/moby-programs/begin.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang s-exp "../../lang/wescheme.ss"
(require "../../lang/check-expect/test-expect.rkt")
(printf "begin.rkt\n")
(printf "You should see the string \"hello world\" immediately after this: ")
(begin (printf "hello ")
(printf "world\n"))
(let ([counter 17])
(test-expect (begin
counter
(set! counter (add1 counter))
counter)
18))
(let ([counter 17])
(test-expect (begin0 counter
(set! counter (add1 counter))
counter)
17))
"begin.rkt end"

13
tests/older-tests/moby-programs/case-lambda.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "case-lambda.rkt\n")
(define f
(case-lambda
[(x) (list x)]
[(x y) (list y x)]
[(x y z) (list z y x)]))
(check-expect (f 3) (list 3))
(check-expect (f 3 4) (list 4 3))
(check-expect (f 3 4 5) (list 5 4 3))

13
tests/older-tests/moby-programs/check-error.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang s-exp "../../lang/wescheme.rkt"
(check-error (/ 1 0) "/: division by zero")
#;(define-struct foo ())
#;(check-error (make-foo 3 4)
"make-foo: expects no arguments, given 2: 3 4")
#;(define (f x)
(* x x))
#;(check-error (f 3 4) "procedure f: expects 1 argument, given 2: 3 4")

18
tests/older-tests/moby-programs/compose.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang s-exp "../../lang/wescheme.rkt"
"compose.rkt"
(define (f x) (* x x))
(define (g x) (+ x x))
(check-expect (procedure? (compose f g)) true)
(check-expect ((compose f g) 7)
(* 14 14))
(check-expect ((compose) 7)
7)
(check-expect ((compose f) 7)
49)
"compose.rkt end"

19
tests/older-tests/moby-programs/continuation-marks.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"continuation-marks.rkt"
(with-continuation-mark 'x 3
(test-expect (continuation-mark-set->list
(current-continuation-marks)
'x)
'(3)))
(with-continuation-mark 'x 3
(with-continuation-mark 'x 4
(test-expect (continuation-mark-set->list
(current-continuation-marks)
'x)
'(4))))
"continuation-marks.rkt end"

41
tests/older-tests/moby-programs/continuation-prompts-2.rkt Normal file
View File

@ -0,0 +1,41 @@
#lang s-exp "../../lang/wescheme.rkt"
(define (escape v)
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () v)))
(printf "continuation-prompts-2.rkt\n")
(printf "testing expected value from abort with default continuation prompt tag\n")
(check-expect
(+ 1
(call-with-continuation-prompt
(lambda ()
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (escape 6))))))))
(default-continuation-prompt-tag)))
7)
(check-expect
(+ 1
(call-with-continuation-prompt
(lambda ()
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (escape 24))))))))
(default-continuation-prompt-tag)
(lambda (thunk)
(printf "I see the escape\n")
(thunk))))
25)
(printf "continuation-prompts-2 tests done!\n")

19
tests/older-tests/moby-programs/continuation-prompts-3.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang s-exp "../../lang/base.rkt"
(define n 0)
(define (f)
(call-with-continuation-prompt
(lambda ()
(abort-current-continuation (default-continuation-prompt-tag)
(lambda ()
(set! n (add1 n))
(when (< n 10000)
(f)))))
(default-continuation-prompt-tag)
(lambda (thunk)
(thunk))))
(f)
n

30
tests/older-tests/moby-programs/continuation-prompts.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang s-exp "../../lang/base.rkt"
(call-with-continuation-prompt
(lambda () (printf "Hello world\n")
(values 3 4 5))
(default-continuation-prompt-tag)
(lambda (thunk)
(error)))
(call-with-continuation-prompt
(lambda (a b c) (printf "~a ~a ~a\n" a b c)
(values 3 4 5))
(default-continuation-prompt-tag)
(lambda (thunk)
(error))
"hello"
"world"
"again")
(abort-current-continuation (default-continuation-prompt-tag)
(lambda ()
(printf "This is the error thunk.")))
(printf "I should not see this\n")

141
tests/older-tests/moby-programs/cycles.rkt Normal file
View File

@ -0,0 +1,141 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"cycle tests"
(define-struct thingy (x y))
(let ([result (shared ([y (make-thingy y y)])
y)])
(test-expect (thingy-x result) result)
(test-expect (thingy-y result) result))
(define mylst (cons 1 (cons (box #f) empty)))
(set-box! (cadr mylst) mylst)
;; FIXME: the output format for cycles in the Javascript implementation is
;; printing out ... rather than the traditional format.
;;
;; This is a bad deviation.
(test-expect (format "~s\n" mylst)
"(1 #&...)\n")
(shared ([a (cons 1 a)])
(test-expect (format "~s\n"a)
"(1 . ...)\n"))
(shared ([a (vector 1 2 a)])
(test-expect (format "~s\n" a)
"#(1 2 ...)\n"))
(shared ([a (box a)])
(test-expect (format "~s\n" a)
"#&...\n"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define my-list (shared ([x (cons 1 (cons 2 (cons 3 y)))]
[y (cons 'a (cons 'b (cons 'c (cons 'd x))))])
x))
(define (take n l)
(cond
[(= n 0)
empty]
[else
(cons (first l)
(take (sub1 n) (rest l)))]))
(test-expect (take 20 my-list)
'(1 2 3 a b c d 1 2 3 a b c d 1 2 3 a b c))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test-expect (shared ([x (list 1 2)]) x)
(list 1 2))
(test-expect (shared ([x (vector 1 2)]) x)
#(1 2))
(test-expect (shared ([x (box 1)]) x)
(box 1))
(test-expect (shared ([x (cons 1 null)]) x)
'(1))
;;(stest (x "#1=(#1# 1)") '(shared ([x (list x 1)]) x))
(let ([result (shared ([x (list x 1)]) x)])
(test-expect result (car result))
(test-expect (cdr result) '(1)))
;(stest (x "#2=#(#2# 1)") '(shared ([x (vector x 1)]) x))
(let ([result (shared ([x (vector x 1)]) x)])
(test-expect (vector-ref result 0) result)
(test-expect (vector-ref result 1) 1)
(test-expect (vector-length result) 2))
;(stest (x "#2=#(#2# 1)") '(shared ([x (vector-immutable x 1)]) x))
;(let ([result (shared ([x (vector-immutable x 1)]) x)])
; (test-expect (vector-ref result 0) result)
; (test-expect (vector-ref result 1) 1)
; (test-expect (vector-length result) 2))
;(stest (x "#3=#&#3#") '(shared ([x (box x)]) x))
(let ([result (shared ([x (box x)]) x)])
(test-expect (unbox result) result))
;(stest (x "#3=#&#3#") '(shared ([x (box-immutable x)]) x))
;(stest (x "#4=(#4#)") '(shared ([x (cons x null)]) x))
(let ([result (shared ([x (cons x null)]) x)])
(test-expect (car result) result)
(test-expect (cdr result) null))
;(stest (x "#5=(1 . #5#)") '(shared ([x (cons 1 x)]) x))
(let ([result (shared ([x (cons 1 x)]) x)])
(test-expect (car result) 1)
(test-expect (cdr result) result))
;; (stest (x "#11=(#11#)") '(shared ([x `(,x)]) x))
(let ([result (shared ([x `(,x)]) x)])
(test-expect (length result) 1)
(test-expect (car result) result))
;; (stest (x "#11=(#11# 1)") '(shared ([x `(,x 1)]) x))
(let ([result (shared ([x `(,x 1)]) x)])
(test-expect (length result) 2)
(test-expect (car result) result)
(test-expect (cdr result) '(1)))
"cycle tests done"

10
tests/older-tests/moby-programs/define-struct.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "define-struct.rkt\n")
(define-struct p (x y))
"should be a structure: " (make-p 3 4)
(check-expect (p? (make-p 3 4))
true)
(check-expect (p-x (make-p 3 4)) 3)
(check-expect (p-y (make-p 3 4)) 4)

12
tests/older-tests/moby-programs/display-and-write.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp "../../lang/wescheme.rkt"
(printf "should not be in quotes: ")
(display "hello world")
(newline)
(printf "should be in quotes: ")
(write "hello world")
(newline)
((current-print) "using current-print")

8
tests/older-tests/moby-programs/double-client.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "double.rkt")
(check-expect (double 3) 6)
(check-expect (double (double (double 2))) 16)

2
tests/older-tests/moby-programs/double.js Normal file
View File

@ -0,0 +1,2 @@
EXPORTS['double'] =
new types.PrimProc('double', 1, false, false, function(x) { return jsnums.multiply(x, 2)});

5
tests/older-tests/moby-programs/double.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang s-exp "../../lang/js-impl/js-impl.rkt"
(require-js "double.js")
(provide double)

9
tests/older-tests/moby-programs/eof.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp "../../lang/wescheme.rkt"
"eof.rkt"
(check-expect (eof-object? eof) true)
(check-expect (eof-object? 'eof) false)
"eof.rkt end"

133
tests/older-tests/moby-programs/exercise-control.rkt Normal file
View File

@ -0,0 +1,133 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "exercise-control.rkt\n")
(check-expect (if true
'ok
'not-ok)
'ok)
(check-expect (if false
'not-ok
'ok)
'ok)
(check-expect (cond [true 'ok]
[else 'not-ok])
'ok)
(check-expect (cond [false 'not-ok]
[else 'ok])
'ok)
(check-expect (case 42
[(1) 'not-ok]
[(2) 'not-ok]
[(42) 'ok])
'ok)
(check-expect (case 42
[(1) 'not-ok]
[(2) 'not-ok]
[(42) 'ok])
'ok)
;; Runtime error: we should see if the test isn't boolean
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "cond: question result is not true or false: 42"
(exn-message exn))
(error 'cond-test)))])
(cond
[42
(error 'uh-oh)]
[else
(error 'cond-test)]))
;; Test fall-through
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "cond: all question results were false"
(exn-message exn))
(error 'cond-test)))])
(cond
[false (error 'uh-oh)]))
;; Runtime error: we should see if the test isn't boolean
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "if: question result is not true or false: \"not a boolean\""
(exn-message exn))
(error 'cond-test)))])
(if "not a boolean"
(error 'uh-oh)
(error 'uh-oh)))
;; Check fall-though with case being an error
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "case: the expression matched none of the choices"
(exn-message exn))
(error 'case-test)))])
(case 42
[(1) (error 'case)]
[(2) (error 'case)]
[(3) (error 'case)])
(error 'case))
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "when: question result is not true or false: \"not a boolean\""
(exn-message exn))
(error 'when-boolean-test)))])
(when "not a boolean"
(error 'uh-oh)))
(with-handlers ([exn:fail?
(lambda (exn)
(unless (string=? "unless: question result is not true or false: \"not a boolean\""
(exn-message exn))
(error 'unless-boolean-test)))])
(unless "not a boolean"
(error 'uh-oh)))
(unless (= 0 0)
(error 'huh?))
(when (= 0 1)
(error 'huh?))
(check-expect (let/cc return
(begin
(return 42)
(error)))
42)
(check-expect (let/cc return
(begin
'fall-through))
'fall-through)
(printf "exercise-control.rkt end\n")

79
tests/older-tests/moby-programs/exn.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang s-exp "../../lang/wescheme.rkt"
"exn.rkt"
(define e0 (make-exn "blah" (current-continuation-marks)))
(define e1 (make-exn:fail "foo" (current-continuation-marks)))
(define e2 (make-exn:fail:contract "bar" (current-continuation-marks)))
(define e3 (make-exn:fail:contract:arity "baz" (current-continuation-marks)))
(define e4 (make-exn:fail:contract:divide-by-zero "blip" (current-continuation-marks)))
(define e5 (make-exn:fail:contract:variable "blop" (current-continuation-marks) 'x))
(check-expect (exn? e0) true)
(check-expect (exn? e1) true)
(check-expect (exn? e2) true)
(check-expect (exn? e3) true)
(check-expect (exn? e4) true)
(check-expect (exn? e5) true)
(check-expect (exn-message e0) "blah")
(check-expect (exn-message e1) "foo")
(check-expect (exn-message e2) "bar")
(check-expect (exn-message e3) "baz")
(check-expect (exn-message e4) "blip")
(check-expect (exn-message e5) "blop")
(check-expect (continuation-mark-set?
(exn-continuation-marks e0)) true)
(check-expect (continuation-mark-set?
(exn-continuation-marks e1)) true)
(check-expect (continuation-mark-set?
(exn-continuation-marks e2)) true)
(check-expect (continuation-mark-set?
(exn-continuation-marks e3)) true)
(check-expect (continuation-mark-set?
(exn-continuation-marks e4)) true)
(check-expect (continuation-mark-set?
(exn-continuation-marks e5)) true)
(check-expect (exn:fail? e0) false)
(check-expect (exn:fail? e1) true)
(check-expect (exn:fail? e2) true)
(check-expect (exn:fail? e3) true)
(check-expect (exn:fail? e4) true)
(check-expect (exn:fail? e5) true)
(check-expect (exn:fail:contract? e0) false)
(check-expect (exn:fail:contract? e1) false)
(check-expect (exn:fail:contract? e2) true)
(check-expect (exn:fail:contract? e3) true)
(check-expect (exn:fail:contract? e4) true)
(check-expect (exn:fail:contract? e5) true)
(check-expect (exn:fail:contract:arity? e0) false)
(check-expect (exn:fail:contract:arity? e1) false)
(check-expect (exn:fail:contract:arity? e2) false)
(check-expect (exn:fail:contract:arity? e3) true)
(check-expect (exn:fail:contract:arity? e4) false)
(check-expect (exn:fail:contract:arity? e5) false)
(check-expect (exn:fail:contract:variable? e0) false)
(check-expect (exn:fail:contract:variable? e1) false)
(check-expect (exn:fail:contract:variable? e2) false)
(check-expect (exn:fail:contract:variable? e3) false)
(check-expect (exn:fail:contract:variable? e4) false)
(check-expect (exn:fail:contract:variable? e5) true)
(check-expect (exn:fail:contract:divide-by-zero? e0) false)
(check-expect (exn:fail:contract:divide-by-zero? e1) false)
(check-expect (exn:fail:contract:divide-by-zero? e2) false)
(check-expect (exn:fail:contract:divide-by-zero? e3) false)
(check-expect (exn:fail:contract:divide-by-zero? e4) true)
(check-expect (exn:fail:contract:divide-by-zero? e5) false)
"exn.rkt end"

48
tests/older-tests/moby-programs/falling-ball.rkt Normal file
View File

@ -0,0 +1,48 @@
#lang s-exp "../../lang/wescheme.ss"
;; Simple falling ball example. A red ball falls down the screen
;; until hitting the bottom.
(printf "falling-ball.rkt\n")
(define-struct world (radius y))
;; The dimensions of the screen:
(define WIDTH 320)
(define HEIGHT 480)
;; The radius of the red circle.
(define RADIUS 15)
;; The world is the distance from the top of the screen.
(define INITIAL-WORLD (make-world RADIUS 0))
;; tick: world -> world
;; Moves the ball down.
(define (tick w)
(make-world RADIUS (+ (world-y w) 5)))
;; hits-floor?: world -> boolean
;; Returns true when the distance reaches the screen height.
(define (hits-floor? w)
(>= (world-y w) HEIGHT))
;; We have some simple test cases.
(check-expect (hits-floor? (make-world RADIUS 0)) false)
(check-expect (hits-floor? (make-world RADIUS HEIGHT)) true)
;; render: world -> scene
;; Produces a scene with the circle at a height described by the world.
(define (render w)
(place-image (circle RADIUS "solid" "red") (/ WIDTH 2) (world-y w)
(empty-scene WIDTH HEIGHT)))
;; Start up a big bang, 15 frames a second.
(check-expect (big-bang INITIAL-WORLD
(on-tick tick 1/15)
(to-draw render)
(stop-when hits-floor?))
(make-world 15 480))

44
tests/older-tests/moby-programs/ffi-2.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang s-exp "../../lang/base.rkt"
(require "../../ffi/ffi.rkt"
"../../jsworld/jsworld.rkt"
"../../lang/check-expect/check-expect.rkt")
"my-ffi-2.rkt"
;; Check to see that we can expression on-tick with make-world-config.
(define (my-on-tick world-updater)
(make-world-config
(lambda (success)
(js-call (js-get-global-value "setInterval")
#f
(procedure->void-js-fun (lambda args (js-call success #f)))
1000))
(lambda (id)
(printf "shutdown with clearInterval id=~s\n" id)
(js-call (js-get-global-value "clearInterval")
#f
id))
(lambda (w)
(world-updater w))))
(check-expect (big-bang 1
(my-on-tick
(lambda (w)
(printf "tick!\n")
(add1 w)))
(stop-when
(lambda (n) (= n 10))))
10)
(run-tests)
"end my-ffi-2.rkt"

125
tests/older-tests/moby-programs/ffi.rkt Normal file
View File

@ -0,0 +1,125 @@
#lang s-exp "../../lang/base.rkt"
(require "../../ffi/ffi.rkt"
"../../lang/check-expect/check-expect.rkt")
(define window
(js-get-global-value "window"))
(define platform
(js-get-field window "navigator" "platform"))
(printf "Current browser platform is ~s\n"
(prim-js->scheme platform))
(check-expect (prim-js->scheme (scheme->prim-js "hello world"))
"hello world")
(check-expect (prim-js->scheme (scheme->prim-js #t))
#t)
(check-expect (prim-js->scheme (scheme->prim-js #f))
#f)
(printf "minimum and maximum js fixnums are ~a and ~a\n"
minimum-js-fixnum
maximum-js-fixnum)
;; (prim-js->scheme (scheme->prim-js ...)) is not the identity, unfortunately.
;; Here are tests that show that we need to do something:
;; Numbers that come back to us are inexact.
(check-expect (inexact->exact (prim-js->scheme (scheme->prim-js 42)))
42)
;; Characters are mapped to one-character strings.
(check-expect (prim-js->scheme (scheme->prim-js #\h))
"h")
;; Symbols are mapped to strings.
(check-expect (prim-js->scheme (scheme->prim-js 'hello))
"hello")
;; Note that when converting vectors, the resulting inner values are not
;; automatically transformed back. So the prim-js->scheme transformation
;; is shallow.
(check-expect (map prim-js->scheme
(vector->list (prim-js->scheme (scheme->prim-js #(1 2 3)))))
'(1.0 2.0 3.0))
(check-expect (map prim-js->scheme
(vector->list (prim-js->scheme
(scheme->prim-js #(1 "testing" 3)))))
'(1.0 "testing" 3.0))
(check-expect (js-=== js-undefined js-undefined) true)
(check-expect (js-=== js-null js-null) true)
(check-expect (js-=== js-undefined js-null) false)
(check-expect (js-=== js-null js-undefined) false)
(check-expect (js-typeof (scheme->prim-js 1)) "number")
(check-expect (js-typeof (scheme->prim-js "hello")) "string")
(check-expect (js-typeof (scheme->prim-js #t)) "boolean")
(check-expect (js-typeof (scheme->prim-js #f)) "boolean")
(check-expect (js-typeof (js-make-hash)) "object")
(check-expect (js-typeof (js-make-hash '(("name" "danny")
("school" "wpi")))) "object")
(define a-hash (js-make-hash '(("foo" "bar")
("baz" "blah"))))
(check-expect (prim-js->scheme (js-get-field a-hash "foo")) "bar")
(check-expect (prim-js->scheme (js-get-field a-hash "baz")) "blah")
(js-set-field! a-hash "something else" (box 3))
;; Uh oh. There's something about this that I do not understand about
;; the current design of the FFI. What's going on here?
(check-expect (js-get-field a-hash "something else")
(box 3))
(define my-escape
(let ([prim-escape (js-get-global-value "escape")])
(lambda (s)
(prim-js->scheme (js-call prim-escape #f s)))))
(check-expect (my-escape "hello world") "hello%20world")
(check-expect (my-escape "x.mv,") "x.mv%2C")
(let ([p (procedure->void-js-fun
(lambda () (printf "this is from scheme\n")))])
(printf "The following should repeat 'this is from scheme'\n")
(js-call p #f))
(let ([p (procedure->void-js-fun
(lambda (x y)
(printf "I see: ~s ~s\n"
(prim-js->scheme x)
(prim-js->scheme y))))])
(printf "The following should repeat 'I see 3 \"four\"\n")
(js-call p #f 3 "four"))
(run-tests)
"end of ffi tests"

16
tests/older-tests/moby-programs/for-each.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang s-exp "../../lang/wescheme.rkt"
"for-each"
(for-each (lambda (x) (error 'nothing!)) '())
(define l1 '(hello world this is a test))
(define l2 '(hello this test))
(for-each (lambda (x) (set! l1 (remove x l1)))
l2)
(check-expect l1 '(world is a))
"for-each.rkt end"

6
tests/older-tests/moby-programs/identity.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang s-exp "../../lang/wescheme.rkt"
(check-expect (identity 42) 42)
(define p (cons 3 4))
(check-expect (identity p) p)

319
tests/older-tests/moby-programs/image-equality.rkt Normal file
View File

@ -0,0 +1,319 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../image/image.rkt")
;; Tests on images.
;;
;; An image can be a circle, star, ns:rectangle, rectangle, triangle, ellipse, line, text, place-image, overlay, underlay
(define a-circle (circle 20 'solid 'green))
(define a-star (star 5 20 30 'solid 'blue))
(define a-nw-rect (nw:rectangle 20 30 'solid 'turquoise))
(define a-rect (rectangle 50 60 'outline 'black))
(define a-triangle (triangle 50 'solid 'magenta))
(define a-line (line 30 40 'red))
(define a-text (text "hello world" 20 "black"))
;; Let's show these at the toplevel to make sure the drawing is working
;; ok
(printf "should be a circle:") a-circle
(printf "should be a star:") a-star
(printf "should be a nw:rectangle:") a-nw-rect
(printf "should be a rectangle:") a-rect
(printf "should be a triangle:") a-triangle
(printf "should be a line:") a-line
(printf "should be a text:") a-text
;; check-fail-contract: (-> void) -> void
;; Make sure we fail with a contract error.
(define (check-fail-contract thunk)
(with-handlers ([exn:fail:contract? void])
(thunk)
(raise (format "failure expected: ~s" thunk))))
;; Now do image comparisons
(printf "running image comparison tests\n")
;; circles
(check-expect (equal? (circle 20 'solid 'green)
(circle 20 'solid 'green))
true)
(check-expect (equal? (circle 20 'solid 'green)
(circle 21 'solid 'green))
false)
(check-expect (equal? (circle 20 'solid 'green)
(circle 20 'solid 'blue))
false)
(check-fail-contract (lambda () (circle 20 "foobar" "green")))
(check-fail-contract (lambda () (circle 20 "outline" "not-a-color")))
(check-fail-contract (lambda () (circle 20 'green 'outline)))
(check-fail-contract (lambda () (circle 'green 'outline 20)))
(check-fail-contract (lambda () (circle)))
(check-fail-contract (lambda () (circle 20)))
(check-fail-contract (lambda () (circle 20 'outline)))
(check-fail-contract (lambda () (circle 20 'outline "black" "too-many-args")))
;; star
(check-expect (equal? (star 20 10 60 'solid 'purple)
(star 20 10 60 'solid 'purple))
true)
(check-expect (equal? (star 20 9 60 'solid 'purple)
(star 20 10 60 'solid 'purple))
false)
(check-expect (equal? (star 20 10 60 'solid 'purple)
(star 20 10 49 'solid 'purple))
false)
(check-expect (equal? (star 20 10 60 'solid 'purple)
(star 20 10 60 'outline 'purple))
false)
(check-expect (equal? (star 20 10 60 'solid 'purple)
(star 20 10 60 'solid 'magenta))
false)
(check-fail-contract (lambda () (star 20 10 60 "foobar" 'green)))
(check-fail-contract (lambda () (star 20 10 60 "outline" 'not-a-color)))
(check-fail-contract (lambda () (star 20 10 60 "green" 'outline)))
(check-fail-contract (lambda () (star 10 60 "green" 'outline 20)))
(check-fail-contract (lambda () (star)))
(check-fail-contract (lambda () (star 10)))
(check-fail-contract (lambda () (star 10 60)))
(check-fail-contract (lambda () (star 10 60 50)))
(check-fail-contract (lambda () (star 10 60 50 'outline)))
(check-fail-contract (lambda () (star 10 60 50 'outline 'green 'too-many-args)))
;; nw:rect
(check-expect (equal? (nw:rectangle 10 20 'solid 'black)
(nw:rectangle 10 20 'solid 'black))
true)
(check-expect (equal? (nw:rectangle 20 10 'solid 'black)
(nw:rectangle 10 20 'solid 'black))
false)
(check-expect (equal? (nw:rectangle 10 10 'solid 'black)
(nw:rectangle 10 20 'solid 'black))
false)
(check-expect (equal? (nw:rectangle 10 20 'solid 'black)
(nw:rectangle 10 20 'outline 'black))
false)
(check-expect (equal? (nw:rectangle 10 20 'solid 'black)
(nw:rectangle 10 20 'outline 'white))
false)
(check-fail-contract (lambda () (nw:rectangle 10 20 "foobar" 'green)))
(check-fail-contract (lambda () (nw:rectangle 10 20 "outline" 'not-a-color)))
(check-fail-contract (lambda () (nw:rectangle 10 20 'green 'outline)))
(check-fail-contract (lambda () (nw:rectangle 20 'green 'outline 10)))
(check-fail-contract (lambda () (nw:rectangle)))
(check-fail-contract (lambda () (nw:rectangle 10)))
(check-fail-contract (lambda () (nw:rectangle 10 20)))
(check-fail-contract (lambda () (nw:rectangle 10 20 'solid)))
(check-fail-contract
(lambda () (nw:rectangle 10 20 'solid 'green 'too-many-args)))
;; rect
(check-expect (equal? (rectangle 10 20 'solid 'black)
(rectangle 10 20 'solid 'black))
true)
(check-expect (equal? (rectangle 20 10 'solid 'black)
(rectangle 10 20 'solid 'black))
false)
(check-expect (equal? (rectangle 10 10 'solid 'black)
(rectangle 10 20 'solid 'black))
false)
(check-expect (equal? (rectangle 10 20 'solid 'black)
(rectangle 10 20 'outline 'black))
false)
(check-expect (equal? (rectangle 10 20 'solid 'black)
(rectangle 10 20 'outline 'white))
false)
(check-fail-contract (lambda () (rectangle 10 20 "foobar" 'green)))
(check-fail-contract (lambda () (rectangle 10 20 "outline" 'not-a-color)))
(check-fail-contract (lambda () (rectangle 10 20 'green 'outline)))
(check-fail-contract (lambda () (rectangle 20 'green 'outline 10)))
(check-fail-contract (lambda () (rectangle)))
(check-fail-contract (lambda () (rectangle 10)))
(check-fail-contract (lambda () (rectangle 10 20)))
(check-fail-contract (lambda () (rectangle 10 20 'solid)))
(check-fail-contract (lambda () (rectangle 10 20 'solid 'green 'too-many-args)))
;; triangle
(check-expect (equal? (triangle 10 'solid 'green)
(triangle 10 'solid 'green))
true)
(check-expect (equal? (triangle 10 'solid 'green)
(triangle 9 'solid 'green))
false)
(check-expect (equal? (triangle 10 'solid 'green)
(triangle 10 'outline 'green))
false)
(check-expect (equal? (triangle 10 'solid 'green)
(triangle 10 'solid 'olive))
false)
(check-fail-contract (lambda () (triangle 10 'foobar 'green)))
(check-fail-contract (lambda () (triangle 10 'outline 'not-a-color)))
(check-fail-contract (lambda () (triangle 10 'green 'outline)))
(check-fail-contract (lambda () (triangle 'green 'outline 10)))
(check-fail-contract (lambda () (triangle)))
(check-fail-contract (lambda () (triangle 'outline)))
(check-fail-contract (lambda () (triangle 10)))
(check-fail-contract (lambda () (triangle 10 'outline)))
(check-fail-contract (lambda () (triangle 10 'outline 'green 'too-many-args)))
;; line
(check-expect (equal? (line 10 20 'blue)
(line 10 20 'blue))
true)
(check-expect (equal? (line 10 20 'blue)
(line 20 10 'blue))
false)
(check-fail-contract (lambda () (line 10 20 'not-a-color)))
(check-fail-contract (lambda () (line 'not-a-color 20 10)))
(check-fail-contract (lambda () (line)))
(check-fail-contract (lambda () (line 10)))
(check-fail-contract (lambda () (line 10 20)))
(check-fail-contract (lambda () (line 10 20 "black" "too-many-args")))
;; text
(check-expect (equal? (text "hello" 20 'yellow)
(text "hello" 20 'yellow))
true)
(check-expect (equal? (text "hello" 20 'yellow)
(text "hi" 20 'yellow))
false)
(check-fail-contract (lambda () (text "hello")))
(check-fail-contract (lambda () (text "hello" 20)))
(check-fail-contract (lambda () (text "hello" 20 'yellow 'too-many-args)))
(check-fail-contract (lambda () (text 'hi 20 'yellow)))
(check-fail-contract (lambda () (text "hello" 'yellow 20)))
;; empty scenes
(check-expect (empty-scene 10 20)
(empty-scene 10 20))
(check-expect (equal? (empty-scene 10 20)
(empty-scene 11 20))
false)
(check-fail-contract (lambda () (empty-scene 'one 'two)))
(check-fail-contract (lambda () (empty-scene 10 20 30)))
(check-fail-contract (lambda () (empty-scene 10)))
;; place images
(check-fail-contract (lambda () (place-image)))
(check-fail-contract (lambda () (place-image 10)))
(check-fail-contract (lambda () (place-image (circle 20 'solid 'green))))
(check-fail-contract (lambda () (place-image (circle 20 'solid 'green) 10)))
(check-fail-contract (lambda () (place-image (circle 20 'solid 'green) 10 20)))
(check-fail-contract
(lambda ()
(place-image (circle 20 'solid 'green) 10 20 (empty-scene 3 4)
"too-many-args")))
(check-fail-contract
(lambda ()
(place-image 10 20 (circle 20 'solid 'green) (empty-scene 3 4))))
(check-expect (place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100)))
(check-expect (equal? (place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100)))
true)
(check-expect (equal? (place-image (circle 9 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100)))
false)
(check-expect (equal? (place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
40
50
(empty-scene 100 100)))
false)
(check-expect (equal? (place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
50
40
(empty-scene 100 100)))
false)
(check-expect (equal? (place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 100))
(place-image (circle 10 'solid 'green)
50
50
(empty-scene 100 99)))
false)
;; overlay
(check-fail-contract (lambda () (overlay)))
(check-expect (overlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green))
(overlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green)))
(check-expect (equal? (overlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green))
(overlay (circle 20 'solid 'green)
(rectangle 10 20 'solid 'blue)))
false)
;; underlay
(check-fail-contract (lambda () (underlay)))
(check-expect (underlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green))
(underlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green)))
(check-expect (equal? (underlay (rectangle 10 20 'solid 'blue)
(circle 20 'solid 'green))
(underlay (circle 20 'solid 'green)
(rectangle 10 20 'solid 'blue)))
false)
(printf "ran image comparison tests\n")

71
tests/older-tests/moby-programs/images.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang s-exp "../../lang/wescheme.rkt"
(printf "images.rkt\n")
(check-expect (image? 'blue) #f)
(check-expect (image? (circle 20 "solid" "green")) #t)
"should be a solid green circle: " (circle 20 "solid" "green")
(check-expect (image=? (circle 50 "solid" "blue")
(rectangle 20 30 "outline" "turquoise"))
#f)
"should be an outline turquoise rectangle: " (rectangle 20 30 "outline" "turquoise")
;(check-expect (color? (make-color 3 4 5)))
(check-expect (color-red (make-color 3 4 5)) 3)
(check-expect (color-green (make-color 3 4 5)) 4)
(check-expect (color-blue (make-color 3 4 5)) 5)
(check-expect (image? (empty-scene 20 50)) true)
(check-expect (image=? (empty-scene 20 50) (empty-scene 20 50)) true)
(check-expect (image? (place-image (circle 50 'solid 'blue)
50
50
(empty-scene 100 100)))
true)
"should be a blue circle in a scene with a border: " (place-image (circle 50 'solid 'blue)
50
50
(empty-scene 100 100))
"should be a text:" (text "hello world" 20 'black)
"should be a text as well:" (text (string-copy "hello world") 20 'black)
"should be a blue ellipse" (ellipse 100 200 "solid" "blue")
"should be an image from a url:" (image-url "http://racket-lang.org/logo.png")
"should be an image from a url:" (open-image-url "http://racket-lang.org/logo.png")
(check-expect (image?
(put-pinhole (rectangle 20 20 'solid 'green) 0 0))
true)
"should be an overlay"
(overlay (circle 20 'solid 'green)
(rectangle 10 20 'solid 'blue))
"should be an overlay/xy"
(overlay/xy (circle 20 'solid 'green)
0 0
(rectangle 10 20 'solid 'blue))
"should be an underlay"
(underlay (circle 20 'solid 'green)
(rectangle 10 20 'solid 'blue))
"should be an underlay/xy"
(underlay/xy (circle 20 'solid 'green)
0 0
(rectangle 10 20 'solid 'blue))

14
tests/older-tests/moby-programs/js-big-bang-timer.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../jsworld/jsworld.rkt")
(printf "js-big-bang-timer.rkt\n")
(printf "number should be counting up to ten\n")
(check-expect (big-bang 1
(on-tick (lambda (w)
(printf "~s~n" w)
(add1 w))
1/4)
(stop-when (lambda (w) (= w 10))))
10)

35
tests/older-tests/moby-programs/js-input.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang s-exp "../../lang/base.rkt"
(require "../../jsworld/jsworld.rkt")
(define (make-ingredient-checkbox-sexp ingredient)
(local [(define (on-check w v)
(cond
[v
(cons ingredient w)]
[else
(remove ingredient w)]))]
(list (js-div)
(list (js-text ingredient))
(list (js-input "checkbox"
on-check
`(("value" ,ingredient)))))))
(define c1 (make-ingredient-checkbox-sexp "mushrooms"))
(define c2 (make-ingredient-checkbox-sexp "green peppers"))
(define c3 (make-ingredient-checkbox-sexp "olives"))
(define (draw w)
(list (js-div)
c1
c2
c3
(list (js-text (format "The world is: ~s" w)))))
(define (draw-css w)
'())
(big-bang '()
(to-draw-page draw draw-css))

19
tests/older-tests/moby-programs/jsworld-effects.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../jsworld/define-effect.rkt")
(define-effect effect:beep ()
#:impl (lambda (w)
(printf "Beep!")))
"This is an effect: " (make-effect:beep)
(check-expect (effect? (make-effect:beep)) #t)
(check-expect (effect-type? (make-effect:beep)) #f)
(check-expect (effect-type? struct:effect:beep) #t)
(check-expect (effect-type? (make-effect:beep)) #f)
(big-bang 0
(initial-effect (make-effect:beep))
(stop-when (lambda (w) true)))

145
tests/older-tests/moby-programs/jsworld.rkt Normal file
View File

@ -0,0 +1,145 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../jsworld/jsworld.rkt")
;; more jsworld tests
(printf "jsworld.rkt\n")
(check-expect (js-big-bang 1 (stop-when (lambda (x) true)))
1)
"should be an empty page"
(void (big-bang 1
(to-draw-page (lambda (x)
(empty-page))
(lambda (x) '()))
(stop-when (lambda (x) true))))
"should be another empty page"
(void (big-bang 1
;; check single-arity to-draw-page
(to-draw-page (lambda (x)
(empty-page)))
(stop-when (lambda (x) true))))
"at this point, something should be moving on the screen."
(void (big-bang 1
(on-tick (lambda (x) (+ x 5)))
;; check single-arity to-draw-page
(to-draw-page (lambda (x)
(place-on-page
(if (>= x 500)
"I'm done"
"I'm moving!")
;(circle 100 'solid 'blue)
(modulo x 300)
(modulo x 300)
(empty-page))))
(stop-when (lambda (x) (>= x 500)))
(on-key (lambda (w k)
1))))
(void (initial-effect '()))
(check-expect (image-height (circle 20 'solid 'green))
40)
(check-expect (image-width (circle 30 'solid 'green))
60)
(check-expect (effect-type? 42) false)
(check-expect (effect? 42) false)
#;(check-expect (effect? '()) true)
"a button"
(void (big-bang 1
(to-draw-page (lambda (x)
(list
(js-button (lambda (x) x))
(list (js-text "a button")))))
(stop-when (lambda (x) true))))
"another button"
(void (big-bang 1
(to-draw-page (lambda (x)
(list
(js-button! (lambda (x) x)
(lambda (x) '()))
(list (js-text "another button")))))
(stop-when (lambda (x) true))))
"a js-img"
(void (big-bang 1
(to-draw-page
(lambda (x)
(list
(js-img "http://racket-lang.org/logo.png"))))
(stop-when (lambda (x) true))))
"a js-p"
(void (big-bang 1
(to-draw-page
(lambda (x)
(list
(js-p)
(list (js-text "hello world")))))
(stop-when (lambda (x) true))))
(check-expect (key=? "a" "a") true)
(check-expect (key=? "a" "b") false)
"js-select"
(let ()
(define (select-house w an-option)
an-option)
(define a-select-element
(js-select (list ""
"Gryffindor"
"Hufflepuff"
"Ravenclaw"
"Slytherin")
select-house))
(define (draw w)
(list (js-div)
(list a-select-element)
(list (js-text (format "House: ~a" w)))))
(define (draw-css w)
'())
(big-bang ""
(to-draw-page draw draw-css)
(stop-when (lambda (x) true))))
(void (on-key! (lambda (w a-key) w)
(lambda (w a-key) '())))
(void (on-tick! (lambda (w) w)
(lambda (w) '())))
(void (stop-when! (lambda (w) true)
(lambda (w) '())))
;; we need more effects
(void (world-with-effects '() 3))
"jsworld.rkt end"

50
tests/older-tests/moby-programs/letrec.rkt Normal file
View File

@ -0,0 +1,50 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"letrec"
(letrec ([even? (lambda (x)
(if (= x 0)
true
(odd? (sub1 x))))]
[odd? (lambda (x)
(if (= x 0)
false
(even? (sub1 x))))])
(test-expect (even? 1024) true)
(test-expect (even? 1023) false)
(test-expect (even? 2172) true)
(test-expect (even? 2171) false))
(letrec-values ([(even? odd?)
(values
(lambda (x)
(if (= x 0)
true
(odd? (sub1 x))))
(lambda (x)
(if (= x 0)
false
(even? (sub1 x)))))])
(test-expect (even? 1024) true)
(test-expect (even? 1023) false)
(test-expect (even? 2172) true)
(test-expect (even? 2171) false))
(letrec ([fact (lambda (x)
(if (= x 0)
1
(* x (fact (sub1 x)))))])
(test-expect (fact 3) 6)
(test-expect (fact 4) 24)
(test-expect (fact 5) 120))
"letrec.rkt end"

15
tests/older-tests/moby-programs/list.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang s-exp "../../lang/wescheme.rkt"
"list tests"
(check-expect (list* 4)
4)
(check-expect (list* 1 2 3)
(cons 1 (cons 2 3)))
(check-expect (list* 1 2 '(3))
(cons 1 (cons 2 (cons 3 empty))))
"end list tests"

12
tests/older-tests/moby-programs/local.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "local.rkt\n")
(check-expect (local [(define (f x)
(* x x))
(define (g x)
(* x x x))]
(f (g (g (f 3)))))
150094635296999121)

18
tests/older-tests/moby-programs/location.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang s-exp "../../lang/base.rkt"
(require "../../lang/location.rkt")
(require "../../lang/check-expect/check-expect.rkt")
"location.rkt"
(check-expect (location? (make-location "location.rkt" 88 7 0 37))
true)
"The following should be a location "
(make-location "location.rkt" 88 7 0 37)
"location.rkt end"
(run-tests)

71
tests/older-tests/moby-programs/math.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang s-exp "../../lang/wescheme.rkt"
"math.rkt"
(check-expect (number? pi) true)
(check-expect (number? e) true)
(check-within pi 22/7 0.1)
(check-within e 2.718 0.1)
(check-expect (=~ 3 4 1) true)
(check-expect (=~ 3 4 .9) false)
(check-expect (< 3 4) true)
(check-expect (< 4 3) false)
(check-expect (< 3 3) false)
(check-expect (> 3 4) false)
(check-expect (> 4 3) true)
(check-expect (> 4 4) false)
(check-expect (<= 3 4) true)
(check-expect (<= 4 3) false)
(check-expect (<= 3 3) true)
(check-expect (>= 3 4) false)
(check-expect (>= 4 3) true)
(check-expect (>= 4 4) true)
(check-expect (abs 3) 3)
(check-expect (abs -3) 3)
(check-expect (quotient 42 2) 21)
(check-expect (remainder 42 2) 0)
(check-expect (modulo 5 3) 2)
(check-expect (max 3 4 5) 5)
(check-expect (max 5) 5)
(check-expect (min 3 4 5) 3)
(check-expect (min 5) 5)
(check-expect (gcd 3 4) 1)
(check-expect (gcd 5 10 20) 5)
(check-expect (lcm 3 4) 12)
(check-expect (lcm 5 10 20) 20)
(check-expect (floor 3) 3)
(check-expect (ceiling 3) 3)
(check-expect (round 3) 3)
(check-expect (round 3) 3)
(check-expect (floor 3.5) 3.0)
(check-expect (ceiling 3.5) 4.0)
(check-expect (floor -3.5) -4.0)
(check-expect (ceiling -3.5) -3.0)
"math.rkt end"

1117
tests/older-tests/moby-programs/misc.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

118
tests/older-tests/moby-programs/more-jsworld.ss Normal file
View File

@ -0,0 +1,118 @@
#lang s-exp "../../lang/wescheme.rkt"
"more-jsworld.rkt"
;; Fill me in with automated tests for jsworld...
;; This file is intentionally with an '.ss' suffix
;; to see if we've also fixed an issue with module names.
;; The tests below make sure that mutable strings pose no issue
;; to the jsworld functions.
;; Thanks to William Zimrin and Tiberiu-Lucian Florea
;; for this test case.
(big-bang empty
(to-draw-page
(lambda (x)
(list (js-div '(("id" "div")))
(list (js-text (string-append "hello")))))
(lambda (x)
`((,(string-append "div") ,(list (string-append "border") (string-append "3px black solid"))))))
(stop-when (lambda (x) true)))
(local [
(define (refresh w form-val)
form-val)
(define input-node
(js-input (string-append "text") refresh '(("id" "myname"))))
(define (draw w)
(list (js-div)
(list (js-div) (list (js-text (format "I see: ~s~n" w))))
(list (js-div) (list input-node))))
(define (draw-css w)
'())]
(big-bang ""
(to-draw-page draw draw-css)
(stop-when (lambda (x) true))))
(define true-f (lambda (x) true))
(let ([draw (lambda (w)
(list (js-img (string-append
"http://racket-lang.org/logo.png"))))])
(big-bang 0
(to-draw-page draw)
(stop-when true-f)))
(local [
(define (select-house w an-option)
an-option)
(define a-select-element
(js-select (list (string-append "")
(string-append "Gryffindor")
"Hufflepuff"
"Ravenclaw"
(string-append "Slytherin"))
select-house))
(define (draw w)
(list (js-div)
(list a-select-element)
(list (js-text (format "House: ~a" w)))))
(define (draw-css w)
'())]
(big-bang ""
(to-draw-page draw draw-css)
(stop-when true-f)))
(big-bang 0
(stop-when (lambda (x) true))
(to-draw-page (lambda (x)
(list (js-div)
(list
(js-input "checkbox"
(lambda (x y) x)
'(("checked" true))));This checkbox is checked
(list
(js-input "checkbox"
(lambda (x y) x)
'(("checked" false))));This checkbox is checked
(list
(js-input "checkbox"
(lambda (x y) x)
'(("value" true))));This checkbox is not checked
(list
(js-input "checkbox"
(lambda (x y) x)
'(("value" false))))));This checkbox is not checked
(lambda (x) empty)))

10
tests/older-tests/moby-programs/permissions.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang s-exp "../../lang/base.rkt"
;; Any program that's compiled with require-permission should have
;; the permissions of the module as part of the module record.
(printf "permissions.rkt\n")
(require "../../permissions/require-permission.rkt")
(require-permission "network")

9
tests/older-tests/moby-programs/quasiquote.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "quasiquote.rkt\n")
(define name "danny")
(define roommates (list "guillaume" "isis" "andy"))
(check-expect `(my name is ,name and I lived with ,@roommates)
'(my name is "danny" and I lived with "guillaume" "isis" "andy"))

34
tests/older-tests/moby-programs/raise.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang s-exp "../../lang/wescheme.rkt"
"raise.rkt"
(check-expect
(with-handlers ([string? identity])
(raise "hello world")
42)
"hello world")
(check-expect (exn? (with-handlers ([void identity])
(raise (make-exn "foo" (current-continuation-marks)))))
true)
(check-expect (exn:fail:contract:arity? (with-handlers ([void identity])
(+ "hello" "world")))
false)
(check-expect (exn:fail:contract? (with-handlers ([void identity])
(+ "hello" "world")))
true)
(check-expect (exn:fail:contract:arity? (with-handlers ([void identity])
(identity "hello" "world")))
true)
(check-expect (exn:fail:contract:variable? (with-handlers ([void identity])
(identity "hello" "world")))
false)
"raise.rkt end"

18
tests/older-tests/moby-programs/random.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"random.rkt"
(let loop ([i 0])
(when (< i 1000)
(begin
(test-within (random 100) 50 50)
(loop (add1 i)))))
(let loop ([i 0])
(when (< i 1000)
(begin
(test-within (random) 0.5 0.5)
(loop (add1 i)))))
"random.rkt end"

13
tests/older-tests/moby-programs/recur.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang s-exp "../../lang/wescheme.rkt"
"recur.rkt"
(check-expect
(recur loop ([i 0])
(cond [(= i 10) '()]
[else
(cons (* i i)
(loop (add1 i)))]))
'(0 1 4 9 16 25 36 49 64 81))
"recur.rkt end"

24
tests/older-tests/moby-programs/repeating-decimals.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang s-exp "../../lang/wescheme.rkt"
"repeating-decimals.rkt"
1/3
3227/555
1/9
1/3
2/3
9/11
7/12
1/81
22/7
1/7
1/17
1/19
1/23
1/97
1/29
"repeating-decimals.rkt end"

34
tests/older-tests/moby-programs/require.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "required.rkt")
(require (prefix-in a-prefix: (only-in "required.rkt" f)))
(require "required-2.rkt")
(printf "require.rkt\n")
(define (blah)
'blaaargh)
(check-expect (blah) 'blaaargh)
(check-expect (f 42) (* 42 42))
(check-expect (hypo 3 4) 5)
(check-expect (h 16) (expt 16 5))
(check-expect (a-prefix:f 42) (* 42 42))
(check-expect (a-struct-x (make-a-struct 3 4 5)) 3)
(check-expect (a-struct? (make-a-struct 3 4 5)) true)
(check-expect game-name "Evolution chamber")
;; Hopefully, all-except-out will prevent a collision
;; between this binding and the one in required-5.rkt
(define clashing-value "value with a binding in required-5.rkt")
(check-expect clashing-value
"value with a binding in required-5.rkt")

15
tests/older-tests/moby-programs/required-2.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang s-exp "../../lang/base.ss"
(require "required-3.rkt")
(require "required-5.rkt")
(provide hypo
h)
(define-struct a-struct (x y z))
(provide (struct-out a-struct))
(provide (except-out (all-from-out "required-5.rkt")
clashing-value))

9
tests/older-tests/moby-programs/required-3.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang s-exp "../../lang/base.ss"
(require "required-4.rkt")
(provide (rename-out (-hypo hypo)) h)
(define (-hypo a b)
(sqrt (+ (sqr a) (sqr b))))

6
tests/older-tests/moby-programs/required-4.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang s-exp "../../lang/base.ss"
(provide (all-defined-out))
(define (h x)
(* x x x x x))

8
tests/older-tests/moby-programs/required-5.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../../lang/wescheme.rkt"
(provide (all-defined-out))
(define game-name "Evolution chamber")
(define clashing-value "don't look at me!")

8
tests/older-tests/moby-programs/required.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../../lang/base.rkt"
(provide f)
(define (f x)
(* x x))
(define h 'something-else)

27
tests/older-tests/moby-programs/rotate.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang s-exp "../../lang/wescheme.rkt"
"rotate and scale"
(printf "Three images at 30, 60, 90 degree rotation:\n")
(rotate 30 (image-url "http://racket-lang.org/logo.png"))
(rotate 60 (image-url "http://racket-lang.org/logo.png"))
(rotate 90 (image-url "http://racket-lang.org/logo.png"))
(printf "scaling small and large")
(scale 1/2 (image-url "http://racket-lang.org/logo.png"))
(scale 2 (image-url "http://racket-lang.org/logo.png"))
(scale/xy 1 2 (image-url "http://racket-lang.org/logo.png"))
(scale/xy 2 1 (image-url "http://racket-lang.org/logo.png"))
"This should be the normal image"
(scale/xy 1 1 (image-url "http://racket-lang.org/logo.png"))
"Rotated, huge image"
(rotate 30 (scale 3 (image-url "http://racket-lang.org/logo.png")))
"rotate and scale end"

3
tests/older-tests/moby-programs/run-all-tests.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket/base
(require "../../main.rkt")
(run-in-browser "all-tests.rkt")

6
tests/older-tests/moby-programs/seconds.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang s-exp "../../lang/wescheme.rkt"
(printf "current seconds: ~a\n" (current-seconds))
(printf "current-inexact-milliseconds: ~a\n"
(current-inexact-milliseconds))

128
tests/older-tests/moby-programs/setbang.rkt Normal file
View File

@ -0,0 +1,128 @@
#lang s-exp "../../lang/wescheme.ss"
(printf "setbang.rkt\n")
(define some-value 16)
(check-expect (set! some-value 42)
(void))
(define song '())
(define (bottles-of-beer)
(let ([x 100])
(define (loop)
(if (< x 1)
(void)
(begin
(set! x (sub1 x))
(set! song (cons (format "~a bottles of beer on the wall\n" x)
song))
(loop))))
(loop)))
(bottles-of-beer)
(check-expect (reverse song)
(list "99 bottles of beer on the wall\n"
"98 bottles of beer on the wall\n"
"97 bottles of beer on the wall\n"
"96 bottles of beer on the wall\n"
"95 bottles of beer on the wall\n"
"94 bottles of beer on the wall\n"
"93 bottles of beer on the wall\n"
"92 bottles of beer on the wall\n"
"91 bottles of beer on the wall\n"
"90 bottles of beer on the wall\n"
"89 bottles of beer on the wall\n"
"88 bottles of beer on the wall\n"
"87 bottles of beer on the wall\n"
"86 bottles of beer on the wall\n"
"85 bottles of beer on the wall\n"
"84 bottles of beer on the wall\n"
"83 bottles of beer on the wall\n"
"82 bottles of beer on the wall\n"
"81 bottles of beer on the wall\n"
"80 bottles of beer on the wall\n"
"79 bottles of beer on the wall\n"
"78 bottles of beer on the wall\n"
"77 bottles of beer on the wall\n"
"76 bottles of beer on the wall\n"
"75 bottles of beer on the wall\n"
"74 bottles of beer on the wall\n"
"73 bottles of beer on the wall\n"
"72 bottles of beer on the wall\n"
"71 bottles of beer on the wall\n"
"70 bottles of beer on the wall\n"
"69 bottles of beer on the wall\n"
"68 bottles of beer on the wall\n"
"67 bottles of beer on the wall\n"
"66 bottles of beer on the wall\n"
"65 bottles of beer on the wall\n"
"64 bottles of beer on the wall\n"
"63 bottles of beer on the wall\n"
"62 bottles of beer on the wall\n"
"61 bottles of beer on the wall\n"
"60 bottles of beer on the wall\n"
"59 bottles of beer on the wall\n"
"58 bottles of beer on the wall\n"
"57 bottles of beer on the wall\n"
"56 bottles of beer on the wall\n"
"55 bottles of beer on the wall\n"
"54 bottles of beer on the wall\n"
"53 bottles of beer on the wall\n"
"52 bottles of beer on the wall\n"
"51 bottles of beer on the wall\n"
"50 bottles of beer on the wall\n"
"49 bottles of beer on the wall\n"
"48 bottles of beer on the wall\n"
"47 bottles of beer on the wall\n"
"46 bottles of beer on the wall\n"
"45 bottles of beer on the wall\n"
"44 bottles of beer on the wall\n"
"43 bottles of beer on the wall\n"
"42 bottles of beer on the wall\n"
"41 bottles of beer on the wall\n"
"40 bottles of beer on the wall\n"
"39 bottles of beer on the wall\n"
"38 bottles of beer on the wall\n"
"37 bottles of beer on the wall\n"
"36 bottles of beer on the wall\n"
"35 bottles of beer on the wall\n"
"34 bottles of beer on the wall\n"
"33 bottles of beer on the wall\n"
"32 bottles of beer on the wall\n"
"31 bottles of beer on the wall\n"
"30 bottles of beer on the wall\n"
"29 bottles of beer on the wall\n"
"28 bottles of beer on the wall\n"
"27 bottles of beer on the wall\n"
"26 bottles of beer on the wall\n"
"25 bottles of beer on the wall\n"
"24 bottles of beer on the wall\n"
"23 bottles of beer on the wall\n"
"22 bottles of beer on the wall\n"
"21 bottles of beer on the wall\n"
"20 bottles of beer on the wall\n"
"19 bottles of beer on the wall\n"
"18 bottles of beer on the wall\n"
"17 bottles of beer on the wall\n"
"16 bottles of beer on the wall\n"
"15 bottles of beer on the wall\n"
"14 bottles of beer on the wall\n"
"13 bottles of beer on the wall\n"
"12 bottles of beer on the wall\n"
"11 bottles of beer on the wall\n"
"10 bottles of beer on the wall\n"
"9 bottles of beer on the wall\n"
"8 bottles of beer on the wall\n"
"7 bottles of beer on the wall\n"
"6 bottles of beer on the wall\n"
"5 bottles of beer on the wall\n"
"4 bottles of beer on the wall\n"
"3 bottles of beer on the wall\n"
"2 bottles of beer on the wall\n"
"1 bottles of beer on the wall\n"
"0 bottles of beer on the wall\n"))

3
tests/older-tests/moby-programs/sleep.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang s-exp "../../lang/wescheme.rkt"
(sleep 0)

56
tests/older-tests/moby-programs/struct.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"struct.rkt"
(let-values ([(a-struct-type
constructor
predicate
accessor
mutator)
(make-struct-type 'pair
#f
2
0)])
(test-expect (struct-type? a-struct-type) true)
(test-expect (struct-type? (constructor 3 4)) false)
(test-expect (predicate (constructor 3 4)) true)
(test-expect (predicate (cons 3 4)) false)
(test-expect (struct-constructor-procedure? constructor) true)
(test-expect (struct-constructor-procedure? (lambda (x y)
(constructor x y)))
false)
(test-expect (struct-predicate-procedure? predicate) true)
(test-expect (struct-predicate-procedure? accessor) false)
(test-expect (struct-predicate-procedure? 24) false)
(test-expect (struct-predicate-procedure? (lambda (x) true))
false)
(test-expect (struct-accessor-procedure? accessor) true)
(test-expect (struct-accessor-procedure? mutator) false)
(test-expect (struct-accessor-procedure? 24) false)
(test-expect (struct-accessor-procedure? (lambda (x) true))
false)
(test-expect (struct-mutator-procedure? mutator) true)
(test-expect (struct-mutator-procedure? accessor) false)
(test-expect (struct-mutator-procedure? 24) false)
(test-expect (struct-mutator-procedure? (lambda (x) true))
false)
(let ([f (make-struct-field-accessor accessor 0)]
[r (make-struct-field-accessor accessor 1)]
[set-f! (make-struct-field-mutator mutator 0)]
[set-r! (make-struct-field-mutator mutator 1)])
(let ([p1 (constructor 17 'foo)])
(test-expect (f p1) 17)
(test-expect (r p1) 'foo)
(set-f! p1 'something-else)
(test-expect (f p1) 'something-else)
(set-r! p1 1024)
(test-expect (r p1) '1024))))
"struct.rkt end"

22
tests/older-tests/moby-programs/values.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
"values.rkt"
(call-with-values (lambda () (values 3 4 5))
(lambda (x y z)
(test-expect x 3)
(test-expect y 4)
(test-expect z 5)))
(call-with-values (lambda () (values 3 4 5))
(lambda args
(test-expect args '(3 4 5))))
(call-with-values (lambda () (values))
(lambda ()
(void)))
"values.rkt end"

8
tests/older-tests/moby-programs/vararity.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../../lang/wescheme.rkt"
"vararity"
(define f (lambda args args))
(check-expect (f) empty)
(check-expect (f 1 2) '(1 2))
"vararity done"

36
tests/older-tests/moby-programs/vector.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang s-exp "../../lang/wescheme.rkt"
(require "../../lang/check-expect/test-expect.rkt")
(printf "vector.rkt\n")
(define v (build-vector 5 (lambda (a) a)))
(test-expect v #(0 1 2 3 4))
(test-expect (vector-length v) 5)
(test-expect (vector? v) true)
(test-expect (vector? '(not a vector)) false)
(define v2 (build-vector 5 (lambda (a) (* a a))))
(test-expect v2 #(0 1 4 9 16))
(test-expect (vector->list #()) '())
(test-expect (vector->list v2) '(0 1 4 9 16))
(test-expect (list->vector '()) #())
(test-expect (list->vector '(a b c)) #(a b c))
(define v3 (vector 'hello 'world))
(test-expect v3 '#(hello world))
(vector-set! v3 0 'hola)
(test-expect v3 '#(hola world))
(test-expect (vector-ref v3 0) 'hola)
(printf "vector.rkt end\n")

12
tests/older-tests/moby-programs/when-unless.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp "../../lang/base.ss"
(printf "when-unless.rkt\n")
(when (= (expt 2 100)
1267650600228229401496703205376)
'ok)
(unless (not (= (expt 2 100)
1/1267650600228229401496703205376))
(error 'not-ok))

35
tests/older-tests/moby-programs/with-handlers-1.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang s-exp "../../lang/base.rkt"
(printf "with-handlers-1.rkt\n")
(with-handlers ([(lambda (exn)
(printf "Is the exception a failure? ~s~n" (exn:fail? exn))
(exn:fail? exn))
(lambda (exn)
(printf "I'm in the handler and saying ok\n")
'ok)])
(/ 1 0)
(error 'not-ok))
(with-handlers ([(lambda (exn)
false)
(lambda (exn)
(printf "I'm in the handler and saying ok\n")
(error 'not-ok))]
[(lambda (exn)
(printf "second test\n")
true)
(lambda (exn)
'ok)])
(/ 1 0)
(error 'not-ok))
(with-handlers ([void (lambda (exn) (error 'not-ok))])
'ok)

23
tests/older-tests/moby-programs/with-handlers-2.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang s-exp "../../lang/base.rkt"
(printf "Testing with-handlers-2.rkt\n");
(with-handlers ([void (lambda (exn) 'ok)])
(with-handlers ([1 2])
(/ 1 0)
(error "expected an error")))
(with-handlers ([void (lambda (exn) 'ok)])
(with-handlers ([void 2])
(/ 1 0)
(error "expected an error")))
(with-handlers ([void (lambda (exn)
(printf "outer\n")
(error 'not-ok))])
(with-handlers ([void (lambda (exn)
'ok)])
(/ 1 0)
(error "expected an error")))

4
tests/older-tests/mz-tests/all-tests.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp "../../lang/base.rkt"
(require "basic.rkt"
#;"number.rkt")

2588
tests/older-tests/mz-tests/basic.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

423
tests/older-tests/mz-tests/list.rkt Normal file
View File

@ -0,0 +1,423 @@
#lang s-exp "../../lang/base.rkt"
(require "testing.rkt")
(require (for-syntax racket/base))
(test (list 1 2 3 4) foldl cons '() (list 4 3 2 1))
(test (list 1 2 3 4) foldr cons '() (list 1 2 3 4))
(test (list (list 5 6) (list 3 4) (list 1 2))
foldl (lambda (x y sofar) (cons (list x y) sofar))
'()
(list 1 3 5)
(list 2 4 6))
(test (list (list 1 2) (list 3 4) (list 5 6))
foldr (lambda (x y sofar) (cons (list x y) sofar))
'()
(list 1 3 5)
(list 2 4 6))
(arity-test foldl 3 -1)
(arity-test foldr 3 -1)
(err/rt-test (foldl 'list 0 10))
(err/rt-test (foldl list 0 10))
(err/rt-test (foldl add1 0 '()))
(err/rt-test (foldl cons 0 '() '()))
(err/rt-test (foldl list 0 '() 10))
(err/rt-test (foldl list 0 '() '() 10))
(err/rt-test (let/cc k (foldl k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/cc k (foldl k 0 '(1 2) '(1 2) '(1 2 3))))
(err/rt-test (foldr 'list 0 10))
(err/rt-test (foldr list 0 10))
(err/rt-test (foldr add1 0 '()))
(err/rt-test (foldr cons 0 '() '()))
(err/rt-test (foldr list 0 '() 10))
(err/rt-test (foldr list 0 '() '() 10))
(err/rt-test (let/cc k (foldr k 0 '(1 2) '(1 2 3))))
(err/rt-test (let/cc k (foldr k 0 '(1 2) '(1 2) '(1 2 3))))
(test '(0 1 2) memf add1 '(0 1 2))
(test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
(test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))
(err/rt-test (memf cons '((1) (2) (3))))
(err/rt-test (memf string? '((1) (2) (3) . 4)) exn:application:mismatch?)
#| dyoo: missing assf
(err/rt-test (assf add1 '(0 1 2)) exn:application:mismatch?)
(test '(0 x) assf number? '((a 1) (0 x) (1 w) (2 r) (c 17)))
(test '("ok" . 10) assf string? '((a 0) (0 a) (1 w) ("ok" . 10) (2 .7) c))
(err/rt-test (assf cons '((1) (2) (3))))
(err/rt-test (assf string? '((1) (2) (3) . 4)) exn:application:mismatch?)
|#
#| dyoo: missing last
;; ---------- last, last-pair ----------
(let ()
(test 3 last '(1 2 3))
(test '(3) last-pair '(1 2 3))
(err/rt-test (last '(1 2 3 . 4)))
(test '(3 . 4) last-pair '(1 2 3 . 4))
(err/rt-test (last '()))
(err/rt-test (last 1))
(err/rt-test (last-pair '()))
(err/rt-test (last-pair 1)))
|#
;; ---------- sort ----------
(test '("a" "b" "c" "c" "d" "e" "f")
sort
'("d" "f" "e" "c" "a" "c" "b")
string<?)
(let ()
(define (car< x y) (< (car x) (car y)))
(define (random-list n range)
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons (list (random range)) r)))))
(define (sort* lst)
(let ([s1 (sort lst car<)]
[s2 (sort lst < #:key car)]
[s3 (sort lst < #:key car #:cache-keys? #t)])
(test #t andmap eq? s1 s2)
(test #t andmap eq? s1 s3)
s1))
(define (test-sort len times)
(or (zero? times)
(and (let* ([rand (random-list len (if (even? times) 1000000 10))]
[orig< (lambda (x y) (memq y (cdr (memq x rand))))]
[sorted (sort* rand)]
[l1 (reverse (cdr (reverse sorted)))]
[l2 (cdr sorted)])
(and (= (length sorted) (length rand))
(andmap (lambda (x1 x2)
(and (not (car< x2 x1)) ; sorted?
(or (car< x1 x2) (orig< x1 x2)))) ; stable?
l1 l2)))
(test-sort len (sub1 times)))))
(test #t test-sort 1 10)
(test #t test-sort 2 20)
(test #t test-sort 3 60)
(test #t test-sort 4 100)
(test #t test-sort 5 100)
(test #t test-sort 10 100)
(test #t test-sort 100 100)
(test #t test-sort 1000 100)
;; test stability
(test '((1) (2) (3 a) (3 b) (3 c)) sort* '((3 a) (1) (3 b) (2) (3 c)))
;; test short lists (+ stable)
(test '() sort* '())
(test '((1 1)) sort* '((1 1)))
(test '((1 2) (1 1)) sort* '((1 2) (1 1)))
(test '((1) (2)) sort* '((2) (1)))
(for-each (lambda (l) (test '((0 3) (1 1) (1 2)) sort* l))
'(((1 1) (1 2) (0 3))
((1 1) (0 3) (1 2))
((0 3) (1 1) (1 2))))
(for-each (lambda (l) (test '((0 2) (0 3) (1 1)) sort* l))
'(((1 1) (0 2) (0 3))
((0 2) (1 1) (0 3))
((0 2) (0 3) (1 1))))
;; exhaustive tests for 2 and 3 item lists
(for-each (lambda (l) (test '((1 x) (2 y)) sort* l))
'(((1 x) (2 y))
((2 y) (1 x))))
(for-each (lambda (l) (test '((1 x) (2 y) (3 z)) sort* l))
'(((1 x) (2 y) (3 z))
((2 y) (1 x) (3 z))
((2 y) (3 z) (1 x))
((3 z) (2 y) (1 x))
((3 z) (1 x) (2 y))
((1 x) (3 z) (2 y)))))
;; test #:key and #:cache-keys?
(let ()
(define l '((0) (9) (1) (8) (2) (7) (3) (6) (4) (5)))
(define sorted '((0) (1) (2) (3) (4) (5) (6) (7) (8) (9)))
(test sorted sort l < #:key car)
(let ([c1 0] [c2 0] [touched '()])
(test sorted
sort l (lambda (x y) (set! c1 (add1 c1)) (< x y))
#:key (lambda (x)
(set! c2 (add1 c2))
(set! touched (cons x touched))
(car x)))
;; test that the number of key uses is half the number of comparisons
(test #t = (* 2 c1) c2)
;; and that this is larger than the number of items in the list
(test #t < (length l) c2)
;; and that every item was touched
;; dyoo: missing remove*
#;(test null remove* touched l))
(let ([c 0] [touched '()])
;; now cache the keys
(test sorted
sort l <
#:key (lambda (x)
(set! c (add1 c))
(set! touched (cons x touched))
(car x))
#:cache-keys? #t)
;; test that the number of key uses is the same as the list length
(test #t = c (length l))
;; and that every item was touched
;; dyoo: missing remove*
#;(test null remove* touched l))
(let* ([c 0] [getkey (lambda (x) (set! c (add1 c)) x)])
;; either way, we never use the key proc on no arguments
(test '() sort '() < #:key getkey #:cache-keys? #f)
(test '() sort '() < #:key getkey #:cache-keys? #t)
(test #t = c 0)
;; we also don't use it for 1-arg lists
(test '(1) sort '(1) < #:key getkey #:cache-keys? #f)
(test #t = c 0)
;; but we do use it once if caching happens (it's a consistent interface)
(test '(1) sort '(1) < #:key getkey #:cache-keys? #t)
(test #t = c 1)
;; check a few other short lists
(test '(1 2) sort '(2 1) < #:key getkey #:cache-keys? #t)
(test '(1 2 3) sort '(2 3 1) < #:key getkey #:cache-keys? #t)
(test '(1 2 3 4) sort '(4 2 3 1) < #:key getkey #:cache-keys? #t)
(test #t = c 10)))
;; ---------- make-list ----------
;; dyoo: missing make-list
#;(let ()
(test '() make-list 0 'x)
(test '(x) make-list 1 'x)
(test '(x x) make-list 2 'x)
(err/rt-test (make-list -3 'x)))
;; ---------- take/drop[-right] ----------
#|
(let ()
(define-syntax vals-list
(syntax-rules ()
[(_ expr)
(call-with-values (lambda () expr) list)]))
;; dyoo: missing split-at
(define (split-at* l n) (vals-list (split-at l n)))
(define (split-at-right* l n) (vals-list (split-at-right l n)))
(define funs (list take drop take-right drop-right
split-at* split-at-right*))
(define tests
;; -----args------ --take--- --drop--- --take-r--- --drop-r-
'([((a b c d) 2) (a b) (c d) (c d) (a b) ]
[((a b c d) 0) () (a b c d) () (a b c d)]
[((a b c d) 4) (a b c d) () (a b c d) () ]
[((a b c . d) 1) (a) (b c . d) (c . d) (a b) ]
[((a b c . d) 3) (a b c) d (a b c . d) () ]
[(99 0) () 99 99 () ]))
(for ([t tests]
#:when #t
[expect `(,@(cdr t)
,(list (list-ref t 1) (list-ref t 2))
,(list (list-ref t 4) (list-ref t 3)))]
[fun funs])
(apply test expect fun (car t)))
(for ([fun funs])
(arity-test fun 2 2)
(err/rt-test (fun 1 1) exn:application:mismatch?)
(err/rt-test (fun '(1 2 3) 2.0))
(err/rt-test (fun '(1) '(1)))
(err/rt-test (fun '(1) -1))
(err/rt-test (fun '(1) 2) exn:application:mismatch?)
(err/rt-test (fun '(1 2 . 3) 3) exn:application:mismatch?)))
|#
;; dyoo: missing append*
#|
;; ---------- append* ----------
(let ()
(test '() append* '())
(test '() append* '(()))
(test '() append* '(() ()))
(test '(0 1 2 3) append* '((0 1 2 3)))
(test '(0 1 2 3) append* '(0 1 2 3) '())
(test '(0 1 2 3) append* '(0 1 2 3) '(()))
(test '(0 1 2 3) append* '(0 1 2 3) '(() ()))
(test '(0 1 2 3) append* '(0 1) '((2) (3)))
(test '(0 1 0 2 0 3) append* (map (lambda (x) (list 0 x)) '(1 2 3)))
(test '(1 2 3 4 5 6 7 8 9) append* '(1 2 3) '(4 5) '((6 7 8) (9))))
|#
;; ---------- flatten ----------
;; dyoo: missing for*/list
#|
(let ()
(define (all-sexps n)
(if (zero? n)
'(x ())
(let ([r (all-sexps (sub1 n))])
(append r (for*/list ([x r] [y r]) (cons x y))))))
(define sexps (all-sexps 3)) ; can use 4 on fast machines
(define (flat? x) (and (list? x) (andmap (lambda (x) (eq? 'x x)) x)))
(for ([x sexps]) (test #t flat? (flatten x))))
|#
;; ---------- add-between ----------
;; dyoo: missing add-between
#|
(let ()
(test '() add-between '() 1)
(test '(9) add-between '(9) 1)
(test '(9 1 8 1 7) add-between '(9 8 7) 1)
(test '(9 (1) 8) add-between '(9 8) '(1)))
|#
;; ---------- remove-duplicates ----------
#| dyoo: missing remove-duplicates
(let ()
(define rd remove-duplicates)
;; basic 'naive tests
(test '() rd '())
(test '(a) rd '(a a a a))
(test '(a b) rd '(a b))
(test '(a b) rd '(a b a b a b))
(test '(a b) rd '(a a a b b b))
(test '(a b) rd '(a b b a)) ; keeps first occurrences
(test '("a" "b") rd '("a" "A" "b" "B" "a") #:key string-downcase)
(let ([long (for/list ([i (in-range 300)]) i)])
(test long rd long)
(test long rd (append long long))
(test long rd (append long (reverse long))) ; keeps first
(test long rd (append* (map (lambda (x) (list x x)) long)))
(test long rd (append long (map (lambda (x) (- x)) long)) #:key abs)
(test long rd (append long (map (lambda (x) (- x)) long)) = #:key abs)))
|#
#|
;; dyoo: missing filter-not
;; ---------- filter and filter-not ----------
(let ()
(define f filter)
(define fn filter-not)
(test '() f number? '())
(test '() fn number? '())
(test '(1 2 3) f number? '(1 a 2 b 3 c d))
(test '(a b c d) fn number? '(1 a 2 b 3 c d))
(test '() f string? '(1 a 2 b 3 c d))
(test '(1 a 2 b 3 c d) fn string? '(1 a 2 b 3 c d))
(err/rt-test (f string? '(1 2 3 . 4)) exn:application:mismatch?)
(err/rt-test (fn string? '(1 2 3 . 4)) exn:application:mismatch?)
(err/rt-test (f 2 '(1 2 3)))
(err/rt-test (fn 2 '(1 2 3)))
(err/rt-test (f cons '(1 2 3)))
(err/rt-test (fn cons '(1 2 3)))
(arity-test f 2 2)
(arity-test fn 2 2))
|#
#| dyoo: missin gpartition
;; ---------- partition ----------
(let ()
(define (p pred l) (call-with-values (lambda () (partition pred l)) list))
(test '(() ()) p (lambda (_) #t) '())
(test '(() ()) p (lambda (_) #f) '())
(test '((1 2 3 4) ()) p (lambda (_) #t) '(1 2 3 4))
(test '(() (1 2 3 4)) p (lambda (_) #f) '(1 2 3 4))
(test '((2 4) (1 3)) p even? '(1 2 3 4))
(test '((1 3) (2 4)) p odd? '(1 2 3 4)))
|#
#| dyoo: missing filter-map
;; ---------- filter-map ----------
(let ()
(define fm filter-map)
(test '() fm values '())
(test '(1 2 3) fm values '(1 2 3))
(test '() fm values '(#f #f #f))
(test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f))
(test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6)))
|#
#| dyoo: missing count
;; ---------- count ----------
(let ()
(test 0 count even? '())
(test 4 count even? '(0 2 4 6))
(test 0 count even? '(1 3 5 7))
(test 2 count even? '(1 2 3 4))
(test 2 count < '(1 2 3 4) '(4 3 2 1)))
|#
#| dyoo: missing append-map
;; ---------- append-map ----------
(let ()
(define am append-map)
(test '() am list '())
(test '(1 2 3) am list '(1 2 3))
(test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3)))
|#
#| dyoo: missing regexps
;; ---------- argmin & argmax ----------
(let ()
(define ((check-regs . regexps) exn)
(and (exn:fail? exn)
(andmap (λ (reg) (regexp-match reg (exn-message exn)))
regexps)))
(test 'argmin object-name argmin)
(test 1 argmin (lambda (x) 0) (list 1))
(test 1 argmin (lambda (x) x) (list 1 2 3))
(test 1 argmin (lambda (x) 1) (list 1 2 3))
(test 3
'argmin-makes-right-number-of-calls
(let ([c 0])
(argmin (lambda (x) (set! c (+ c 1)) 0)
(list 1 2 3))
c))
(test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure"))
(err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list"))
(err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
(err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list"))
(test 'argmax object-name argmax)
(test 1 argmax (lambda (x) 0) (list 1))
(test 3 argmax (lambda (x) x) (list 1 2 3))
(test 1 argmax (lambda (x) 1) (list 1 2 3))
(test 3
'argmax-makes-right-number-of-calls
(let ([c 0])
(argmax (lambda (x) (set! c (+ c 1)) 0)
(list 1 2 3))
c))
(test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples)))
(err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure"))
(err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list"))
(err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
(err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list")))
|#
;; ---------- check no collisions with srfi/1 ----------
#;(test (void)
eval '(module foo scheme/base (require scheme/base srfi/1/list))
(make-base-namespace))
(report-errs)
"list.rkt end"

35
tests/older-tests/mz-tests/missing-features.txt Normal file
View File

@ -0,0 +1,35 @@
mcons, mcar, mcdr, set-mcar!, set-mcdr!
make-weak-box, weak-box-value, weak-box?
hash-eq? hash-count
make-immutable-hasheq, make-immutable-hash
make-hasheqv
make-weak-hasheq, make-weak-hash, make-weak-hasheqv
parameterize
read-case-sensitive
keywords: keyword? string->keyword keyword->string
eq-hash-code
string-copy!
exn:fail:out-of-memory?
regular expressions: regexp-match, regexp-match-positions, ...
call-with-escape-continuation, dynamic-wind, let/ec, call/ec
call-with-exception-handler, uncaught-exception-handler
normalize-arity
read
make-placeholder
version, banner, system-type, current-command-line-arguments, system-library-subpath, current-output-port
eval, eval-jit-enabled

2749
tests/older-tests/mz-tests/number.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

220
tests/older-tests/mz-tests/numstrs.rkt Normal file
View File

@ -0,0 +1,220 @@
#lang s-exp "../../lang/base.rkt"
(provide (all-defined-out))
;; #f means a symbol
;; X means fails (syntax forces it to be a number)
;; DBZ means fails because divide-by-zero
;; NOE means fails because no such exact
(define number-table
`((,(+ 1/2 +i) "1/2+i")
(100 "100")
(100 "#d100")
(0.1 ".1")
(0.1 "#d.1")
(1/20000 "#e1/2e-4")
(10.0 "1e1")
(10.0 "1E1")
(10.0 "1s1")
(10.0 "1S1")
(10.0 "1f1")
(10.0 "1F1")
(10.0 "1l1")
(10.0 "1L1")
(10.0 "1d1")
(10.0 "1D1")
(0.0 "0e13")
(0.0 "#i0")
(-0.0 "#i-0")
(+inf.0 ".3e2666666666")
(+inf.0 "+INF.0")
(+nan.0 "+NaN.0")
(+inf.0 "1e500") ; Check simple overflows
(-inf.0 "-1e500")
(0.0 "1e-500")
(-0.0 "-1e-500")
(+inf.0 "1#e500")
(-inf.0 "-1#e500")
(0.0 "1#e-500")
(-0.0 "-1#e-500")
(+inf.0 "1e10000000000000000000000000000000") ; Check avoidance of extreme computations
(-inf.0 "-1e10000000000000000000000000000000")
(+inf.0 "1#e10000000000000000000000000000000")
(-inf.0 "-1#e10000000000000000000000000000000")
(+0.0 "1e-10000000000000000000000000000000")
(-0.0 "-1e-10000000000000000000000000000000")
(+0.0 "1#e-10000000000000000000000000000000")
(-0.0 "-1#e-10000000000000000000000000000000")
(10.0 "1#")
(10.0 "1#e0")
(10.0 "1####e-3")
(10.0 "1#.e0")
(10.0 "10.#e0")
(10.0 "10.e0")
(10.0 "1#.e0")
(10.0 "10.0#e0")
(10.0 "1#.##e0")
(10 "#e1#")
(10 "#e1#e0")
(10 "#e1#.e0")
(5e-5 "1/2e-4")
(5e-5 "#i1/2e-4")
(0.5 "#i1/2")
(1/2 "#e1/2")
(0.5 "#i0.5")
(1/2 "#e0.5")
(1/20 "#e0.5e-1")
(1/20 "#e0.005e1")
(1.0+0.5i "1+0.5i")
(1/2 "1/2@0")
(-1/2 "-1/2@0")
(1/2 "1/2@-0")
(0 "#o#e0")
(8 "#o#e10")
(0 "#b#e0")
(0.0 "#b#i0")
(4.0 "#b1e10")
(4 "#b#e1e10")
(1/10+1/5i "#e0.1+0.2i")
(0.0+80.0i "#i+8#i")
(521976 "#x7f6f8")
(1+8i "#b#e1+1#e10i")
(1.125 "#x1.2")
(1.1640625 "#x1.2a")
(1.1640625 "#x1.2a####")
(10.0 "#xa.")
(10.25 "#xa.4")
(160.0 "#xa#.")
(416.0 "#x1a#.")
(2816.0 "#xb##.##")
(4e62 "#i4000000000000000000000000000000000000000000000000000000000000e2")
(-0.0 "#b-0.0")
(X "#b1000000000020e1")
(#f "1.0/3")
(#f "1/3.0")
(#i10/3 "1#/3")
(#i1/300 "1/3##")
(#f "1#/#3")
(#i10/3 "#d1#/3")
(X "#d1#/#3")
(+inf.0 "1/0#")
(-inf.0 "-1/0#")
(NOE "#e+inf.0")
(NOE "#e-inf.0")
(NOE "#e+nan.0")
(NOE "#e1/0#")
(500.0 "1/2#e4")
(5000.0 "1#/2#e4")
(500000000.0 "1/2#e10")
(500000000 "#e1/2#e10")
(16140901064495857664-50176i "#e#x+e#s+e@-e#l-e")
(#f "d")
(D "D")
(#f "i")
(I "I")
(#f "3i")
(3I "3I")
(#f "33i")
(33I "33I")
(#f "3.3i")
(3.3I "3.3I")
(#f "e")
(#f "e1")
(#f "e1")
(#f "-")
(#f "+")
(X "#e-")
(X "#e+")
(X "#i-")
(X "#i+")
(#f "+.")
(X "#e+.")
(#f "/")
(#f "+1+1")
(#f "+1/+1")
(#f "1//2")
(#f "mod//")
(#f "-1.0/2")
(#f "/2")
(#f "2..")
(#f ".2.")
(X "#e2..")
(X "#e.2.")
(#f "1#.0e4")
(#f "1#0e4")
(#f "1#0.e4")
(#f "1##.##0e4")
(#f "2i")
(#f "/2i")
(#f "2@2i")
(#f "2@@2")
(#f "-2@-+2")
(#f "1/1-e4")
(#f "1.-2")
(#f "--1")
(#f "-+1")
(#f "-1+3-4")
(#f "1\0002")
(X "#xg")
(X "#x")
(X "#xa#a")
(X "#i#j0")
(X "#x12.a#b")
(X "#e1.-2")
(X "#b#b0")
(X "#b#o0")
(X "#i#i0")
(X "#e#e0")
(X "#i8#i")
(X "#i4@#i5")
(X "#i4+#d6i")
(X "#i4+#d6")
(#f "4ef5")
(X "#e4ef5")
(X "#d1e")
(X "#b1e")
(X "#o1e")
(DBZ "1/0")
(DBZ "5+1/0i")
(DBZ "1/0+5i")
(DBZ "5@1/0")
(DBZ "1/0@5")
(DBZ "1/0e2")
(#f "1/0+hi")
(#f "x+1/0i")
(+nan.0+1i "+nan.0+1i")
(1+nan.0i "1+nan.0i")
(#f "1++nan.0i")
(0.5+nan.0i "1/2+nan.0i")
(1+inf.0i "1+inf.0i")
(1-inf.0i "1-inf.0i")
(+inf.0i "+inf.0i")
(-inf.0i "-inf.0i")
(+nan.0i "+nan.0i")
(-nan.0i "-nan.0i")
(+inf.0i "+INF.0i")
(-inf.0-nan.0i "-inf.0-nan.0i")
(#f "1++inf.0i")
(+nan.0@1 "+nan.0@1")
(+inf.0@1 "+inf.0@1")
(#f "+inf.0@1@1")
(1@+inf.0 "1@+inf.0")
(1@+inf.0 "1/1@+inf.0")
(+inf.0@1 "+inf.0@1/1")
(1.0+0.0i "1@0000.0")
(1.0 "0001.0@0")
(#f "+inf.0@3@0")
(#f "+inf.0@3+4i")
(#f "+ina.0")
(#f "1@3+4i")
(#f "@2")
(#f "+a@2")
(DBZ "1/0+inf.0i")
(DBZ "+inf.0+1/0i")
(DBZ "1/0@+inf.0")
(DBZ "+inf.0@1/0")
(#f "1e1/0")
(#f "011111122222222223333333333444444x")))

3
tests/older-tests/mz-tests/run-all-tests.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket/base
(require "../../main.rkt")
(run-in-browser "all-tests.rkt")

188
tests/older-tests/mz-tests/test-files-notes.txt Normal file
View File

@ -0,0 +1,188 @@
Looks easy to convert
---------------------
ztest.rktl looks good
vector.rktl
shared.rktl
shared-tests.rktl
oe.rktl
numstrs.rktl
number.rktl
nch.rktl
math.rktl
ltest.rktl
loop.rktl
list.rktl
ktest.rktl
fact.rktl
binc.rktl
Looks moderately hard
-------------------------------------------
basic.rktl
syntax.rktl
structlib.rktl
struct.rktl
string.rktl
string-mzlib.rktl
prompt.rktl
prompt-tests.rktl
procs.rktl
print.rktl
mpair.rktl
intm-adv.rktl
htdp.rktl
htdp-test.rktl
deep.rktl
control.rktl
contmark.rktl
censor.rktl
advanced.rktl
Looks difficult to convert, or inapplicable
-------------------------------------------
zo-marshal.rktl
will.rktl
version.rktl
unsafe.rktl
unitsig.rktl
unit.rktl
udp.rktl
trait.rktl
trace.rktl
thrport.rktl
threadlib.rktl
thread.rktl
tcp.rktl
sync.rktl
subprocess.rktl
stx.rktl
unicode.rktl
uni-norm.rktl
unic3.rktl
unic2.rktl
unic.rktl
stream.rktl
srfi.rktl
set.rktl
serialize.rktl
sandbox.rktl
rx.rktl
runflats.rktl
restart.rktl
readtable.rktl
read.rktl
quiet.rktl
pretty.rtkl
portlib.rktl
port.rktl
place-channel.rktl
pconvert.rktl
pathlib.rktl
path.rktl
param.rktl
parallel.rtkl
package.rktl
package-gen.rktl
pack.rktl
optimize.rktl
openssl.rktl
object.rktl
object-old.rktl
net.rktl
namespac.rktl
name.rktl
mzq.rktl
mzlib-tests.rktl
mz-tests.rktl
module.rktl
module-reader.rktl
modprot.rktl
moddep.rktl
makeflats.rktl
makeflat.rktl
macrolib.rktl
macro.rktl
logger.rktl
loadtest.rktl
loadable.rktl
kw.rktl
intmlam-adv.rktl
intm-intml.rktl
intermediate.rktl
intermediate-lambda.rktl
imap.rktl
id-table-test.rktl
htdp-image.rktl
head.rktl
function.rktl
foreign-test.rktl
for.rktl
fixnum.rktl
filelib.rktl
file.rktl
expand.rktl
etc.rktl
embed.rktl
embed-me4.rktl
embed-in-c.rktl
dict.rktl
date.rktl
contract-test.rktl
contract-mzlib-test.rktl
compile.rktl
compat.rktl
cmdline.rktl
cm.rktl
chez-module.rktl
char-set.rktl
chaperones.rktl
cache-image-snip-test.rktl
boundmap-test.rktl
beginner.rktl
beginner-abbr.rktl
bega-adv.rktl
beg-intml.rktl
beg-intm.rktl
beg-bega.rktl
beg-adv.rktl
awk.rktl
async-channel.rktl
all.rktl

193
tests/older-tests/mz-tests/testing.rkt Normal file
View File

@ -0,0 +1,193 @@
#lang s-exp "../../lang/base.rkt"
(provide test test-values Section record-error arity-test err/rt-test disable
exn:application:mismatch? exn:application:type? exn:application:arity?
report-errs type? arity?)
(require (for-syntax racket/base))
(define number-of-tests 0)
(define number-of-error-tests 0)
(define Section-prefix "")
(define cur-section '())
(define errs '())
(define (record-error e)
(set! errs (cons (list cur-section e) errs)))
(define (Section . args)
(let ()
(printf "~aSection~s\n" Section-prefix args)
#;(flush-output p))
(set! cur-section args)
#t)
(define (report-errs)
(printf "\n\nran ~s normal tests, and ~s error-trapping tests\n"
number-of-tests number-of-error-tests)
(printf "\n\n~a errors during the run:\n" (length errs))
(for-each (lambda (err) (printf "~s\n\n" err)) errs))
(define test
(let ()
(define (test* expect fun args kws kvs)
(set! number-of-tests (add1 number-of-tests))
(printf "~s ==> " (cons fun args))
#;(flush-output)
(let ([res (if (procedure? fun)
(if kws
(error 'test "keywords not supported yet")
(apply fun args))
(car args))])
(printf "~s\n" res)
(let ([ok? (equal? expect res)])
(unless ok?
(record-error (list res expect (cons fun args)))
(printf " BUT EXPECTED ~s\n" expect))
ok?)))
#;(define (test/kw kws kvs expect fun . args) (test* expect fun args kws kvs))
(define (test expect fun . args) (test* expect fun args #f #f))
test
#;(make-keyword-procedure test/kw test)))
(define (test-values l thunk)
(test l call-with-values thunk list))
(define exn:application:mismatch? exn:fail:contract?)
(define exn:application:type? exn:fail:contract?)
(define exn:application:arity? exn:fail:contract:arity?)
(define type? exn:application:type?)
(define arity? exn:application:arity?)
(define arity-test
(case-lambda
[(f min max except)
#;(void)
(letrec ([aok?
(lambda (a)
(cond
[(integer? a) (= a min max)]
[(arity-at-least? a) (and (negative? max)
(= (arity-at-least-value a) min))]
[(and (list? a) (andmap integer? a))
(and (= min (car a)) (= max
(let loop ([l a])
(if (null? (cdr l))
(car l)
(loop (cdr l))))))]
[(list? a)
;; Just check that all are consistent for now.
;; This should be improved.
(andmap
(lambda (a)
(if (number? a)
(<= min a (if (negative? max) a max))
(>= (arity-at-least-value a) min)))
a)]
[else #f]))]
[make-ok?
(lambda (v)
(lambda (e)
(exn:application:arity? e)))]
[do-test
(lambda (f args check?)
(set! number-of-error-tests (add1 number-of-error-tests))
(printf "(apply ~s '~s) =e=> " f args)
(let/cc done
(let ([v (with-handlers ([void
(lambda (exn)
(if (check? exn)
(printf " ~a\n" (if (exn? exn)
(exn-message exn)
(format "uncaught ~x" exn)))
(let ([ok-type? (exn:application:arity? exn)])
(printf " WRONG EXN ~a: ~s\n"
(if ok-type?
"FIELD"
"TYPE")
exn)
(record-error (list exn
(if ok-type?
'exn-field
'exn-type)
(cons f args)))))
(done (void)))])
(apply f args))])
(printf "~s\n BUT EXPECTED ERROR\n" v)
(record-error (list v 'Error (cons f args))))))])
(let loop ([n 0][l '()])
(unless (>= n min)
(unless (memq n except)
(do-test f l (make-ok? n)))
(loop (add1 n) (cons 1 l))))
(let loop ([n min])
(unless (memq n except)
(test #t procedure-arity-includes? f n))
(unless (>= n max)
(loop (add1 n))))
(if (>= max 0)
(do-test f (let loop ([n 0][l '(1)])
(if (= n max)
l
(loop (add1 n) (cons 1 l))))
(make-ok? (add1 max)))
(test #t procedure-arity-includes? f 1267650600228229401496703205376 #;(arithmetic-shift 1 100))))]
[(f min max) (arity-test f min max null)]))
;; err/rt-test currently a stub that doesn't do anything.
#;(define-syntax err/rt-test
(lambda (stx)
(syntax-case stx ()
[(_ e exn?)
(syntax
(thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))]
[(_ e)
(syntax
(err/rt-test e exn:application:type?))])))
(define-syntax (err/rt-test stx)
(syntax-case stx ()
[(_ e exn?)
(with-syntax ([stx-datum (syntax->datum #'e)])
(syntax/loc stx
(err/rt-test-helper (lambda () e) exn? (quote stx-datum))))]
[(_ e)
(syntax/loc stx
(err/rt-test e exn:application:type?))]))
(define (err/rt-test-helper thunk exn? datum)
(set! number-of-error-tests (add1 number-of-tests))
(with-handlers ([exn? (lambda (exn) (void))])
(thunk)
(record-error (list 'Error datum)))
#;(printf "took ~s milliseconds\n" (- (current-inexact-milliseconds) start-time)))
(define-syntax (disable stx)
(syntax-case stx ()
[(_ e ...)
(syntax/loc stx
(void))]))

4
tests/older-tests/require-test/m.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp "../../lang/base.rkt"
(require "m2.rkt"
"m3.rkt")

1
tests/older-tests/require-test/m1.rkt Normal file
View File

@ -0,0 +1 @@
#lang s-exp "../../lang/base.rkt"

2
tests/older-tests/require-test/m2.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang s-exp "../../lang/base.rkt"
(require "m1.rkt")

2
tests/older-tests/require-test/m3.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang s-exp "../../lang/base.rkt"
(require "m1.rkt")

40
tests/older-tests/require-test/test.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
;; check to see that multiple invokations don't duplicate code generation.
(require "../../private/compile-moby-module.rkt"
"../../private/module-record.rkt"
racket/runtime-path)
(define-runtime-path m.rkt
"m.rkt"
#;"/home/dyoo/Downloads/tmp/Package/tourguide.rkt")
(define (check-module-names-unique! module-records)
(let ([names (map module-record-name module-records)])
(unless (unique? names)
(error 'check-module-names-unique!
"modules with non-unique names: ~s" names))))
(define (unique? names)
(let ([ht (make-hash)])
(let/ec return
(for ([n names])
(cond [(hash-ref ht n #f)
(return #f)]
[else
(hash-set! ht n #t)])
(return #t)))))
(define (test)
(define modules
(compile-moby-modules m.rkt))
(check-module-names-unique! modules))
(test)

25
tests/older-tests/run-all-tests.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require racket/list
"../main.rkt"
racket/runtime-path
racket/system
"check-coverage.rkt")
(define-runtime-path my-directory ".")
(when (find-executable-path "node")
(printf "Running the VM internal test suite\n")
(parameterize ([current-directory my-directory])
(system "unit-tests/run-tests")
(printf "Press Enter to continue.\n")
(void (read-line))))
(printf "Checking for untouched wescheme primitives\n")
(unless (empty? (untouched-wescheme-primitives))
(print-coverage-report)
(printf "Press Enter to continue.\n")
(void (read-line)))
(printf "Running browser tests\n")
(run-in-browser "all-tests.rkt")

6
tests/older-tests/unit-tests/browser/build-tests Executable file
View File

@ -0,0 +1,6 @@
#!/bin/bash
cd `dirname $0`
../../../lib/build-test browser run-tests.js
cat ../tests.js >> run-tests.js

20
tests/older-tests/unit-tests/browser/webTest.html Normal file
View File

@ -0,0 +1,20 @@
<html>
<head>
<title>MzScheme VM Tests</title>
</head>
<body>
<h2>MzScheme VM Tests</h2>
<script type="text/javascript" src="run-tests.js"></script>
<!--
<div id="printDiv">This is some test text<br /></div>
<script type="text/javascript">
document.write("This text was added!<br />");
document.write("This text was added!<br />");
var txt = document.createTextNode(" This text was added to the DIV.\r\n");
document.getElementByName('printDiv').appendChild(text);
</script>
-->
</body>
</html>

36
tests/older-tests/unit-tests/run-tests Executable file
View File

@ -0,0 +1,36 @@
#!/bin/bash
cd `dirname $0`
if [ -z $1 ] || [ $1 == 'unit' ]
then
srcFile='tests.js'
target='exec-tests.js'
else if [ $1 == 'struct' ]
then
srcFile='struct-tests.js'
target='exec-struct-tests.js'
else
echo $1 'is not a valid type of test'
exit
fi
fi
#if [ -f $target ]
# then
# echo "File exec-tests.js already exists."
# echo "Please remove" $target "or use a different file."
# exit
#fi
rm -f $target
echo 'Building support files'
echo
../../private/lib/build-test node $target
echo
#cat imports.js >> $target
cat $srcFile >> $target
node $target
#rm -f $target

84
tests/older-tests/unit-tests/struct-tests.js Normal file
View File

@ -0,0 +1,84 @@
var parent = types.makeStructureType('parent', false, 1, 0, false, function(args, name, k) { return k(args); });
var child1 = types.makeStructureType('child1', parent, 1, 1, 'auto1',
function(args, name, k) { return k([args[0]+'-g1a', args[1]+'-g1b']); });
var child2 = types.makeStructureType('child2', parent, 2, 1, 'auto2', false);
var subchild1 = types.makeStructureType('subchild1', child1, 0, 0, false,
function(args, name, k) { return k([args[0]+'-g2a', args[1]+'-g2b']); });
// function(arg1, arg2, name) { return new types.ValuesWrapper([arg1+'-g2a', arg2+'-g2b']); });
var subchild2 = types.makeStructureType('subchild2', child2, 2, 2, 'auto2b', false);
// Constructors
var parentInstance = parent.constructor('a');
var child1Instance = child1.constructor('b', '1');
var child2Instance = child2.constructor('c', '2', '3');
var subchild1Instance = subchild1.constructor('d', '4');
var subchild2Instance = subchild2.constructor('e', '5', '6', 7, 8);
sys.print(sys.inspect(parentInstance) + '\n');
sys.print(sys.inspect(child1Instance) + '\n');
sys.print(sys.inspect(child2Instance) + '\n');
sys.print(sys.inspect(subchild1Instance) + '\n');
sys.print(sys.inspect(subchild2Instance) + '\n');
// Predicates
assert.ok( parent.predicate(parentInstance) );
assert.ok( parent.predicate(child1Instance) );
assert.ok( parent.predicate(child2Instance) );
assert.ok( parent.predicate(subchild1Instance) );
assert.ok( parent.predicate(subchild2Instance) );
assert.ok( !child1.predicate(parentInstance) );
assert.ok( child1.predicate(child1Instance) );
assert.ok( !child1.predicate(child2Instance) );
assert.ok( child1.predicate(subchild1Instance) );
assert.ok( !child1.predicate(subchild2Instance) );
assert.ok( !child2.predicate(parentInstance) );
assert.ok( !child2.predicate(child1Instance) );
assert.ok( child2.predicate(child2Instance) );
assert.ok( !child2.predicate(subchild1Instance) );
assert.ok( child2.predicate(subchild2Instance) );
assert.ok( !subchild1.predicate(parentInstance) );
assert.ok( !subchild1.predicate(child1Instance) );
assert.ok( !subchild1.predicate(child2Instance) );
assert.ok( subchild1.predicate(subchild1Instance) );
assert.ok( !subchild1.predicate(subchild2Instance) );
assert.ok( !subchild2.predicate(parentInstance) );
assert.ok( !subchild2.predicate(child1Instance) );
assert.ok( !subchild2.predicate(child2Instance) );
assert.ok( !subchild2.predicate(subchild1Instance) );
assert.ok( subchild2.predicate(subchild2Instance) );
// Accessors
assert.deepEqual(parent.accessor(parentInstance, 0), 'a');
assert.deepEqual(parent.accessor(child1Instance, 0), 'b-g1a');
assert.deepEqual(parent.accessor(child2Instance, 0), 'c');
assert.deepEqual(parent.accessor(subchild1Instance, 0), 'd-g2a-g1a');
assert.deepEqual(parent.accessor(subchild2Instance, 0), 'e');
assert.deepEqual(child1.accessor(child1Instance, 0), '1-g1b');
assert.deepEqual(child1.accessor(child1Instance, 1), 'auto1');
assert.deepEqual(child1.accessor(subchild1Instance, 0), '4-g2b-g1b');
assert.deepEqual(child1.accessor(subchild1Instance, 1), 'auto1');
assert.deepEqual(child2.accessor(child2Instance, 0), '2');
assert.deepEqual(child2.accessor(child2Instance, 1), '3');
assert.deepEqual(child2.accessor(child2Instance, 2), 'auto2');
assert.deepEqual(child2.accessor(subchild2Instance, 0), '5');
assert.deepEqual(child2.accessor(subchild2Instance, 1), '6');
assert.deepEqual(child2.accessor(subchild2Instance, 2), 'auto2');
assert.deepEqual(subchild2.accessor(subchild2Instance, 0), 7);
assert.deepEqual(subchild2.accessor(subchild2Instance, 1), 8);
assert.deepEqual(subchild2.accessor(subchild2Instance, 2), 'auto2b');
assert.deepEqual(subchild2.accessor(subchild2Instance, 3), 'auto2b');
sys.print('All tests passed!!\n');

3462
tests/older-tests/unit-tests/tests.js Normal file
View File

File diff suppressed because it is too large Load Diff