From: Matt Birkholz Date: Sun, 5 Feb 2017 02:42:56 +0000 (-0700) Subject: Add tests/runtime/test-multiple-values.scm. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=625d63d7d3f1481441bd4b076b014c9022e741bd;p=mit-scheme.git Add tests/runtime/test-multiple-values.scm. --- diff --git a/tests/check.scm b/tests/check.scm index 2518aa98e..c12aa7eaa 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -61,6 +61,7 @@ USA. "runtime/test-hash-table" "runtime/test-integer-bits" "runtime/test-mime-codec" + "runtime/test-multiple-values" ("runtime/test-parametric-predicate" (runtime parametric-predicate)) ("runtime/test-predicate-lattice" (runtime)) ("runtime/test-predicate-metadata" (runtime)) diff --git a/tests/runtime/test-multiple-values-compiled.scm b/tests/runtime/test-multiple-values-compiled.scm new file mode 100644 index 000000000..aea45de50 --- /dev/null +++ b/tests/runtime/test-multiple-values-compiled.scm @@ -0,0 +1,94 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme 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 +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +(declare (usual-integrations)) + +(define (compiled-producer) + (let ((a 1) + (b 2) + (c 3)) + (values a b c))) + +(define (compiled-producer-mismatch extra) + (cons 'compiled extra)) + +(define (compiled-consumer a b c) + (note "a: "a" b: "b" c: "c) + 'compiled-done) + +(define (compiled-consumer-mismatch a b) + (note "mismatch: a: "a" b: "b) + (cons a b)) + +(define (compiled-caller) + + (define (test-note producer consumer) + (note "caller: compiled, producer: "producer", consumer: "consumer)) + + (test-note 'interpreted 'interpreted) + (call-with-values interpreted-producer interpreted-consumer) + + (test-note 'compiled 'interpreted) + (call-with-values compiled-producer interpreted-consumer) + + (test-note 'interpreted 'compiled) + (call-with-values interpreted-producer compiled-consumer) + + (test-note 'compiled 'compiled) + (call-with-values compiled-producer compiled-consumer)) + +(define (compiled-arity-errors) + (assert-error + (lambda () (call-with-values compiled-producer-mismatch compiled-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer-mismatch compiled-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () (call-with-values compiled-producer compiled-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer compiled-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + + (assert-error + (lambda () + (call-with-values interpreted-producer-mismatch interpreted-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values compiled-producer-mismatch interpreted-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer interpreted-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values compiled-producer interpreted-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments))) \ No newline at end of file diff --git a/tests/runtime/test-multiple-values-interpreted.scm b/tests/runtime/test-multiple-values-interpreted.scm new file mode 100644 index 000000000..915093d9c --- /dev/null +++ b/tests/runtime/test-multiple-values-interpreted.scm @@ -0,0 +1,94 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme 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 +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +(declare (usual-integrations)) + +(define (interpreted-producer) + (let ((a 1) + (b 2) + (c 3)) + (values a b c))) + +(define (interpreted-producer-mismatch extra) + (cons 'interpreted extra)) + +(define (interpreted-consumer a b c) + (note "a: "a" b: "b" c: "c) + 'interpreted-done) + +(define (interpreted-consumer-mismatch a b) + (note "mismatch: a: "a" b: "b) + (cons a b)) + +(define (interpreted-caller) + + (define (test-note producer consumer) + (note "caller: interpreted, producer: "producer", consumer: "consumer)) + + (test-note 'interpreted 'interpreted) + (call-with-values interpreted-producer interpreted-consumer) + + (test-note 'compiled 'interpreted) + (call-with-values compiled-producer interpreted-consumer) + + (test-note 'interpreted 'compiled) + (call-with-values interpreted-producer compiled-consumer) + + (test-note 'compiled 'compiled) + (call-with-values compiled-producer compiled-consumer)) + +(define (interpreted-arity-errors) + (assert-error + (lambda () (call-with-values compiled-producer-mismatch compiled-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer-mismatch compiled-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () (call-with-values compiled-producer compiled-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer compiled-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + + (assert-error + (lambda () + (call-with-values interpreted-producer-mismatch interpreted-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values compiled-producer-mismatch interpreted-consumer)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values interpreted-producer interpreted-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments)) + (assert-error + (lambda () + (call-with-values compiled-producer interpreted-consumer-mismatch)) + (list condition-type:wrong-number-of-arguments))) \ No newline at end of file diff --git a/tests/runtime/test-multiple-values.scm b/tests/runtime/test-multiple-values.scm new file mode 100644 index 000000000..a1c837a54 --- /dev/null +++ b/tests/runtime/test-multiple-values.scm @@ -0,0 +1,47 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme 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 +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Test multiple value returns + +(define notes '()) + +(define (note . objects) + (set! notes (cons objects notes))) + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (sf "test-multiple-values-interpreted.scm") + (load "test-multiple-values-interpreted.bin") + (compile-file "test-multiple-values-compiled.scm") + (load "test-multiple-values-compiled.com"))) + +(define-test 'COMPILED-CALLER compiled-caller) + +(define-test 'INTERPRETED-CALLER interpreted-caller) + +(define-test 'COMPILED-ARITY-ERRORS compiled-arity-errors) + +(define-test 'INTERPRETED-ARITY-ERRORS interpreted-arity-errors) \ No newline at end of file