Added SRFI 147 (custom macro transformers), part of ticket #804.

lib/SRFI/srfi/147.body.scm

@@ -0,0 +1,149 @@
+;; Copyright (C) Marc Nieper-Wißkirchen (2016). All Rights Reserved. 
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(scheme-define-syntax :continuation
+ (scheme-syntax-rules ()))
+
+(scheme-define-syntax expand-transformer
+ (scheme-syntax-rules (scheme-syntax-rules syntax-error begin)
+ ((expand-transformer (k ...) (scheme-syntax-rules . args))
+ (k ... (scheme-syntax-rules . args)))
+ ((expand-transformer (k ...) (syntax-error . args))
+ (syntax-error . args))
+ ((expand-transformer (k ...) (begin definition ... transformer-spec))
+ (begin definition
+ ...
+ (expand-transformer (k ...) transformer-spec))) 
+ ((expand-transformer (k ...) (keyword . args))
+ (keyword (:continuation expand-transformer (k ...)) . args))
+ ((expand-transformer (k ...) keyword)
+ (k ... (scheme-syntax-rules ()
+ ((_ . args) (keyword . args)))))))
+
+(scheme-define-syntax define-syntax
+ (scheme-syntax-rules ()
+ ((define-syntax name transformer-spec)
+ (expand-transformer (scheme-define-syntax name) transformer-spec))
+ ((define-syntax . _)
+ (syntax-error "invalid define-syntax syntax"))))
+
+(scheme-define-syntax let-syntax
+ (scheme-syntax-rules ()
+ ((let-syntax ((keyword transformer-spec) ...) body1 body2 ...)
+ (let ()
+ (let-syntax-aux (keyword ...) (transformer-spec ...) () (body1 body2 ...))))
+ ((let-syntax . _)
+ (syntax-error "invalid let-syntax syntax"))))
+
+(scheme-define-syntax let-syntax-aux
+ (scheme-syntax-rules ()
+ ((let-syntax-aux (keyword ...) () (transformer-spec ...) body*)
+ (scheme-let-syntax ((keyword transformer-spec) ...) . body*))
+ ((let-syntax-aux keyword* (transformer-spec1 transformer-spec2 ...) transformer-spec* body*)
+ (expand-transformer (let-syntax-aux keyword*
+ (transformer-spec2 ...)
+ transformer-spec*
+ body*)
+ transformer-spec1))
+ ((let-syntax-aux keyword*
+ (transformer-spec2 ...)
+ (transformer-spec ...)
+ body*
+ transformer-spec1)
+ (let-syntax-aux keyword*
+ (transformer-spec2 ...)
+ (transformer-spec ... transformer-spec1)
+ body*))))
+
+(scheme-define-syntax letrec-syntax
+ (scheme-syntax-rules ()
+ ((letrec-syntax ((keyword transformer-spec) ...) body1 body2 ...)
+ (let ()
+ (letrec-syntax-aux (keyword ...) (transformer-spec ...) () (body1 body2 ...))))
+ ((letrec-syntax . _)
+ (syntax-error "invalid letrec-syntax syntax"))))
+
+(scheme-define-syntax letrec-syntax-aux
+ (scheme-syntax-rules ()
+ ((letrec-syntax-aux (keyword ...) () (transformer-spec ...) body*)
+ (begin
+ (define-syntax keyword transformer-spec)
+ ...
+ (let () . body*)))
+ ((letrec-syntax-aux keyword*
+ (transformer-spec1 transformer-spec2 ...)
+ transformer-spec*
+ body*)
+ (expand-transformer (letrec-syntax-aux keyword*
+ (transformer-spec2 ...)
+ transformer-spec*
+ body*)
+ transformer-spec1))
+ ((letrec-syntax-aux keyword*
+ (transformer-spec2 ...)
+ (transformer-spec ...)
+ body*
+ transformer-spec1)
+ (letrec-syntax-aux keyword*
+ (transformer-spec2 ...)
+ (transformer-spec ... transformer-spec1)
+ body*))))
+
+(scheme-define-syntax syntax-rules
+ (scheme-syntax-rules (:continuation)
+ ((syntax-rules (:continuation k ...) . args)
+ (syntax-rules-aux "state0" (k ...) . args))
+ ((syntax-rules . _)
+ (syntax-error "invalid syntax-rules syntax"))))
+
+(scheme-define-syntax syntax-rules-aux
+ (scheme-syntax-rules ()
+ ((syntax-rules-aux "state0" k* (literal* ...) . rule*)
+ (syntax-rules-aux "state1" k* (... ...) ((literal* ... :continuation)) rule* () rule*))
+
+ ((syntax-rules-aux "state0" k* ellipsis (literal* ...) . rule*)
+ (syntax-rules-aux "state1" k* ellipsis (ellipsis (literal* ... :continuation))
+ rule* () rule*))
+
+ ((syntax-rules-aux "state1" (k ...) e (l ...) () (rule1* ...) rule2*)
+ (k ... (scheme-syntax-rules l ... rule1* ... . rule2*)))
+
+ ((syntax-rules-aux "state1" k* ::: l*
+ (((_ . pattern) template) . rule1*) (rule2 ...) rule3*)
+ (syntax-rules-aux "state1" k* ::: l* rule1*
+ (rule2
+ ...
+ ((_ (:continuation c :::) . pattern)
+ (c ::: template)))
+ rule3*))
+ ((syntax-rules-aux . _)
+ (syntax-error "invalid syntax-rules syntax"))))
+
+
+;; Local Variables:
+;; eval: (put 'scheme-define-syntax 'scheme-indent-function 'defun)
+;; eval: (put 'scheme-syntax-rules 'scheme-indent-function 'defun)
+;; eval: (put 'syntax-rules-aux 'scheme-indent-function 'defun)
+;; eval: (font-lock-add-keywords 'scheme-mode
+;; '(("(\\(scheme-define-syntax\\)\\>" 1 font-lock-keyword-face)
+;; ("(\\(scheme-syntax-rules\\)\\>" 1 font-lock-keyword-face)))
+;; End:

lib/SRFI/srfi/147.sld

@@ -0,0 +1,33 @@
+;; Copyright (C) Marc Nieper-Wißkirchen (2016). All Rights Reserved. 
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-library (srfi 147)
+ (export define-syntax
+ let-syntax
+ letrec-syntax
+ syntax-rules)
+ (import (rename (scheme base)
+ (syntax-rules scheme-syntax-rules)
+ (define-syntax scheme-define-syntax)
+ (let-syntax scheme-let-syntax)
+ (letrec-syntax scheme-letrec-syntax)))
+ (include "147.body.scm"))

lib/SRFI/test/srfi-147-test.sps7

@@ -0,0 +1,181 @@
+;; Copyright (C) Marc Nieper-Wißkirchen (2016). All Rights Reserved. 
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(define-library (srfi 147 test)
+ (export run-tests)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; (include-library-declarations "../../custom-macro-transformers.scm")
+
+ ;; Here are the declarations that would have been included:
+
+ (cond-expand
+ (custom-macro-transformers
+ (import (scheme base)))
+ (else
+ (import (except (scheme base)
+ define-syntax
+ let-syntax
+ letrec-syntax
+ syntax-rules))
+ (import (srfi 147))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (import (srfi 64))
+ (begin
+ (define (run-tests)
+ (test-begin "SRFI 147")
+
+ (test-group "R7RS macros"
+ (define-syntax foo
+ (syntax-rules ()
+ ((foo)
+ 42)))
+
+ (test-equal 42 (foo))
+
+ (test-equal 42 (let-syntax
+ ((foo
+ (syntax-rules ()
+ ((foo)
+ 42))))
+ (foo)))
+
+ (test-equal 42 (letrec-syntax
+ ((foo
+ (syntax-rules ()
+ ((foo)
+ 42)))
+ (bar
+ (syntax-rules ()
+ ((bar)
+ (foo)))))
+ (bar))))
+
+ (test-group "Custom macro transformers"
+ (define-syntax simple-syntax-rules
+ (syntax-rules ()
+ ((simple-syntax-rules . rules)
+ (syntax-rules () . rules))))
+
+ (define-syntax bar-rules
+ (simple-syntax-rules
+ ((bar-rules (pattern template) ...)
+ (simple-syntax-rules (pattern '(bar template)) ...))))
+
+ (define-syntax foo
+ (simple-syntax-rules
+ ((foo)
+ 42)))
+
+ (define-syntax bar
+ (bar-rules
+ ((bar x) x)))
+
+ (test-equal 42 (foo))
+
+ (test-equal 42 (let-syntax
+ ((foo
+ (simple-syntax-rules
+ ((foo)
+ 42))))
+ (foo)))
+
+ (test-equal '(bar 42) (bar 42)))
+
+ (test-group "Auxiliary definitions in custom macro transformers"
+ (define-syntax my-macro-transformer
+ (syntax-rules ()
+ ((my-macro-transformer)
+ (begin (define foo 2)
+ (syntax-rules ()
+ ((_) foo))))))
+
+ (test-equal 42 (* 21 (letrec-syntax ((foo (my-macro-transformer)))
+ (foo)))))
+
+ (test-group "Scoping of expansion"
+ (define-syntax simple-syntax-rules
+ (syntax-rules ()
+ ((simple-syntax-rules . rules)
+ (syntax-rules () . rules))))
+
+ (test-equal 'foo (let-syntax
+ ((simple-syntax-rules
+ (simple-syntax-rules ((_) 'foo))))
+ (simple-syntax-rules))))
+
+ (test-group "Custom ellipsis"
+ (define-syntax my-syntax-rules
+ (syntax-rules !!! ()
+ ((my-syntax-rules e l* rule !!!)
+ (syntax-rules e l* rule !!!))))
+
+ (define-syntax foo
+ (my-syntax-rules ::: ()
+ ((foo a) 'a)
+ ((foo a b) '(a . b)) 
+ ((foo a :::) (list 'a :::))))
+
+ (test-equal '(a b c) (foo a b c)))
+
+ (test-group "Aliases for keywords"
+ (define-syntax λ lambda)
+ (define foo (λ () 'baz))
+ (test-equal 'baz (foo)))
+
+ (test-group "Example from specification"
+ (define-syntax syntax-rules*
+ (syntax-rules ()
+ ((syntax-rules* (literal ...) (pattern . templates) ...)
+ (syntax-rules (literal ...) (pattern (begin . templates)) ...))
+ ((syntax-rules* ellipsis (literal ...) (pattern . templates) ...)
+ (syntax-rules ellipsis (literal ...) (pattern (begin . templates)) ...))))
+
+ (test-equal '(1 2) (let-syntax
+ ((foo
+ (syntax-rules* ()
+ ((foo a b)
+ (define a 1)
+ (define b 2)))))
+ (foo x y)
+ (list x y))))
+
+ (test-end))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(import (only (scheme base)
+ write-string flush-output-port current-output-port)
+ (srfi 147 test))
+
+(run-tests)
+
+;;; FIXME: Running the tests somehow gets the current output port
+;;; into such an unusual state that a write error occurs when the
+;;; normal exit process tries to flush its buffer. Anything that
+;;; flushes its buffer before exit avoids the error.
+
+(write-string "Done.\n")
+(flush-output-port (current-output-port))