mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
691697de09
"RTL" didn't make any sense, and now that there's no other bytecode to disambiguate against, just call it bytecode. * module/Makefile.am: * module/ice-9/eval-string.scm: * module/language/bytecode.scm: * module/language/bytecode/spec.scm: * module/language/cps/arities.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/compile-rtl.scm: * module/language/cps/contification.scm: * module/language/cps/elide-values.scm: * module/language/cps/primitives.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/spec.scm: * module/language/cps/specialize-primcalls.scm: * module/language/rtl.scm: * module/language/rtl/spec.scm: * module/scripts/compile.scm: * module/system/base/compile.scm: * module/system/repl/common.scm: * module/system/vm/assembler.scm: * module/system/vm/debug.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * test-suite/tests/cross-compilation.test: * test-suite/tests/dwarf.test: * test-suite/tests/rtl-compilation.test: * test-suite/tests/rtl.test: * test-suite/vm/run-vm-tests.scm: Fixups.
220 lines
6.8 KiB
Scheme
220 lines
6.8 KiB
Scheme
;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2013 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
(define-module (test-suite bytecode-compilation)
|
|
#:use-module (test-suite lib)
|
|
#:use-module (system base compile)
|
|
#:use-module (system vm loader))
|
|
|
|
(define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
|
|
(load-thunk-from-memory
|
|
(compile exp #:env env #:to 'bytecode
|
|
#:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
|
|
|
|
(define* (run-bytecode exp #:key (env (make-fresh-user-module)))
|
|
(let ((thunk (compile-via-bytecode exp #:env env)))
|
|
(save-module-excursion
|
|
(lambda ()
|
|
(set-current-module env)
|
|
(thunk)))))
|
|
|
|
(with-test-prefix "tail context"
|
|
(pass-if-equal 1
|
|
(run-bytecode '(let ((x 1)) x)))
|
|
|
|
(pass-if-equal 1
|
|
(run-bytecode 1))
|
|
|
|
(pass-if-equal (if #f #f)
|
|
(run-bytecode '(if #f #f)))
|
|
|
|
(pass-if-equal "top-level define"
|
|
(list (if #f #f) 1)
|
|
(let ((mod (make-fresh-user-module)))
|
|
(let ((result (run-bytecode '(define v 1) #:env mod)))
|
|
(list result (module-ref mod 'v)))))
|
|
|
|
(pass-if-equal "top-level set!"
|
|
(list (if #f #f) 1)
|
|
(let ((mod (make-fresh-user-module)))
|
|
(module-define! mod 'v #f)
|
|
(let ((result (run-bytecode '(set! v 1) #:env mod)))
|
|
(list result (module-ref mod 'v)))))
|
|
|
|
(pass-if-equal "top-level apply [single value]"
|
|
8
|
|
(let ((mod (make-fresh-user-module)))
|
|
(module-define! mod 'args '(2 3))
|
|
(run-bytecode '(apply expt args) #:env mod)))
|
|
|
|
(pass-if-equal "top-level apply [zero values]"
|
|
'()
|
|
(let ((mod (make-fresh-user-module)))
|
|
(module-define! mod 'proc (lambda () (values)))
|
|
(module-define! mod 'args '())
|
|
(call-with-values
|
|
(lambda () (run-bytecode '(apply proc args) #:env mod))
|
|
list)))
|
|
|
|
(pass-if-equal "top-level apply [two values]"
|
|
'(1 2)
|
|
(let ((mod (make-fresh-user-module)))
|
|
(module-define! mod 'proc (lambda (n d) (floor/ n d)))
|
|
(module-define! mod 'args '(5 3))
|
|
(call-with-values
|
|
(lambda () (run-bytecode '(apply proc args) #:env mod))
|
|
list)))
|
|
|
|
(pass-if-equal "call-with-values"
|
|
'(1 2 3)
|
|
((run-bytecode '(lambda (n d)
|
|
(call-with-values (lambda () (floor/ n d))
|
|
(lambda (q r) (list q r (+ q r))))))
|
|
5 3))
|
|
|
|
(pass-if-equal cons
|
|
(run-bytecode 'cons))
|
|
|
|
(pass-if-equal 1
|
|
((run-bytecode '(lambda () 1))))
|
|
|
|
(pass-if-equal 1
|
|
((run-bytecode '(lambda (x) 1)) 2))
|
|
|
|
(pass-if-equal 1
|
|
((run-bytecode '(lambda (x) x)) 1))
|
|
|
|
(pass-if-equal 6
|
|
((((run-bytecode '(lambda (x)
|
|
(lambda (y)
|
|
(lambda (z)
|
|
(+ x y z))))) 1) 2) 3))
|
|
|
|
(pass-if-equal 1
|
|
(run-bytecode '(identity 1)))
|
|
|
|
(pass-if-equal '(1 . 2)
|
|
(run-bytecode '(cons 1 2)))
|
|
|
|
(pass-if-equal '(1 2)
|
|
(call-with-values (lambda () (run-bytecode '(values 1 2))) list))
|
|
|
|
(pass-if-equal 28
|
|
((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
|
|
2 3 5 '(7 11)))
|
|
|
|
;; prompts
|
|
)
|
|
|
|
(with-test-prefix "value context"
|
|
1
|
|
)
|
|
|
|
(with-test-prefix "drop context"
|
|
1
|
|
)
|
|
|
|
(with-test-prefix "test context"
|
|
1
|
|
)
|
|
|
|
(with-test-prefix "values context"
|
|
(pass-if-equal '(3 . 1)
|
|
(run-bytecode
|
|
'(let ((rat (lambda (n d)
|
|
(call-with-values
|
|
(lambda () (floor/ n d))
|
|
(lambda (q r)
|
|
(cons q r))))))
|
|
(rat 10 3)))))
|
|
|
|
(with-test-prefix "contification"
|
|
(pass-if ((run-bytecode '(lambda (x)
|
|
(define (even? x)
|
|
(if (null? x) #t (odd? (cdr x))))
|
|
(define (odd? x)
|
|
(if (null? x) #f (even? (cdr x))))
|
|
(even? x)))
|
|
'(1 2 3 4)))
|
|
|
|
(pass-if (not ((run-bytecode '(lambda (x)
|
|
(define (even? x)
|
|
(if (null? x) #t (odd? (cdr x))))
|
|
(define (odd? x)
|
|
(if (null? x) #f (even? (cdr x))))
|
|
(even? x)))
|
|
'(1 2 3))))
|
|
|
|
(pass-if-equal '(#t)
|
|
((run-bytecode '(lambda (x)
|
|
(define (even? x)
|
|
(if (null? x) #t (odd? (cdr x))))
|
|
(define (odd? x)
|
|
(if (null? x) #f (even? (cdr x))))
|
|
(list (even? x))))
|
|
'(1 2 3 4)))
|
|
|
|
;; An irreducible loop between even? and odd?.
|
|
(pass-if-equal '#t
|
|
((run-bytecode '(lambda (x do-even?)
|
|
(define (even? x)
|
|
(if (null? x) #t (odd? (cdr x))))
|
|
(define (odd? x)
|
|
(if (null? x) #f (even? (cdr x))))
|
|
(if do-even? (even? x) (odd? x))))
|
|
'(1 2 3 4)
|
|
#t)))
|
|
|
|
(with-test-prefix "case-lambda"
|
|
(pass-if-equal "simple"
|
|
'(0 3 9 28)
|
|
(let ((proc (run-bytecode '(case-lambda
|
|
(() 0)
|
|
((x) x)
|
|
((x y) (+ x y))
|
|
((x y z . rest) (apply + x y z rest))))))
|
|
(map (lambda (args) (apply proc args))
|
|
'(() (3) (2 7) (2 3 5 7 11)))))
|
|
|
|
(pass-if-exception "no match"
|
|
exception:wrong-num-args
|
|
((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
|
|
1 2 3))
|
|
|
|
(pass-if-exception "zero clauses called with no args"
|
|
exception:wrong-num-args
|
|
((run-bytecode '(case-lambda))))
|
|
|
|
(pass-if-exception "zero clauses called with args"
|
|
exception:wrong-num-args
|
|
((run-bytecode '(case-lambda)) 1)))
|
|
|
|
(with-test-prefix "mixed contexts"
|
|
(pass-if-equal "sequences" '(3 4 5)
|
|
(let* ((pair (cons 1 2))
|
|
(result ((run-bytecode '(lambda (pair)
|
|
(set-car! pair 3)
|
|
(set-cdr! pair 4)
|
|
5))
|
|
pair)))
|
|
(list (car pair)
|
|
(cdr pair)
|
|
result)))
|
|
|
|
(pass-if-equal "mutable lexicals" 2
|
|
(run-bytecode '(let ((n 1)) (set! n 2) n))))
|