--- /dev/null
+Compiler tests
+
+This directory contains rudimentary test programs for developing the
+compiler or a compiler back end. Each one exercises some edge case,
+invokes only primitives or procedures that USUAL-INTEGRATIONS assumes
+to be defined to be primitives, and is therefore fit to run as a cold
+load with `scheme --fasl foo.com'.
+
+Except for empty.scm, datum.scm, declempty.scm, and decldatum.scm,
+these all print no output and return an exit status of 0 on success;
+the exceptions don't have any code in them and so don't call exit and
+so the microcode prints the return value.
+
+The script tests.sf sets up some macros for use by the tests:
+
+- (ucode-primitive <name>) expands to the microcode primitive <name>
+
+- (identity <x>) expands to an expression evaluating to <x> without
+ letting the compiler assume anything about <x>.
+
+ Currently, it creates a one-element vector with vector-cons holding x
+ and returns the first element with vector-ref; this will have to
+ change if we ever teach the compiler about vector-cons.
+
+- (prelude) expands to a definition of define-multiple, as used in code
+ generated by the compiler for multiple top-level definitions.
+
+Usage:
+
+1. Compile the tests.
+ % scheme --load tests.sf --load tests.cbf
+
+2. Run the tests.
+ % for t in *.com; do scheme --fasl $t || echo $t failed; done
--- /dev/null
+; Test of creating a closure before GC and then using it after.
+
+(declare (usual-integrations))
+
+(let ((x (let ((y 5)) (identity (lambda () y)))))
+ ((ucode-primitive garbage-collect 1) #x1000)
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (x) 5)))
--- /dev/null
+; Trivial test to confirm closures work.
+
+(declare (usual-integrations))
+
+(let ((x (let ((y 5)) (identity (lambda () y)))))
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (x) 5)))
--- /dev/null
+; Pathological case: file contains only a datum.
+
+0
--- /dev/null
+; Pathological case: file contains only a declaration and a datum.
+
+(declare (usual-integrations))
+
+0
--- /dev/null
+; Pathological case: empty file except for declarations.
+
+(declare (usual-integrations))
--- /dev/null
+; Test for INVOCATION-PREFIX:DYNAMIC-LINK with a small frame.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (filter-map-if p f l)
+ (let loop ((l l))
+ (if (pair? l)
+ (let ((x (car l)))
+ (if (p x)
+ (let ((y (f x)))
+ (if y
+ (cons y (loop (cdr l)))
+ (loop (cdr l))))
+ (loop (cdr l))))
+ '())))
+ (let ((result
+ ((identity filter-map-if)
+ (lambda (x)
+ (fix:zero? (fix:remainder x 2)))
+ (lambda (x)
+ (and (fix:zero? (fix:remainder x 3))
+ (fix:quotient x 6)))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))))
+ ((ucode-primitive exit-with-value 1)
+ (fix:or (fix:- (car result) 1)
+ (fix:- (car (cdr result)) 2)))))
--- /dev/null
+; Test for INVOCATION-PREFIX:DYNAMIC-LINK with a large frame.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (filter-map-if p f l on-tail)
+ (let loop
+ ((l l) (a 0) (b 1) (c 2) (u 3) (v 4) (w 5) (n 6))
+ (if (pair? l)
+ (let ((x (car l)))
+ (if (p x)
+ (let ((y (f x)))
+ (if y
+ (cons y (loop (cdr l) b c u v w n a))
+ (loop (cdr l) b c u v w n a)))
+ (loop (cdr l) b c u v w n a)))
+ (on-tail '() a b c u v w n))))
+ (let ((result
+ ((identity filter-map-if)
+ (lambda (x)
+ (fix:zero? (fix:remainder x 2)))
+ (lambda (x)
+ (and (fix:zero? (fix:remainder x 3))
+ (fix:quotient x 6)))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+ (lambda (tail a b c u v w n)
+ a b c u v w n
+ tail))))
+ ((ucode-primitive exit-with-value 1)
+ (fix:or (fix:- (car result) 1)
+ (fix:- (car (cdr result)) 2)))))
--- /dev/null
+; Test for dynamic links.
+;
+; The LOOP procedure doesn't statically know whether it has to pop L
+; off the stack, or only L1, when it returns, so it uses a dynamic
+; link, a pointer to the caller's stack frame.
+
+(declare (usual-integrations))
+
+(let ()
+ (declare (no-type-checks))
+ (define (list-copy l)
+ (let loop ((l1 l))
+ (if (pair? l1)
+ (cons (car l1) (loop (cdr l1)))
+ '())))
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (car ((identity list-copy) '(42 123 456 789)))
+ 42)))
--- /dev/null
+; Test for static and dynamic links.
+;
+; The LOOP procedure doesn't statically know whether it has to pop F
+; and L off the stack, or only L1, when it returns, so it uses a
+; dynamic link -- a pointer to the parent stack frame. It also doesn't
+; know where F was on the stack originally, so it passes around a
+; static link to its own stack environment to get at F.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (map f l)
+ (let loop ((l1 l))
+ (if (pair? l1)
+ (cons (f (car l1)) (loop (cdr l1)))
+ '())))
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (car ((identity map) (lambda (x) x) '(42 123 456 789)))
+ 42)))
--- /dev/null
+; Pathological case: empty file.
--- /dev/null
+; Run the garbage collector once.
+
+(declare (usual-integrations))
+
+((ucode-primitive garbage-collect 1) #x1000)
+
+((ucode-primitive exit-with-value) 0)
--- /dev/null
+; Test to confirm that the identity hack and exiting work.
+
+(declare (usual-integrations))
+
+((identity (ucode-primitive exit-with-value 1))
+ (identity 0))
--- /dev/null
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+((ucode-primitive exit-with-value 1) x)
--- /dev/null
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+(define (f) x)
+
+((ucode-primitive exit-with-value 1)
+ (f))
--- /dev/null
+(declare (usual-integrations))
+
+(prelude)
+
+(define x 0)
+
+(define (f) x)
+
+(define (g) x)
+
+((ucode-primitive exit-with-value 1)
+ (fix:or (f) (g)))
--- /dev/null
+; A vaguely nontrivial program involving a recursive procedure.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (map-reduce kons f nil l)
+ (let g ((l l))
+ (if (pair? l)
+ (kons (f (car l)) (g (cdr l)))
+ nil)))
+ ((ucode-primitive exit-with-value 1)
+ (map-reduce (identity (lambda (x y) (fix:+ x y)))
+ (identity (lambda (z) (fix:- 0 z)))
+ 0
+ (identity '(1 -2 3 -4 2)))))
--- /dev/null
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with dynamic link and small frame.
+;
+; The LOOP procedure doesn't statically know whether it must pop off
+; the arguments to COPY or only the argument to LOOP when it performs
+; tail calls to IF-PROPER or IF-IMPROPER.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (copy list if-proper if-improper)
+ (let loop ((list list))
+ (cond ((pair? list) (cons (car list) (loop (cdr list))))
+ ((null? list) (if-proper))
+ (else (if-improper list)))))
+ ((identity copy)
+ (identity '(1 2 3 . 0))
+ (lambda () ((ucode-primitive exit-with-value 1) 1))
+ (ucode-primitive exit-with-value 1)))
--- /dev/null
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with dynamic link and large frame.
+;
+; The LOOP procedure doesn't statically know whether it must pop off
+; the arguments to COPY or only the argument to LOOP when it performs
+; tail calls to IF-PROPER or IF-IMPROPER. When it calls IF-IMPROPER,
+; it creates a large frame and then moves it up to where the dynamic
+; link specified the parent started.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (copy list if-proper if-improper)
+ (let loop ((list list))
+ (cond ((pair? list) (cons (car list) (loop (cdr list))))
+ ((null? list) (if-proper))
+ (else (if-improper list list list list list list list list)))))
+ ((identity copy)
+ (identity '(1 2 3 . 0))
+ (lambda () ((ucode-primitive exit-with-value 1) 0))
+ (lambda (a b c d e f g h)
+ ((ucode-primitive exit-with-value 1)
+ (fix:or (fix:or (fix:or a b) (fix:or c d))
+ (fix:or (fix:or e f) (fix:or g h)))))))
--- /dev/null
+; Test for INVOCATION-PREFIX:MOVE-FRAME-UP with a known parent.
+;
+; The LOOP procedure knows how much it has to pop when making a tail
+; call to itself; however, the stack frame it creates is so large that
+; the compiler chooses not to reuse the parent frame but instead use
+; INVOCATION-PREFIX:MOVE-FRAME-UP to replace it.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (fib n x y z f)
+ (let loop
+ ((a 0) (b 1)
+ (x x) (y y) (z z) (p x) (q y) (r z) (u x) (v y) (w z)
+ (i 0))
+ (if (< i n)
+ (let ((p (f y z p))
+ (q (f z x q))
+ (r (f x y r)))
+ (loop b (+ a b) u v w p q r x y z (+ i 1)))
+ (cons b (vector x y z)))))
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (car ((identity fib) 20 0 1 2 (lambda (a b c) b c a)))
+ 10946)))
--- /dev/null
+; Test for static links.
+;
+; The LOOP procedure doesn't know how far up the stack F will be, so
+; the generated code passes an extra stack environment pointer
+; `argument' on the stack. The extra (let ((x ...)) x) frame obviates
+; the need for a dynamic link, because LOOP never has to pop MAP's
+; arguments off the stack -- only its own argument.
+
+(declare (usual-integrations))
+
+(let ()
+ (define (map f l)
+ (let ((x
+ (let loop ((l1 l))
+ (if (pair? l1)
+ (cons (f (car l1)) (loop (cdr l1)))
+ '()))))
+ x))
+ (let ((l ((identity map) (lambda (x) (fix:- 0 x)) '(1 2 3))))
+ ((ucode-primitive exit-with-value 1)
+ (fix:or (fix:+ (car l) 1)
+ (fix:or (fix:+ (cadr l) 2)
+ (fix:+ (caddr l) 3))))))
--- /dev/null
+; -*- Mode: Scheme -*-
+
+(declare (usual-integrations))
+
+(fluid-let ((compiler:generate-rtl-files? #t)
+ (compiler:generate-lap-files? #t)
+ (compiler:generate-type-checks? #f)
+ (compiler:generate-range-checks? #f))
+ (compile-directory "."))
--- /dev/null
+; -*- Mode: Scheme -*-
+
+(declare (usual-integrations))
+
+(let ((environment (make-top-level-environment)))
+ (eval '(begin
+ (define-syntax ucode-primitive
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply make-primitive-procedure (cdr form)))))
+ (define-syntax identity
+ (sc-macro-transformer
+ (lambda (form environment)
+ `((UCODE-PRIMITIVE VECTOR-REF 2)
+ ((UCODE-PRIMITIVE VECTOR-CONS 2)
+ 1
+ ,(close-syntax (cadr form) environment))
+ 0))))
+ (define-syntax prelude
+ (sc-macro-transformer
+ (lambda (form environment)
+ '((ucode-primitive local-assignment)
+ #f ;global environment
+ 'define-multiple
+ (lambda (env names values)
+ (if (or (not (vector? names))
+ (not (vector? values))
+ (not (fix:= (vector-length names)
+ (vector-length values))))
+ (error "DEFINE-MULTIPLE: Invalid arguments"
+ names
+ values))
+ (let ((len (vector-length names)))
+ (let loop ((i 0) (val unspecific))
+ (if (fix:< i len)
+ (loop (fix:+ i 1)
+ ((ucode-primitive local-assignment)
+ env
+ (vector-ref names i)
+ (vector-ref values i)))
+ val)))))))))
+ environment)
+ (fluid-let ((sf/default-syntax-table environment))
+ (sf-directory ".")))
--- /dev/null
+; Test of uuo links.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+ (fix:* x 2))
+
+(define (g x)
+ (f (car (cdr x))))
+
+((ucode-primitive exit-with-value 1)
+ (fix:- (g (cons 1 (cons 2 '())))
+ 4))
--- /dev/null
+; Test of uuo links with closure values.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+ (lambda (y)
+ (fix:* x y)))
+
+(define g
+ (f 5))
+
+(define (h x)
+ (g (car (cdr x))))
+
+((ucode-primitive exit-with-value 1)
+ (fix:- (h (cons 1 (cons 2 '())))
+ 10))
--- /dev/null
+; Test of uuo links with closure values before/after GC.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+ (lambda (y)
+ (fix:* x y)))
+
+(define g
+ (f 5))
+
+(define (h x)
+ (g (car (cdr x))))
+
+(let ((x ((f 3) 5)))
+ ((ucode-primitive garbage-collect 1) #x1000)
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (h (cons 1 (cons 3 '())))
+ x)))
--- /dev/null
+; Test of uuo links, before/after garbage collection.
+
+(declare (usual-integrations))
+
+(prelude)
+
+(define (f x)
+ (fix:* x 2))
+
+(define (g x)
+ (f (car (cdr x))))
+
+(let ((x (f 2)))
+ ((ucode-primitive garbage-collect 1) #x1000)
+ ((ucode-primitive exit-with-value 1)
+ (fix:- (g (cons 1 (cons 2 '())))
+ x)))
projects / mit-scheme.git / commitdiff