summaryrefslogtreecommitdiff
path: root/test-suite/tests/syncase.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/syncase.test')
-rw-r--r--test-suite/tests/syncase.test324
1 files changed, 324 insertions, 0 deletions
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
new file mode 100644
index 000000000..7651c46a4
--- /dev/null
+++ b/test-suite/tests/syncase.test
@@ -0,0 +1,324 @@
+;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013, 2015 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
+
+;; These tests are in a module so that the syntax transformer does not
+;; affect code outside of this file.
+;;
+(define-module (test-suite test-syncase)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (ice-9 regex)
+ #:use-module ((srfi srfi-1) :select (member)))
+
+(define-syntax plus
+ (syntax-rules ()
+ ((plus x ...) (+ x ...))))
+
+(pass-if "basic syncase macro"
+ (= (plus 1 2 3) (+ 1 2 3)))
+
+(pass-if "@ works with syncase"
+ (eq? run-test (@ (test-suite lib) run-test)))
+
+(define-syntax string-let
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ id body ...)
+ #`(let ((id #,(symbol->string
+ (syntax->datum #'id))))
+ body ...)))))
+
+(pass-if "macro using quasisyntax"
+ (equal? (string-let foo (list foo foo))
+ '("foo" "foo")))
+
+(define-syntax string-case
+ (syntax-rules (else)
+ ((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
+ (let ((value expr))
+ (cond ((member value '(string ...) string=?)
+ clause-body ...)
+ ...
+ (else
+ else-body ...))))
+ ((string-case expr ((string ...) clause-body ...) ...)
+ (let ((value expr))
+ (cond ((member value '(string ...) string=?)
+ clause-body ...)
+ ...)))))
+
+(define-syntax alist
+ (syntax-rules (tail)
+ ((alist ((key val) ... (tail expr)))
+ (cons* '(key . val) ... expr))
+ ((alist ((key val) ...))
+ (list '(key . val) ...))))
+
+(with-test-prefix "with-syntax"
+ (pass-if "definitions allowed in body"
+ (equal? (with-syntax ((a 23))
+ (define b #'a)
+ (syntax->datum b))
+ 23)))
+
+(with-test-prefix "tail patterns"
+ (with-test-prefix "at the outermost level"
+ (pass-if "non-tail invocation"
+ (equal? (string-case "foo" (("foo") 'foo))
+ 'foo))
+ (pass-if "tail invocation"
+ (equal? (string-case "foo" (("bar") 'bar) (else 'else))
+ 'else)))
+ (with-test-prefix "at a nested level"
+ (pass-if "non-tail invocation"
+ (equal? (alist ((a 1) (b 2) (c 3)))
+ '((a . 1) (b . 2) (c . 3))))
+ (pass-if "tail invocation"
+ (equal? (alist ((foo 42) (tail '((bar . 66)))))
+ '((foo . 42) (bar . 66))))))
+
+(with-test-prefix "serializable labels and marks"
+ (compile '(begin
+ (define-syntax duplicate-macro
+ (syntax-rules ()
+ ((_ new-name old-name)
+ (define-syntax new-name
+ (syntax-rules ()
+ ((_ . vals)
+ (letrec-syntax ((apply (syntax-rules ()
+ ((_ macro args)
+ (macro . args)))))
+ (apply old-name vals))))))))
+
+ (define-syntax kwote
+ (syntax-rules ()
+ ((_ arg1) 'arg1)))
+
+ (duplicate-macro kwote* kwote))
+ #:env (current-module))
+ (pass-if "compiled macro-generating macro works"
+ (eq? (eval '(kwote* foo) (current-module))
+ 'foo)))
+
+(with-test-prefix "changes to expansion environment"
+ (pass-if "expander detects changes to current-module with @@ @@"
+ (compile '(begin
+ (define-module (new-module))
+ (@@ @@ (new-module)
+ (define-syntax new-module-macro
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ arg) (syntax arg))))))
+ (@@ @@ (new-module)
+ (new-module-macro #t)))
+ #:env (current-module))))
+
+(define-module (test-suite test-syncase-2)
+ #:export (make-the-macro))
+
+(define (hello)
+ 'hello)
+
+(define-syntax make-the-macro
+ (syntax-rules ()
+ ((_ name)
+ (define-syntax name
+ (syntax-rules ()
+ ((_) (hello)))))))
+
+(define-module (test-suite test-syncase)) ;; back to main module
+(use-modules (test-suite test-syncase-2))
+
+(make-the-macro foo)
+
+(with-test-prefix "macro-generating macro"
+ (pass-if "module hygiene"
+ (eq? (foo) 'hello)))
+
+(pass-if "_ is a placeholder"
+ (equal? (eval '(begin
+ (define-syntax ciao
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ _)
+ "ciao"))))
+ (ciao 1))
+ (current-module))
+ "ciao"))
+
+(define qux 30)
+
+(with-test-prefix "identifier-syntax"
+
+ (pass-if "global reference"
+ (let-syntax ((baz (identifier-syntax qux)))
+ (equal? baz qux)))
+
+ (pass-if "lexical hygienic reference"
+ (let-syntax ((baz (identifier-syntax qux)))
+ (let ((qux 20))
+ (equal? (+ baz qux)
+ 50))))
+
+ (pass-if "lexical hygienic reference (bound)"
+ (let ((qux 20))
+ (let-syntax ((baz (identifier-syntax qux)))
+ (equal? (+ baz qux)
+ 40))))
+
+ (pass-if "global reference (settable)"
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (equal? baz qux)))
+
+ (pass-if "lexical hygienic reference (settable)"
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (let ((qux 20))
+ (equal? (+ baz qux)
+ 50))))
+
+ (pass-if "lexical hygienic reference (bound, settable)"
+ (let ((qux 20))
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (equal? (+ baz qux)
+ 40))))
+
+ (pass-if "global set!"
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (set! baz 10)
+ (equal? (+ baz qux) 20)))
+
+ (pass-if "lexical hygienic set!"
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (and (let ((qux 20))
+ (set! baz 5)
+ (equal? (+ baz qux)
+ 25))
+ (equal? qux 5))))
+
+ (pass-if "lexical hygienic set! (bound)"
+ (let ((qux 20))
+ (let-syntax ((baz (identifier-syntax
+ (id qux)
+ ((set! id expr) (set! qux expr)))))
+ (set! baz 50)
+ (equal? (+ baz qux)
+ 100)))))
+
+(with-test-prefix "top-level expansions"
+ (pass-if "syntax definitions expanded before other expressions"
+ (eval '(begin
+ (define even?
+ (lambda (x)
+ (or (= x 0) (odd? (- x 1)))))
+ (define-syntax odd?
+ (syntax-rules ()
+ ((odd? x) (not (even? x)))))
+ (even? 10))
+ (current-module))))
+
+(define-module (test-suite test-syncase-3)
+ #:autoload (test-syncase-3-does-not-exist) (baz))
+
+(define-module (test-suite test-syncase)) ;; back to main module
+
+(pass-if "missing autoloads do not foil psyntax"
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (eval '(if #f (baz) #t)
+ (resolve-module '(test-suite test-syncase-3)))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+ (define-syntax syntax-type
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id resolve?)
+ (call-with-values
+ (lambda ()
+ (syntax-local-binding
+ #'id
+ #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+ (lambda (type value)
+ (with-syntax ((type (datum->syntax #'id type)))
+ #''type)))))))
+
+ (define-syntax-parameter foo
+ (syntax-rules ()))
+
+ (pass-if "syntax-parameters (resolved)"
+ (equal? (syntax-type foo #t) 'macro))
+
+ (pass-if "syntax-parameters (unresolved)"
+ (equal? (syntax-type foo #f) 'syntax-parameter)))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
+
+(with-test-prefix "primitives"
+ (pass-if-syntax-error "primref in default module"
+ "failed to match"
+ (macroexpand '(@@ primitive cons)))
+
+ (pass-if-syntax-error "primcall in default module"
+ "failed to match"
+ (macroexpand '((@@ primitive cons) 1 2)))
+
+ (pass-if-equal "primcall in (guile)"
+ '(1 . 2)
+ (@@ @@ (guile) ((@@ primitive cons) 1 2)))
+
+ (pass-if-syntax-error "primref in (guile)"
+ "not in operator position"
+ (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
+
+(pass-if "infinite loop bug"
+ (begin
+ (macroexpand
+ '(let-syntax
+ ((define-foo
+ (syntax-rules ()
+ ((define-foo a b)
+ (begin
+ (define a '())
+ ;; Oddly, the "*" in the define* seems to be
+ ;; important in triggering this bug.
+ (define* (b) (set! a a)))))))
+ (define-foo a c)))
+ #t))