Merge branch 'stable-2.0'
Conflicts: libguile/hash.c module/ice-9/psyntax-pp.scm module/ice-9/psyntax.scm test-suite/tests/r6rs-ports.test
This commit is contained in:
Mark H Weaver
commit
b958141cdb
13 changed files with 659 additions and 133 deletions
|
|
@ -137,7 +137,7 @@ same @var{letrec-syntax}.
|
|||
@code{syntax-rules} macros are simple, pattern-driven syntax transformers, with
|
||||
a beauty worthy of Scheme.
|
||||
|
||||
@deffn {Syntax} syntax-rules literals (pattern template)...
|
||||
@deffn {Syntax} syntax-rules literals (pattern template) @dots{}
|
||||
Create a syntax transformer that will rewrite an expression using the rules
|
||||
embodied in the @var{pattern} and @var{template} clauses.
|
||||
@end deffn
|
||||
|
|
@ -364,6 +364,50 @@ Cast into this form, our @code{when} example is significantly shorter:
|
|||
(if c (begin e ...)))
|
||||
@end example
|
||||
|
||||
@subsubsection Reporting Syntax Errors in Macros
|
||||
|
||||
@deffn {Syntax} syntax-error message [arg ...]
|
||||
Report an error at macro-expansion time. @var{message} must be a string
|
||||
literal, and the optional @var{arg} operands can be arbitrary expressions
|
||||
providing additional information.
|
||||
@end deffn
|
||||
|
||||
@code{syntax-error} is intended to be used within @code{syntax-rules}
|
||||
templates. For example:
|
||||
|
||||
@example
|
||||
(define-syntax simple-let
|
||||
(syntax-rules ()
|
||||
((_ (head ... ((x . y) val) . tail)
|
||||
body1 body2 ...)
|
||||
(syntax-error
|
||||
"expected an identifier but got"
|
||||
(x . y)))
|
||||
((_ ((name val) ...) body1 body2 ...)
|
||||
((lambda (name ...) body1 body2 ...)
|
||||
val ...))))
|
||||
@end example
|
||||
|
||||
@subsubsection Specifying a Custom Ellipsis Identifier
|
||||
|
||||
When writing macros that generate macro definitions, it is convenient to
|
||||
use a different ellipsis identifier at each level. Guile allows the
|
||||
desired ellipsis identifier to be specified as the first operand to
|
||||
@code{syntax-rules}, as per R7RS. For example:
|
||||
|
||||
@example
|
||||
(define-syntax define-quotation-macros
|
||||
(syntax-rules ()
|
||||
((_ (macro-name head-symbol) ...)
|
||||
(begin (define-syntax macro-name
|
||||
(syntax-rules ::: ()
|
||||
((_ x :::)
|
||||
(quote (head-symbol x :::)))))
|
||||
...))))
|
||||
(define-quotation-macros (quote-a a) (quote-b b) (quote-c c))
|
||||
(quote-a 1 2 3) @result{} (a 1 2 3)
|
||||
@end example
|
||||
|
||||
@subsubsection Further Information
|
||||
|
||||
For a formal definition of @code{syntax-rules} and its pattern language, see
|
||||
|
|
@ -390,7 +434,7 @@ Primer for the Merely Eccentric}.
|
|||
@code{syntax-case} macros are procedural syntax transformers, with a power
|
||||
worthy of Scheme.
|
||||
|
||||
@deffn {Syntax} syntax-case syntax literals (pattern [guard] exp)...
|
||||
@deffn {Syntax} syntax-case syntax literals (pattern [guard] exp) @dots{}
|
||||
Match the syntax object @var{syntax} against the given patterns, in order. If a
|
||||
@var{pattern} matches, return the result of evaluating the associated @var{exp}.
|
||||
@end deffn
|
||||
|
|
@ -632,9 +676,9 @@ variable environment, and we can do so using @code{syntax-case} itself:
|
|||
However there are easier ways to write this. @code{with-syntax} is often
|
||||
convenient:
|
||||
|
||||
@deffn {Syntax} with-syntax ((pat val)...) exp...
|
||||
@deffn {Syntax} with-syntax ((pat val) @dots{}) exp @dots{}
|
||||
Bind patterns @var{pat} from their corresponding values @var{val}, within the
|
||||
lexical context of @var{exp...}.
|
||||
lexical context of @var{exp} @enddots{}.
|
||||
|
||||
@example
|
||||
;; better
|
||||
|
|
@ -682,6 +726,42 @@ edition 3 or 4, in the chapter on syntax. Dybvig was the primary author of the
|
|||
@code{syntax-case} system. The book itself is available online at
|
||||
@uref{http://scheme.com/tspl4/}.
|
||||
|
||||
@subsubsection Custom Ellipsis Identifiers for syntax-case Macros
|
||||
|
||||
When writing procedural macros that generate macro definitions, it is
|
||||
convenient to use a different ellipsis identifier at each level. Guile
|
||||
supports this for procedural macros using the @code{with-ellipsis}
|
||||
special form:
|
||||
|
||||
@deffn {Syntax} with-ellipsis ellipsis body @dots{}
|
||||
@var{ellipsis} must be an identifier. Evaluate @var{body} in a special
|
||||
lexical environment such that all macro patterns and templates within
|
||||
@var{body} will use @var{ellipsis} as the ellipsis identifier instead of
|
||||
the usual three dots (@code{...}).
|
||||
@end deffn
|
||||
|
||||
For example:
|
||||
|
||||
@example
|
||||
(define-syntax define-quotation-macros
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (macro-name head-symbol) ...)
|
||||
#'(begin (define-syntax macro-name
|
||||
(lambda (x)
|
||||
(with-ellipsis :::
|
||||
(syntax-case x ()
|
||||
((_ x :::)
|
||||
#'(quote (head-symbol x :::)))))))
|
||||
...)))))
|
||||
(define-quotation-macros (quote-a a) (quote-b b) (quote-c c))
|
||||
(quote-a 1 2 3) @result{} (a 1 2 3)
|
||||
@end example
|
||||
|
||||
Note that @code{with-ellipsis} does not affect the ellipsis identifier
|
||||
of the generated code, unless @code{with-ellipsis} is included around
|
||||
the generated code.
|
||||
|
||||
@node Syntax Transformer Helpers
|
||||
@subsection Syntax Transformer Helpers
|
||||
|
||||
|
|
@ -747,8 +827,11 @@ value will not be returned. Pass @code{#:resolve-syntax-parameters? #f}
|
|||
to indicate that you are interested in syntax parameters. The value is
|
||||
the default transformer procedure, as in @code{macro}.
|
||||
@item pattern-variable
|
||||
A pattern variable, bound via syntax-case. The value is an opaque
|
||||
object, internal to the expander.
|
||||
A pattern variable, bound via @code{syntax-case}. The value is an
|
||||
opaque object, internal to the expander.
|
||||
@item ellipsis
|
||||
An internal binding, bound via @code{with-ellipsis}. The value is the
|
||||
(anti-marked) local ellipsis identifier.
|
||||
@item displaced-lexical
|
||||
A lexical variable that has gone out of scope. This can happen if a
|
||||
badly-written procedural macro saves a syntax object, then attempts to
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
This manual documents Guile version @value{VERSION}.
|
||||
|
||||
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
|
||||
2010, 2011, 2012, 2013 Free Software Foundation.
|
||||
2010, 2011, 2012, 2013, 2014 Free Software Foundation.
|
||||
|
||||
Permission is granted to copy, distribute and/or modify this document
|
||||
under the terms of the GNU Free Documentation License, Version 1.3 or
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
|
||||
* 2009, 2010, 2011, 2012 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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 2009, 2010, 2011, 2013, 2014 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
|
||||
|
|
@ -216,10 +216,14 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
|
|||
result = scm_call_0 (get_position_proc);
|
||||
else
|
||||
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
|
||||
"R6RS custom binary port does not "
|
||||
"support `port-position'");
|
||||
"R6RS custom binary port with "
|
||||
"`port-position' support");
|
||||
c_result = scm_to_int (result);
|
||||
if (offset == 0)
|
||||
/* We just want to know the current position. */
|
||||
break;
|
||||
|
||||
offset += scm_to_int (result);
|
||||
offset += c_result;
|
||||
/* Fall through. */
|
||||
}
|
||||
|
||||
|
|
@ -232,8 +236,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence)
|
|||
result = scm_call_1 (set_position_proc, scm_from_int (offset));
|
||||
else
|
||||
scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
|
||||
"R6RS custom binary port does not "
|
||||
"support `set-port-position!'");
|
||||
"seekable R6RS custom binary port");
|
||||
|
||||
/* Assuming setting the position succeeded. */
|
||||
c_result = offset;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Parsing Guile's command-line
|
||||
|
||||
;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 1994-1998, 2000-2011, 2012, 2013, 2014 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
|
||||
|
|
@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
|
|||
(define* (version-etc package version #:key
|
||||
(port (current-output-port))
|
||||
;; FIXME: authors
|
||||
(copyright-year 2013)
|
||||
(copyright-year 2014)
|
||||
(copyright-holder "Free Software Foundation, Inc.")
|
||||
(copyright (format #f "Copyright (C) ~a ~a"
|
||||
copyright-year copyright-holder))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;
|
||||
;;; Copyright (C) 2012 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2012, 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
|
||||
|
|
@ -179,6 +179,12 @@
|
|||
(cdr val)
|
||||
t)
|
||||
patterns))))
|
||||
((ellipsis)
|
||||
(lp ids capture formals
|
||||
(cons (lambda (x)
|
||||
#`(with-ellipsis #,val #,x))
|
||||
wrappers)
|
||||
patterns))
|
||||
(else
|
||||
;; Interestingly, this case can include globals (and
|
||||
;; global macros), now that Guile tracks which globals it
|
||||
|
|
|
|||
|
|
@ -276,7 +276,7 @@
|
|||
(if (null? r)
|
||||
'()
|
||||
(let ((a (car r)))
|
||||
(if (memq (cadr a) '(macro syntax-parameter))
|
||||
(if (memq (cadr a) '(macro syntax-parameter ellipsis))
|
||||
(cons a (macros-only-env (cdr r)))
|
||||
(macros-only-env (cdr r)))))))
|
||||
(global-extend
|
||||
|
|
@ -591,7 +591,14 @@
|
|||
(let ((x (build-global-definition s var (expand e r w mod))))
|
||||
(top-level-eval-hook x mod)
|
||||
(lambda () x))
|
||||
(lambda () (build-global-definition s var (expand e r w mod)))))))
|
||||
(call-with-values
|
||||
(lambda () (resolve-identifier id '(()) r mod #t))
|
||||
(lambda (type* value* mod*)
|
||||
(if (eq? type* 'macro)
|
||||
(top-level-eval-hook
|
||||
(build-global-definition s var (build-void s))
|
||||
mod))
|
||||
(lambda () (build-global-definition s var (expand e r w mod)))))))))
|
||||
((memv key '(define-syntax-form define-syntax-parameter-form))
|
||||
(let* ((id (wrap value w mod))
|
||||
(label (gen-label))
|
||||
|
|
@ -1129,9 +1136,23 @@
|
|||
(syntax-violation #f "nonprocedure transformer" p)))))
|
||||
(expand-void (lambda () (build-void #f)))
|
||||
(ellipsis?
|
||||
(lambda (x)
|
||||
(and (nonsymbol-id? x)
|
||||
(free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
|
||||
(lambda (e r mod)
|
||||
(and (nonsymbol-id? e)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(resolve-identifier
|
||||
(make-syntax-object
|
||||
'#{ $sc-ellipsis }#
|
||||
(syntax-object-wrap e)
|
||||
(syntax-object-module e))
|
||||
'(())
|
||||
r
|
||||
mod
|
||||
#f))
|
||||
(lambda (type value mod)
|
||||
(if (eq? type 'ellipsis)
|
||||
(bound-id=? e value)
|
||||
(free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
|
||||
(lambda-formals
|
||||
(lambda (orig-args)
|
||||
(letrec*
|
||||
|
|
@ -1607,14 +1628,15 @@
|
|||
(call-with-values
|
||||
(lambda () (gen-ref src (car value) (cdr value) maps))
|
||||
(lambda (var maps) (values (list 'ref var) maps))))
|
||||
((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
|
||||
((ellipsis? e r mod)
|
||||
(syntax-violation 'syntax "misplaced ellipsis" src))
|
||||
(else (values (list 'quote e) maps))))))
|
||||
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
|
||||
(if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
|
||||
(apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
|
||||
(if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
|
||||
(apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
|
||||
(if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
|
||||
(if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1))
|
||||
(apply (lambda (x dots y)
|
||||
(let f ((y y)
|
||||
(k (lambda (maps)
|
||||
|
|
@ -1625,7 +1647,7 @@
|
|||
(syntax-violation 'syntax "extra ellipsis" src)
|
||||
(values (gen-map x (car maps)) (cdr maps))))))))
|
||||
(let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
|
||||
(if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
|
||||
(if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
|
||||
(apply (lambda (dots y)
|
||||
(f y
|
||||
(lambda (maps)
|
||||
|
|
@ -1847,6 +1869,30 @@
|
|||
args)))
|
||||
tmp)
|
||||
(syntax-violation 'case-lambda "bad case-lambda*" e))))))))
|
||||
(global-extend
|
||||
'core
|
||||
'with-ellipsis
|
||||
(lambda (e r w s mod)
|
||||
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
|
||||
(if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
|
||||
(apply (lambda (dots e1 e2)
|
||||
(let ((id (if (symbol? dots)
|
||||
'#{ $sc-ellipsis }#
|
||||
(make-syntax-object
|
||||
'#{ $sc-ellipsis }#
|
||||
(syntax-object-wrap dots)
|
||||
(syntax-object-module dots)))))
|
||||
(let ((ids (list id))
|
||||
(labels (list (gen-label)))
|
||||
(bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
|
||||
(let ((nw (make-binding-wrap ids labels w))
|
||||
(nr (extend-env labels bindings r)))
|
||||
(expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
'with-ellipsis
|
||||
"bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
(global-extend
|
||||
'core
|
||||
'let
|
||||
|
|
@ -2103,7 +2149,7 @@
|
|||
'syntax-case
|
||||
(letrec*
|
||||
((convert-pattern
|
||||
(lambda (pattern keys)
|
||||
(lambda (pattern keys ellipsis?)
|
||||
(letrec*
|
||||
((cvt* (lambda (p* n ids)
|
||||
(let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
|
||||
|
|
@ -2197,9 +2243,10 @@
|
|||
(gen-clause
|
||||
(lambda (x keys clauses r pat fender exp mod)
|
||||
(call-with-values
|
||||
(lambda () (convert-pattern pat keys))
|
||||
(lambda ()
|
||||
(convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
|
||||
(lambda (p pvars)
|
||||
(cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
|
||||
(cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
|
||||
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
|
||||
((not (distinct-bound-ids? (map car pvars)))
|
||||
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
|
||||
|
|
@ -2276,7 +2323,7 @@
|
|||
(tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (val key m)
|
||||
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
|
||||
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
|
||||
(let ((x (gen-var 'tmp)))
|
||||
(build-call
|
||||
s
|
||||
|
|
@ -2401,6 +2448,13 @@
|
|||
(if (equal? mod '(primitive))
|
||||
(values 'primitive value)
|
||||
(values 'global (cons value (cdr mod)))))
|
||||
((memv key '(ellipsis))
|
||||
(values
|
||||
'ellipsis
|
||||
(make-syntax-object
|
||||
(syntax-object-expression value)
|
||||
(anti-mark (syntax-object-wrap value))
|
||||
(syntax-object-module value))))
|
||||
(else (values 'other #f)))))))))))
|
||||
(syntax-locally-bound-identifiers
|
||||
(lambda (id)
|
||||
|
|
@ -2582,80 +2636,197 @@
|
|||
"source expression failed to match any pattern"
|
||||
tmp)))))))))))
|
||||
|
||||
(define syntax-rules
|
||||
(define syntax-error
|
||||
(make-syntax-transformer
|
||||
'syntax-rules
|
||||
'syntax-error
|
||||
'macro
|
||||
(lambda (xx)
|
||||
(let ((tmp-1 xx))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
|
||||
(if tmp
|
||||
(apply (lambda (k keyword pattern template)
|
||||
(list '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
'(#(syntax-object x ((top)) (hygiene guile)))
|
||||
(vector
|
||||
'(#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-rules)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object syntax-rules ((top)) (hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
|
||||
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object x ((top)) (hygiene guile))
|
||||
(cons k
|
||||
(map (lambda (tmp-1 tmp)
|
||||
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
tmp-1)))
|
||||
template
|
||||
pattern))))))
|
||||
(lambda (x)
|
||||
(let ((tmp-1 x))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
|
||||
(if (if tmp
|
||||
(apply (lambda (keyword operands message arg)
|
||||
(string? (syntax->datum message)))
|
||||
tmp)
|
||||
#f)
|
||||
(apply (lambda (keyword operands message arg)
|
||||
(syntax-violation
|
||||
(syntax->datum keyword)
|
||||
(string-join
|
||||
(cons (syntax->datum message)
|
||||
(map (lambda (x) (object->string (syntax->datum x))) arg)))
|
||||
(if (syntax->datum keyword) (cons keyword operands) #f)))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
|
||||
(if (if tmp
|
||||
(apply (lambda (k docstring keyword pattern template)
|
||||
(string? (syntax->datum docstring)))
|
||||
tmp)
|
||||
(apply (lambda (message arg) (string? (syntax->datum message))) tmp)
|
||||
#f)
|
||||
(apply (lambda (k docstring keyword pattern template)
|
||||
(list '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
'(#(syntax-object x ((top)) (hygiene guile)))
|
||||
docstring
|
||||
(vector
|
||||
'(#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-rules)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object syntax-rules ((top)) (hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
(cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
|
||||
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object x ((top)) (hygiene guile))
|
||||
(cons k
|
||||
(map (lambda (tmp-1 tmp)
|
||||
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
tmp-1)))
|
||||
template
|
||||
pattern))))))
|
||||
(apply (lambda (message arg)
|
||||
(cons '#(syntax-object
|
||||
syntax-error
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-error)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object syntax-error ((top)) (hygiene guile))))))
|
||||
(hygiene guile))
|
||||
(cons '(#f) (cons message arg))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))
|
||||
|
||||
(define syntax-rules
|
||||
(make-syntax-transformer
|
||||
'syntax-rules
|
||||
'macro
|
||||
(lambda (xx)
|
||||
(letrec*
|
||||
((expand-clause
|
||||
(lambda (clause)
|
||||
(let ((tmp-1 clause))
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'((any . any)
|
||||
(#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
|
||||
any
|
||||
.
|
||||
each-any)))))
|
||||
(if (if tmp
|
||||
(apply (lambda (keyword pattern message arg)
|
||||
(string? (syntax->datum message)))
|
||||
tmp)
|
||||
#f)
|
||||
(apply (lambda (keyword pattern message arg)
|
||||
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object syntax-error ((top)) (hygiene guile))
|
||||
(cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(cons message arg))))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
|
||||
(if tmp
|
||||
(apply (lambda (keyword pattern template)
|
||||
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1))))))))
|
||||
(expand-syntax-rules
|
||||
(lambda (dots keys docstrings clauses)
|
||||
(let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(each-any each-any #(each ((any . any) any)) each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (k docstring keyword pattern template clause)
|
||||
(let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
(cons '(#(syntax-object x ((top)) (hygiene guile)))
|
||||
(append
|
||||
docstring
|
||||
(list (vector
|
||||
'(#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-rules)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top))
|
||||
(hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
(cons '#(syntax-object patterns ((top)) (hygiene guile))
|
||||
pattern))
|
||||
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object x ((top)) (hygiene guile))
|
||||
(cons k clause)))))))))
|
||||
(let ((form tmp))
|
||||
(if dots
|
||||
(let ((tmp dots))
|
||||
(let ((dots tmp))
|
||||
(list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
|
||||
dots
|
||||
form)))
|
||||
form))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))
|
||||
(let ((tmp xx))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
|
||||
(if tmp-1
|
||||
(apply (lambda (k keyword pattern template)
|
||||
(expand-syntax-rules
|
||||
#f
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
|
||||
(if (if tmp-1
|
||||
(apply (lambda (k docstring keyword pattern template)
|
||||
(string? (syntax->datum docstring)))
|
||||
tmp-1)
|
||||
#f)
|
||||
(apply (lambda (k docstring keyword pattern template)
|
||||
(expand-syntax-rules
|
||||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
|
||||
(if (if tmp-1
|
||||
(apply (lambda (dots k keyword pattern template) (identifier? dots))
|
||||
tmp-1)
|
||||
#f)
|
||||
(apply (lambda (dots k keyword pattern template)
|
||||
(expand-syntax-rules
|
||||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
|
||||
(if (if tmp-1
|
||||
(apply (lambda (dots k docstring keyword pattern template)
|
||||
(if (identifier? dots) (string? (syntax->datum docstring)) #f))
|
||||
tmp-1)
|
||||
#f)
|
||||
(apply (lambda (dots k docstring keyword pattern template)
|
||||
(expand-syntax-rules
|
||||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
tmp-1)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp))))))))))))))
|
||||
|
||||
(define define-syntax-rule
|
||||
(make-syntax-transformer
|
||||
'define-syntax-rule
|
||||
|
|
|
|||
|
|
@ -42,6 +42,9 @@
|
|||
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
|
||||
;;; revision control logs corresponding to this file: 2009, 2010.
|
||||
|
||||
;;; Modified by Mark H Weaver <mhw@netris.org> according to the Git
|
||||
;;; revision control logs corresponding to this file: 2012, 2013.
|
||||
|
||||
|
||||
;;; This code is based on "Syntax Abstraction in Scheme"
|
||||
;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
|
||||
|
|
@ -511,6 +514,7 @@
|
|||
;; (syntax . (<var> . <level>)) pattern variables
|
||||
;; (global) assumed global variable
|
||||
;; (lexical . <var>) lexical variables
|
||||
;; (ellipsis . <identifier>) custom ellipsis
|
||||
;; (displaced-lexical) displaced lexicals
|
||||
;; <level> ::= <nonnegative integer>
|
||||
;; <var> ::= variable returned by build-lexical-var
|
||||
|
|
@ -530,6 +534,9 @@
|
|||
|
||||
;; a lexical variable is a lambda- or letrec-bound variable.
|
||||
|
||||
;; an ellipsis binding is introduced by the 'with-ellipsis' special
|
||||
;; form.
|
||||
|
||||
;; a displaced-lexical identifier is a lexical identifier removed from
|
||||
;; it's scope by the return of a syntax object containing the identifier.
|
||||
;; a displaced lexical can also appear when a letrec-syntax-bound
|
||||
|
|
@ -571,7 +578,7 @@
|
|||
(if (null? r)
|
||||
'()
|
||||
(let ((a (car r)))
|
||||
(if (memq (cadr a) '(macro syntax-parameter))
|
||||
(if (memq (cadr a) '(macro syntax-parameter ellipsis))
|
||||
(cons a (macros-only-env (cdr r)))
|
||||
(macros-only-env (cdr r)))))))
|
||||
|
||||
|
|
@ -1086,8 +1093,17 @@
|
|||
(let ((x (build-global-definition s var (expand e r w mod))))
|
||||
(top-level-eval-hook x mod)
|
||||
(lambda () x))
|
||||
(lambda ()
|
||||
(build-global-definition s var (expand e r w mod)))))))
|
||||
(call-with-values
|
||||
(lambda () (resolve-identifier id empty-wrap r mod #t))
|
||||
(lambda (type* value* mod*)
|
||||
;; If the identifier to be bound is currently bound to a
|
||||
;; macro, then immediately discard that binding.
|
||||
(if (eq? type* 'macro)
|
||||
(top-level-eval-hook (build-global-definition
|
||||
s var (build-void s))
|
||||
mod))
|
||||
(lambda ()
|
||||
(build-global-definition s var (expand e r w mod)))))))))
|
||||
((define-syntax-form define-syntax-parameter-form)
|
||||
(let* ((id (wrap value w mod))
|
||||
(label (gen-label))
|
||||
|
|
@ -1124,8 +1140,8 @@
|
|||
(parse #'(e1 ...) r w s m esew mod))))
|
||||
((local-syntax-form)
|
||||
(expand-local-syntax value e r w s mod
|
||||
(lambda (forms r w s mod)
|
||||
(parse forms r w s m esew mod))))
|
||||
(lambda (forms r w s mod)
|
||||
(parse forms r w s m esew mod))))
|
||||
((eval-when-form)
|
||||
(syntax-case e ()
|
||||
((_ (x ...) e1 e2 ...)
|
||||
|
|
@ -1675,9 +1691,24 @@
|
|||
(build-void no-source)))
|
||||
|
||||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (nonsymbol-id? x)
|
||||
(free-id=? x #'(... ...)))))
|
||||
(lambda (e r mod)
|
||||
(and (nonsymbol-id? e)
|
||||
;; If there is a binding for the special identifier
|
||||
;; #{ $sc-ellipsis }# in the lexical environment of E,
|
||||
;; and if the associated binding type is 'ellipsis',
|
||||
;; then the binding's value specifies the custom ellipsis
|
||||
;; identifier within that lexical environment, and the
|
||||
;; comparison is done using 'bound-id=?'.
|
||||
(call-with-values
|
||||
(lambda () (resolve-identifier
|
||||
(make-syntax-object '#{ $sc-ellipsis }#
|
||||
(syntax-object-wrap e)
|
||||
(syntax-object-module e))
|
||||
empty-wrap r mod #f))
|
||||
(lambda (type value mod)
|
||||
(if (eq? type 'ellipsis)
|
||||
(bound-id=? e value)
|
||||
(free-id=? e #'(... ...))))))))
|
||||
|
||||
(define lambda-formals
|
||||
(lambda (orig-args)
|
||||
|
|
@ -2010,17 +2041,17 @@
|
|||
(lambda (var maps)
|
||||
(values `(ref ,var) maps))))
|
||||
(else
|
||||
(if (ellipsis? e)
|
||||
(if (ellipsis? e r mod)
|
||||
(syntax-violation 'syntax "misplaced ellipsis" src)
|
||||
(values `(quote ,e) maps))))))
|
||||
(syntax-case e ()
|
||||
((dots e)
|
||||
(ellipsis? #'dots)
|
||||
(gen-syntax src #'e r maps (lambda (x) #f) mod))
|
||||
(ellipsis? #'dots r mod)
|
||||
(gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
|
||||
((x dots . y)
|
||||
;; this could be about a dozen lines of code, except that we
|
||||
;; choose to handle #'(x ... ...) forms
|
||||
(ellipsis? #'dots)
|
||||
(ellipsis? #'dots r mod)
|
||||
(let f ((y #'y)
|
||||
(k (lambda (maps)
|
||||
(call-with-values
|
||||
|
|
@ -2035,7 +2066,7 @@
|
|||
(cdr maps))))))))
|
||||
(syntax-case y ()
|
||||
((dots . y)
|
||||
(ellipsis? #'dots)
|
||||
(ellipsis? #'dots r mod)
|
||||
(f #'y
|
||||
(lambda (maps)
|
||||
(call-with-values
|
||||
|
|
@ -2226,6 +2257,25 @@
|
|||
#'((args e1 e2 ...) ...)))
|
||||
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
|
||||
|
||||
(global-extend 'core 'with-ellipsis
|
||||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ dots e1 e2 ...)
|
||||
(id? #'dots)
|
||||
(let ((id (if (symbol? #'dots)
|
||||
'#{ $sc-ellipsis }#
|
||||
(make-syntax-object '#{ $sc-ellipsis }#
|
||||
(syntax-object-wrap #'dots)
|
||||
(syntax-object-module #'dots)))))
|
||||
(let ((ids (list id))
|
||||
(labels (list (gen-label)))
|
||||
(bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
|
||||
(let ((nw (make-binding-wrap ids labels w))
|
||||
(nr (extend-env labels bindings r)))
|
||||
(expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
|
||||
(_ (syntax-violation 'with-ellipsis "bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
|
||||
(global-extend 'core 'let
|
||||
(let ()
|
||||
(define (expand-let e r w s mod constructor ids vals exps)
|
||||
|
|
@ -2438,7 +2488,7 @@
|
|||
(define convert-pattern
|
||||
;; accepts pattern & keys
|
||||
;; returns $sc-dispatch pattern & ids
|
||||
(lambda (pattern keys)
|
||||
(lambda (pattern keys ellipsis?)
|
||||
(define cvt*
|
||||
(lambda (p* n ids)
|
||||
(syntax-case p* ()
|
||||
|
|
@ -2528,10 +2578,10 @@
|
|||
(define gen-clause
|
||||
(lambda (x keys clauses r pat fender exp mod)
|
||||
(call-with-values
|
||||
(lambda () (convert-pattern pat keys))
|
||||
(lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
|
||||
(lambda (p pvars)
|
||||
(cond
|
||||
((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
|
||||
((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
|
||||
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
|
||||
((not (distinct-bound-ids? (map car pvars)))
|
||||
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
|
||||
|
|
@ -2597,7 +2647,7 @@
|
|||
(let ((e (source-wrap e w s mod)))
|
||||
(syntax-case e ()
|
||||
((_ val (key ...) m ...)
|
||||
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
|
||||
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod))))
|
||||
#'(key ...))
|
||||
(let ((x (gen-var 'tmp)))
|
||||
;; fat finger binding and references to temp variable x
|
||||
|
|
@ -2708,6 +2758,11 @@
|
|||
(if (equal? mod '(primitive))
|
||||
(values 'primitive value)
|
||||
(values 'global (cons value (cdr mod)))))
|
||||
((ellipsis)
|
||||
(values 'ellipsis
|
||||
(make-syntax-object (syntax-object-expression value)
|
||||
(anti-mark (syntax-object-wrap value))
|
||||
(syntax-object-module value))))
|
||||
(else (values 'other #f))))))))
|
||||
|
||||
(define (syntax-locally-bound-identifiers id)
|
||||
|
|
@ -2899,27 +2954,69 @@
|
|||
#'(syntax-case (list in ...) ()
|
||||
((out ...) (let () e1 e2 ...)))))))
|
||||
|
||||
(define-syntax syntax-error
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
;; Extended internal syntax which provides the original form
|
||||
;; as the first operand, for improved error reporting.
|
||||
((_ (keyword . operands) message arg ...)
|
||||
(string? (syntax->datum #'message))
|
||||
(syntax-violation (syntax->datum #'keyword)
|
||||
(string-join (cons (syntax->datum #'message)
|
||||
(map (lambda (x)
|
||||
(object->string
|
||||
(syntax->datum x)))
|
||||
#'(arg ...))))
|
||||
(and (syntax->datum #'keyword)
|
||||
#'(keyword . operands))))
|
||||
;; Standard R7RS syntax
|
||||
((_ message arg ...)
|
||||
(string? (syntax->datum #'message))
|
||||
#'(syntax-error (#f) message arg ...)))))
|
||||
|
||||
(define-syntax syntax-rules
|
||||
(lambda (xx)
|
||||
(define (expand-clause clause)
|
||||
;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
|
||||
(syntax-case clause (syntax-error)
|
||||
;; If the template is a 'syntax-error' form, use the extended
|
||||
;; internal syntax, which adds the original form as the first
|
||||
;; operand for improved error reporting.
|
||||
(((keyword . pattern) (syntax-error message arg ...))
|
||||
(string? (syntax->datum #'message))
|
||||
#'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
|
||||
;; Normal case
|
||||
(((keyword . pattern) template)
|
||||
#'((dummy . pattern) #'template))))
|
||||
(define (expand-syntax-rules dots keys docstrings clauses)
|
||||
(with-syntax
|
||||
(((k ...) keys)
|
||||
((docstring ...) docstrings)
|
||||
((((keyword . pattern) template) ...) clauses)
|
||||
((clause ...) (map expand-clause clauses)))
|
||||
(with-syntax
|
||||
((form #'(lambda (x)
|
||||
docstring ... ; optional docstring
|
||||
#((macro-type . syntax-rules)
|
||||
(patterns pattern ...)) ; embed patterns as procedure metadata
|
||||
(syntax-case x (k ...)
|
||||
clause ...))))
|
||||
(if dots
|
||||
(with-syntax ((dots dots))
|
||||
#'(with-ellipsis dots form))
|
||||
#'form))))
|
||||
(syntax-case xx ()
|
||||
((_ (k ...) ((keyword . pattern) template) ...)
|
||||
#'(lambda (x)
|
||||
;; embed patterns as procedure metadata
|
||||
#((macro-type . syntax-rules)
|
||||
(patterns pattern ...))
|
||||
(syntax-case x (k ...)
|
||||
((_ . pattern) #'template)
|
||||
...)))
|
||||
(expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
|
||||
((_ (k ...) docstring ((keyword . pattern) template) ...)
|
||||
(string? (syntax->datum #'docstring))
|
||||
#'(lambda (x)
|
||||
;; the same, but allow a docstring
|
||||
docstring
|
||||
#((macro-type . syntax-rules)
|
||||
(patterns pattern ...))
|
||||
(syntax-case x (k ...)
|
||||
((_ . pattern) #'template)
|
||||
...))))))
|
||||
(expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
|
||||
((_ dots (k ...) ((keyword . pattern) template) ...)
|
||||
(identifier? #'dots)
|
||||
(expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
|
||||
((_ dots (k ...) docstring ((keyword . pattern) template) ...)
|
||||
(and (identifier? #'dots) (string? (syntax->datum #'docstring)))
|
||||
(expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
|
||||
|
||||
(define-syntax define-syntax-rule
|
||||
(lambda (x)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;; Repl common routines
|
||||
|
||||
;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
|
||||
;; 2013 Free Software Foundation, Inc.
|
||||
;; 2013, 2014 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
|
||||
|
|
@ -41,7 +41,7 @@
|
|||
|
||||
(define *version*
|
||||
(format #f "GNU Guile ~A
|
||||
Copyright (C) 1995-2013 Free Software Foundation, Inc.
|
||||
Copyright (C) 1995-2014 Free Software Foundation, Inc.
|
||||
|
||||
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
|
||||
This program is free software, and you are welcome to redistribute it
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
;;;; hash.test --- test guile hashing -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012,
|
||||
;;;; 2014 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
|
||||
|
|
@ -36,7 +37,17 @@
|
|||
(pass-if (= 0 (hash noop 1)))
|
||||
(pass-if (= 0 (hash +inf.0 1)))
|
||||
(pass-if (= 0 (hash -inf.0 1)))
|
||||
(pass-if (= 0 (hash +nan.0 1))))
|
||||
(pass-if (= 0 (hash +nan.0 1)))
|
||||
(pass-if (= 0 (hash '#() 1)))
|
||||
|
||||
(pass-if "cyclic vectors"
|
||||
(let ()
|
||||
(define (cyclic-vector n)
|
||||
(let ((v (make-vector n)))
|
||||
(vector-fill! v v)
|
||||
v))
|
||||
(and (= 0 (hash (cyclic-vector 3) 1))
|
||||
(= 0 (hash (cyclic-vector 10) 1))))))
|
||||
|
||||
;;;
|
||||
;;; hashv
|
||||
|
|
|
|||
|
|
@ -1808,7 +1808,7 @@
|
|||
(pass-if (not (integer? (current-input-port)))))
|
||||
|
||||
;;;
|
||||
;;; integer?
|
||||
;;; exact-integer?
|
||||
;;;
|
||||
|
||||
(with-test-prefix "exact-integer?"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
|
||||
;;;; 2014 Free Software Foundation, Inc.
|
||||
;;;; Ludovic Courtès
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -410,6 +411,15 @@
|
|||
(not (or (port-has-port-position? port)
|
||||
(port-has-set-port-position!? port)))))
|
||||
|
||||
(pass-if-equal "custom binary input port supports `port-position', \
|
||||
not `set-port-position!'"
|
||||
42
|
||||
(let ((port (make-custom-binary-input-port "the port" (const 0)
|
||||
(const 42) #f #f)))
|
||||
(and (port-has-port-position? port)
|
||||
(not (port-has-set-port-position!? port))
|
||||
(port-position port))))
|
||||
|
||||
(pass-if "custom binary input port supports `port-position'"
|
||||
(let* ((str "Hello Port!")
|
||||
(source (open-bytevector-input-port
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010,
|
||||
;;;; 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; 2011, 2012, 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
|
||||
|
|
@ -19,6 +19,7 @@
|
|||
|
||||
(define-module (test-suite test-syntax)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 local-eval)
|
||||
#:use-module (test-suite lib))
|
||||
|
||||
|
||||
|
|
@ -1238,6 +1239,85 @@
|
|||
(r 'outer))
|
||||
#t)))
|
||||
|
||||
(with-test-prefix "syntax-rules"
|
||||
|
||||
(pass-if-equal "custom ellipsis within normal ellipsis"
|
||||
'((((a x) (a y) (a …))
|
||||
((b x) (b y) (b …))
|
||||
((c x) (c y) (c …)))
|
||||
(((a x) (b x) (c x))
|
||||
((a y) (b y) (c y))
|
||||
((a …) (b …) (c …))))
|
||||
(let ()
|
||||
(define-syntax foo
|
||||
(syntax-rules ()
|
||||
((_ y ...)
|
||||
(syntax-rules … ()
|
||||
((_ x …)
|
||||
'((((x y) ...) …)
|
||||
(((x y) …) ...)))))))
|
||||
(define-syntax bar (foo x y …))
|
||||
(bar a b c)))
|
||||
|
||||
(pass-if-equal "normal ellipsis within custom ellipsis"
|
||||
'((((a x) (a y) (a z))
|
||||
((b x) (b y) (b z))
|
||||
((c x) (c y) (c z)))
|
||||
(((a x) (b x) (c x))
|
||||
((a y) (b y) (c y))
|
||||
((a z) (b z) (c z))))
|
||||
(let ()
|
||||
(define-syntax foo
|
||||
(syntax-rules … ()
|
||||
((_ y …)
|
||||
(syntax-rules ()
|
||||
((_ x ...)
|
||||
'((((x y) …) ...)
|
||||
(((x y) ...) …)))))))
|
||||
(define-syntax bar (foo x y z))
|
||||
(bar a b c))))
|
||||
|
||||
(with-test-prefix "syntax-error"
|
||||
|
||||
(pass-if-syntax-error "outside of macro without args"
|
||||
"test error"
|
||||
(eval '(syntax-error "test error")
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-syntax-error "outside of macro with args"
|
||||
"test error x \\(y z\\)"
|
||||
(eval '(syntax-error "test error" x (y z))
|
||||
(interaction-environment)))
|
||||
|
||||
(pass-if-equal "within macro"
|
||||
'(simple-let
|
||||
"expected an identifier but got (z1 z2)"
|
||||
(simple-let ((y (* x x))
|
||||
((z1 z2) (values x x)))
|
||||
(+ y 1)))
|
||||
(catch 'syntax-error
|
||||
(lambda ()
|
||||
(eval '(let ()
|
||||
(define-syntax simple-let
|
||||
(syntax-rules ()
|
||||
((_ (head ... ((x . y) val) . tail)
|
||||
body1 body2 ...)
|
||||
(syntax-error
|
||||
"expected an identifier but got"
|
||||
(x . y)))
|
||||
((_ ((name val) ...) body1 body2 ...)
|
||||
((lambda (name ...) body1 body2 ...)
|
||||
val ...))))
|
||||
(define (foo x)
|
||||
(simple-let ((y (* x x))
|
||||
((z1 z2) (values x x)))
|
||||
(+ y 1)))
|
||||
foo)
|
||||
(interaction-environment))
|
||||
(error "expected syntax-error exception"))
|
||||
(lambda (k who what where form . maybe-subform)
|
||||
(list who what form)))))
|
||||
|
||||
(with-test-prefix "syntax-case"
|
||||
|
||||
(pass-if-syntax-error "duplicate pattern variable"
|
||||
|
|
@ -1291,6 +1371,71 @@
|
|||
((x ... y ... z ...) #f)))
|
||||
(interaction-environment)))))
|
||||
|
||||
(with-test-prefix "with-ellipsis"
|
||||
|
||||
(pass-if-equal "simple"
|
||||
'(a 1 2 3)
|
||||
(let ()
|
||||
(define-syntax define-quotation-macros
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (macro-name head-symbol) ...)
|
||||
#'(begin (define-syntax macro-name
|
||||
(lambda (x)
|
||||
(with-ellipsis …
|
||||
(syntax-case x ()
|
||||
((_ x …)
|
||||
#'(quote (head-symbol x …)))))))
|
||||
...)))))
|
||||
(define-quotation-macros (quote-a a) (quote-b b))
|
||||
(quote-a 1 2 3)))
|
||||
|
||||
(pass-if-equal "disables normal ellipsis"
|
||||
'(a ...)
|
||||
(let ()
|
||||
(define-syntax foo
|
||||
(lambda (x)
|
||||
(with-ellipsis …
|
||||
(syntax-case x ()
|
||||
((_)
|
||||
#'(quote (a ...)))))))
|
||||
(foo)))
|
||||
|
||||
(pass-if-equal "doesn't affect ellipsis for generated code"
|
||||
'(a b c)
|
||||
(let ()
|
||||
(define-syntax quotation-macro
|
||||
(lambda (x)
|
||||
(with-ellipsis …
|
||||
(syntax-case x ()
|
||||
((_)
|
||||
#'(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ x ...)
|
||||
#'(quote (x ...))))))))))
|
||||
(define-syntax kwote (quotation-macro))
|
||||
(kwote a b c)))
|
||||
|
||||
(pass-if-equal "propagates into syntax binders"
|
||||
'(a b c)
|
||||
(let ()
|
||||
(with-ellipsis …
|
||||
(define-syntax kwote
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ x …)
|
||||
#'(quote (x …))))))
|
||||
(kwote a b c))))
|
||||
|
||||
(pass-if-equal "works with local-eval"
|
||||
5
|
||||
(let ((env (with-ellipsis … (the-environment))))
|
||||
(local-eval '(syntax-case #'(a b c d e) ()
|
||||
((x …)
|
||||
(length #'(x …))))
|
||||
env))))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
|
||||
;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue