diff options
-rw-r--r-- | doc/ref/api-macros.texi | 95 | ||||
-rw-r--r-- | doc/ref/guile.texi | 2 | ||||
-rw-r--r-- | libguile/hash.c | 2 | ||||
-rw-r--r-- | libguile/r6rs-ports.c | 17 | ||||
-rw-r--r-- | module/ice-9/command-line.scm | 4 | ||||
-rw-r--r-- | module/ice-9/local-eval.scm | 8 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 325 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 161 | ||||
-rw-r--r-- | module/system/repl/common.scm | 4 | ||||
-rw-r--r-- | test-suite/tests/hash.test | 15 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 2 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 12 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 147 |
13 files changed, 660 insertions, 134 deletions
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 07fde8f86..d4dbd8f79 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -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 diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index c3170ce46..c43873cff 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -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 diff --git a/libguile/hash.c b/libguile/hash.c index 740dac11f..0ac67fa1f 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -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 diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 3f936e71b..fc676895d 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -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'"); - - offset += scm_to_int (result); + "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 += 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; diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 7da0a6b15..b387eb350 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -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)) diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm index 493dbed0d..b81daf3e8 100644 --- a/module/ice-9/local-eval.scm +++ b/module/ice-9/local-eval.scm @@ -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 diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0684890ed..7ad8a7018 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -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) @@ -1849,6 +1871,30 @@ (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 (letrec* ((expand-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 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index cfcea4b26..f7c5c0ee6 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -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) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 0a38710af..f0e6e03a0 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -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 diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index ad247f50a..64d10bb38 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -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 diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index e91bc5240..847f93962 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1808,7 +1808,7 @@ (pass-if (not (integer? (current-input-port))))) ;;; -;;; integer? +;;; exact-integer? ;;; (with-test-prefix "exact-integer?" diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index d0ae9d395..abd5d6ff9 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -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 diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 8b8c9d954..4bde635d8 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -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: |