mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
9846796b6a
* module/ice-9/psyntax.scm (chi-macro): Instead of assuming that output
of a macro should be scoped relative to the module that was current
when the macro was defined, allow the module information associated
with the syntax object itself to pass through unmolested. Fixes bug
29860.
(datum->syntax): Propagate the module of the identifier through to the
new syntax object, so that datum->syntax preserves module hygiene in
addition to lexical hygiene.
(include, include-from-path): Refactor to plumb though the hygiene
information from the filename instead of the `include', allowing
hygiene from the original caller of include-from-path to propagate
through.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/syncase.test ("macro-generating macro"): Add test for
bug 29860.
143 lines
4.7 KiB
Scheme
143 lines
4.7 KiB
Scheme
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2001, 2006, 2009, 2010 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 ((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 "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)))
|