Changeset 29104 in project


Ignore:
Timestamp:
06/15/13 18:11:40 (8 years ago)
Author:
sjamaan
Message:

Implement syntax-rules in r7rs egg

Location:
release/4/r7rs/trunk
Files:
1 added
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/r7rs.scm

    r29030 r29104  
    11(module r7rs (define-library)
    22
    3   (import scheme)                       ;XXX except ...
     3  (import (except scheme syntax-rules))         ;XXX except ...
    44  (import chicken)                      ;XXX except ...
    55  (import numbers)
    66  (import scheme.base)
    7   (include "scheme.base-interface.scm") 
     7  (include "scheme.base-interface.scm")
    88
    99  (begin-for-syntax
  • release/4/r7rs/trunk/r7rs.setup

    r29029 r29104  
     1;; -*- Scheme -*-
    12(use make)
    2 
    33
    44(define scheme-modules
     
    88        (compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
    99        (compile -s -O3 -d0 r7rs-compile-time.import.scm))
    10        ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm")
     10       ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm"
     11                          "synrules.scm")
    1112        (compile -s -O3 -d1 scheme.base.scm -J)
    1213        (compile -s -O3 -d0 scheme.base.import.scm)))
  • release/4/r7rs/trunk/scheme.base-interface.scm

    r29049 r29104  
    3939  define
    4040  define-record-type
     41  |#
    4142  define-syntax
     43  #|
    4244  define-values
    4345  denominator numerator
     
    7981  import
    8082  #|
    81   ;; import-for-syntax   XXX should we?
     83  ;; import-for-syntax   XXX should we?  Probably not, it's not in r7rs...
    8284  include include-ci
    8385  |#
     
    9193  letrec letrec*
    9294  let-values let*-values
     95  |#
    9396  let-syntax
    9497  letrec-syntax
     98  #|
    9599  library                    ; for "cond-expand"
    96100  list
     
    162166  symbol?
    163167  syntax-error
    164   ;syntax-rules   XXX???
     168  |#
     169  syntax-rules
     170  #|
    165171  textual-port?
    166172  truncate
  • release/4/r7rs/trunk/scheme.base.scm

    r29092 r29104  
    11(module scheme.base ()
    22
    3 (import (except scheme cond-expand))
     3(import (except scheme syntax-rules cond-expand))
    44(import (except chicken with-exception-handler raise))
    55
     
    9696                    (apply values args))))))))))))))
    9797
     98;;;
     99;;; 5.4. Syntax definitions
     100;;;
     101(include "synrules.scm")
    98102
    99103;;;
  • release/4/r7rs/trunk/tests/run.scm

    r29092 r29104  
    11(use r7rs test)
     2
     3;; XXX: This seems to be necessary in order to get the syntax-rules
     4;; from r7rs rather than the built-in CHICKEN one.  I'm not sure if
     5;; that's correct or not...
     6(import-for-syntax r7rs)
    27
    38(define (read-from-string s)
     
    117122                   (close-port the-string-port)))))
    118123
     124;; This is for later. We can't define it inside a group because that
     125;; would make it locally scoped (as a letrec rewrite), which breaks
     126;; the syntax-rules underscore tests.  Very subtle (and annoying), this!
     127(define (_) 'underscore-procedure)
     128(define ___ 'triple-underscore-literal)
     129
     130(test-group "syntax-rules"
     131  (test "let-syntax w/ basic syntax-rules"
     132        100
     133        (let-syntax ((foo (syntax-rules ()
     134                            ((_ x form)
     135                             (let ((tmp x))
     136                               (if (number? tmp)
     137                                   form
     138                                   (error "not a number" tmp)))))))
     139          (foo 2 100)))
     140  (let-syntax ((foo (syntax-rules ()
     141                      ((_ #(a ...)) (list a ...)))))
     142    (test "Basic matching of vectors"
     143          '(1 2 3) (foo #(1 2 3))))
     144  ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
     145  (let-syntax ((foo (syntax-rules ()
     146                      ((_ (a b) ...)
     147                       (list 'first '(a b) ...))
     148                      ((_ a ...)
     149                       (list 'second '(a) ...)))))
     150    (test "Basic ellipsis match"
     151          '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
     152    (test "Ellipsis match of length 1 does not match length 2"
     153          '(second (1)) (foo 1))
     154    (test "Ellipsis match of lists with mismatched lengths (used to fail)"
     155          '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
     156
     157  (test "letrec-syntax"
     158        34
     159        (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
     160                        (bar (syntax-rules () ((_ x) (+ x 1)))))
     161          (foo 33)))
     162  (test "Basic hygienic rename of syntactic keywords"
     163        'now
     164        (let-syntax ((when (syntax-rules ()
     165                             ((when test stmt1 stmt2 ...)
     166                              (if test
     167                                  (begin stmt1
     168                                         stmt2 ...))))))
     169          (let ((if #t))
     170            (when if (set! if 'now))
     171            if)))
     172  (test "Basic hygienic rename of shadowed outer let"
     173        'outer
     174        (let ((x 'outer))
     175          (let-syntax ((m (syntax-rules () ((m) x))))
     176            (let ((x 'inner))
     177              (m)))))
     178  (test "Simple recursive letrec expansion"
     179        7
     180        (letrec-syntax
     181            ((my-or (syntax-rules ()
     182                      ((my-or) #f)
     183                      ((my-or e) e)
     184                      ((my-or e1 e2 ...)
     185                       (let ((temp e1))
     186                         (if temp
     187                             temp
     188                             (my-or e2 ...)))))))
     189          (let ((x #f)
     190                (y 7)
     191                (temp 8)
     192                (let odd?)
     193                (if even?))
     194            (my-or x
     195                   (let temp)
     196                   (if y)
     197                   y))))
     198  ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
     199  (let ((a 1))
     200    (letrec-syntax
     201        ((foo (syntax-rules ()
     202                ((_ b)
     203                 (bar a b))))
     204         (bar (syntax-rules ()
     205                ((_ c d)
     206                 (cons c (let ((c 3))
     207                           (list d c 'c)))))))
     208      (let ((a 2))
     209        (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
     210  (let-syntax
     211      ((foo (syntax-rules ()
     212              ((_)
     213               '#(b)))))
     214    (test "Quoted symbols inside vectors are stripped of syntactic info"
     215          '#(b) (foo)))
     216  (let-syntax ((kw (syntax-rules (baz)
     217                     ((_ baz) "baz")
     218                     ((_ any) "no baz"))))
     219    (test "syntax-rules keywords match" "baz" (kw baz))
     220    (test "syntax-rules keywords no match" "no baz" (kw xxx))
     221    (let ((baz 100))
     222      (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
     223  (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
     224        'ok
     225        (let ((=> #f))
     226          (cond (#t => 'ok))))
     227  (test "Nested identifier shadowing works correctly"
     228        '(3 4)
     229        (let ((foo 3))
     230          (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
     231            (let ((foo 4))
     232              (bar foo)))))
     233  (let-syntax ((c (syntax-rules ()
     234                    ((_)
     235                     (let ((x 10))
     236                       (let-syntax ((z (syntax-rules ()
     237                                         ((_) (quote x)))))
     238                         (z))))))
     239               (c2 (syntax-rules ()
     240                     ((_)
     241                      (let ((x 10))
     242                        (let-syntax
     243                            ((z (syntax-rules ()
     244                                  ((_) (let-syntax
     245                                           ((w (syntax-rules ()
     246                                                 ((_) (quote x)))))
     247                                         (w))))))
     248                          (z)))))))
     249    ;; Reported by Matthew Flatt
     250    (test "strip-syntax cuts across three levels of syntax"
     251          "x" (symbol->string (c)))
     252    (test "strip-syntax cuts across four levels of syntax"
     253          "x" (symbol->string (c2))))
     254  (let-syntax ((foo (syntax-rules
     255                        ___ ()
     256                        ((_ vals ___) (list '... vals ___)))))
     257    (test "Alternative ellipsis (from SRFI-46)"
     258          '(... 1 2 3) (foo 1 2 3)))
     259  (let-syntax ((let-alias (syntax-rules
     260                              ___ ()
     261                              ((_ new old code ___)
     262                               (let-syntax
     263                                   ((new
     264                                     (syntax-rules ()
     265                                       ((_ args ...) (old args ...)))))
     266                                 code ___)))))
     267    (let-alias inc (lambda (x) (+ 1 x))
     268               (test "Ellipsis rules are reset in new macro expansion phase"
     269                     3 (inc 2))))
     270  (let-syntax ((foo (syntax-rules ()
     271                      ((_ (a ... b) ... (c d))
     272                       (list (list (list a ...) ... b ...) c d))
     273                      ((_ #(a ... b) ... #(c d) #(e f))
     274                       (list (list (vector a ...) ... b ...) c d e f))
     275                      ((_ #(a ... b) ... #(c d))
     276                       (list (list (vector a ...) ... b ...) c d)))))
     277    (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
     278      (test '(() 1 2) (foo (1 2)))
     279      (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
     280      (test '(((1 2) (4) 3 5) 6 7)
     281            (foo (1 2 3) (4 5) (6 7)))
     282      (test '(() 1 2)
     283            (foo #(1 2)))
     284      (test '((#() 1) 2 3)
     285            (foo #(1) #(2 3)))
     286      (test '((#(1 2) 3) 4 5)
     287            (foo #(1 2 3) #(4 5)))
     288      (test '((#(1 2) 3) 4 5 6 7)
     289            (foo #(1 2 3) #(4 5) #(6 7)))
     290      (test '(() 1 2 3 4)
     291            (foo #(1 2) #(3 4)))
     292      (test '((#(1) 2) 3 4 5 6)
     293            (foo #(1 2) #(3 4) #(5 6)))
     294      (test '((#(1 2) #(4) 3 5) 6 7 8 9)
     295            (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
     296  (let-syntax ((foo (syntax-rules ()
     297                      ((_ #((a) ...)) (list a ...)))))
     298    (test "Bug discovered during implementation of rest patterns"
     299          '(1)
     300          (foo #((1)))))
     301  ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
     302  ;; occurrances of <ellipsis> inside the template.
     303  (let-syntax ((be-like-begin
     304                (syntax-rules ()
     305                  ((be-like-begin name)
     306                   (define-syntax name
     307                     (syntax-rules ()
     308                       ((name expr (... ...))
     309                        (begin expr (... ...)))))))))
     310    (be-like-begin sequence)
     311    (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
     312          4 (sequence 1 2 3 4)))
     313  (let-syntax ((ignore-underscores
     314                (syntax-rules ()
     315                  ((_ _ _ _) (_)))))
     316    (test "underscores are ignored in patterns"
     317          'underscore-procedure (ignore-underscores _ b c)))
     318
     319  (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
     320    (test-group "underscore as keyword literal"
     321      (define-syntax match-literal-underscores ; for eval
     322        (syntax-rules (_)
     323          ((x a _ c) (_))
     324          ((x _ b c) 1)))
     325      (test-error "Missing literal underscore keyword causes syntax-error"
     326                  (eval '(match-literal-underscores d e f)))
     327      (test "Literal underscore matches"
     328            1 (match-literal-underscores _ h i))
     329      (test "Literal underscore matches even if it refers to toplevel binding"
     330            'underscore-procedure (match-literal-underscores g _ i)))
     331   
     332    (test-group "underscore as ellipsis"
     333     ;; It's undefined what this should do.  Logically, it should be
     334     ;; possible to bind _ as an ellipsis identifier.
     335     (define-syntax match-ellipsis-underscores ; for eval
     336       (syntax-rules _ () ((x a _ c) (list a _ c))))
     337     (test-error "No rule matching if prefix is omitted"
     338                 (eval '(match-ellipsis-underscores)))
     339     (test "Only prefix is supplied"
     340           '(1) (match-ellipsis-underscores 1))
     341     (test "Ellipsis does its work if multiple arguments given"
     342           '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
     343
     344    (test-group "underscore as ellipsis mixed with underscore literal"
     345      ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
     346      ;; Currently, ellipsis identifiers have precedence over the other two.
     347      (define-syntax match-ellipsis-and-literals-underscores ; for eval
     348        (syntax-rules _ (_) ((x a _ c) (list a _ c))))
     349      (test-error "No rule matching if prefix is omitted"
     350                  (eval '(match-ellipsis-and-literals-underscores)))
     351      (test '(1) (match-ellipsis-and-literals-underscores 1))
     352      (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
     353      (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
     354
     355    (test-group "\"custom\" ellipsis and literal of the same identifier"
     356      ;; This is similar to the above, but maybe a little simpler because
     357      ;; it does not use reserved names:
     358      (define-syntax match-ellipsis-literals
     359        (syntax-rules ___ (___)
     360                      ((_ x ___) (list x ___))))
     361      (test "Ellipsis as literals"
     362            '(1) (match-ellipsis-literals 1))
     363      (test "Ellipsis as literals multiple args"
     364            '(1 2) (match-ellipsis-literals 1 2))
     365      (test "Toplevel binding of the same name as ellipsis"
     366            '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
     367
     368  (letrec-syntax ((usetmp
     369                   (syntax-rules ()
     370                     ((_ var)
     371                      (list var))))
     372                  (withtmp
     373                   (syntax-rules ()
     374                     ((_ val exp)
     375                      (let ((tmp val))
     376                        (exp tmp))))))
     377    (test "Passing a macro as argument to macro"
     378          '(99)
     379          (withtmp 99 usetmp)))
     380
     381  ;; renaming of keyword argument (#277)
     382  (let-syntax ((let-hello-proc
     383                (syntax-rules ()
     384                  ((_ procname code ...)
     385                   (let ((procname (lambda (#!key (who "world"))
     386                                     (string-append "hello, " who))))
     387                     code ...)))))
     388    (let-hello-proc bar
     389         ;; This is not R7RS, but R7RS should not interfere with other
     390         ;; CHICKEN features!
     391         (test "DSSSL keyword arguments aren't renamed (not R7RS)"
     392               "hello, XXX" (bar who: "XXX")))))
     393
    119394(test-end "r7rs tests")
    120395
Note: See TracChangeset for help on using the changeset viewer.