mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 19:20:23 +02:00
fd5985271f
* module/ice-9/psyntax.scm (gen-label, new-mark): Labels and marks need
to be unique across read/write boundaries -- it's not sufficient for
them to simply be unique within a process by virtue of (string #\i)
constructing a new object. This used to mostly work before, because
the collapsing of duplicate constants didn't catch many syntax-object
cases -- but for some reason the attached test case brings out the
problem. So switch to use gensyms. Potentially more costly, but it's
what upstream psyntax does now.
This bug took me fully two days to figure out.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/syncase.test ("serializable labels and marks"): Add
test case.
108 lines
3.8 KiB
Scheme
108 lines
3.8 KiB
Scheme
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2001, 2006, 2009 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)))
|