test-suite/tests/srfi-105.test

   1 ;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2012 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-srfi-105)
  20   #:use-module (test-suite lib)
  21   #:use-module (srfi srfi-1))
  22
  23 (define (read-string s)
  24   (with-fluids ((%default-port-encoding #f))
  25     (with-input-from-string s read)))
  26
  27 (define (with-read-options opts thunk)
  28   (let ((saved-options (read-options)))
  29     (dynamic-wind
  30         (lambda ()
  31           (read-options opts))
  32         thunk
  33         (lambda ()
  34           (read-options saved-options)))))
  35
  36 ;; Verify that curly braces are allowed in identifiers and that neoteric
  37 ;; expressions are not recognized by default.
  38 (with-test-prefix "no-curly-infix"
  39   (pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
  40                    `(,(string->symbol "{f")
  41                      (x) + g [y] +
  42                      ,(string->symbol "h{z}")
  43                      + [a]
  44                      ,(string->symbol "}")))))
  45
  46 #!curly-infix
  47
  48 (with-test-prefix "curly-infix"
  49   (pass-if (equal? '{n <= 5}                '(<= n 5)))
  50   (pass-if (equal? '{x + 1}                 '(+ x 1)))
  51   (pass-if (equal? '{a + b + c}             '(+ a b c)))
  52   (pass-if (equal? '{x ,op y ,op z}         '(,op x y z)))
  53   (pass-if (equal? '{x eqv? `a}             '(eqv? x `a)))
  54   (pass-if (equal? '{'a eq? b}              '(eq? 'a b)))
  55   (pass-if (equal? '{n-1 + n-2}             '(+ n-1 n-2)))
  56   (pass-if (equal? '{a * {b + c}}           '(* a (+ b c))))
  57   (pass-if (equal? '{a + {b - c}}           '(+ a (- b c))))
  58   (pass-if (equal? '{{a + b} - c}           '(- (+ a b) c)))
  59   (pass-if (equal? '{{a > 0} and {b >= 1}}  '(and (> a 0) (>= b 1))))
  60   (pass-if (equal? '{}                      '()))
  61   (pass-if (equal? '{5}                     '5))
  62   (pass-if (equal? '{- x}                   '(- x)))
  63   (pass-if (equal? '{length(x) >= 6}        '(>= (length x) 6)))
  64   (pass-if (equal? '{f(x) + g(y) + h(z)}    '(+ (f x) (g y) (h z))))
  65   (pass-if (equal? '{(f a b) + (g h)}       '(+ (f a b) (g h))))
  66   (pass-if (equal? '{f(a b) + g(h)}         '(+ (f a b) (g h))))
  67   (pass-if (equal? ''{a + f(b) + x}         ''(+ a (f b) x)))
  68   (pass-if (equal? '{(- a) / b}             '(/ (- a) b)))
  69   (pass-if (equal? '{-(a) / b}              '(/ (- a) b)))
  70   (pass-if (equal? '{cos(q)}                '(cos q)))
  71   (pass-if (equal? '{e{}}                   '(e)))
  72   (pass-if (equal? '{pi{}}                  '(pi)))
  73   (pass-if (equal? '{'f(x)}                 '(quote (f x))))
  74
  75   (pass-if (equal? '{ (f (g h(x))) }        '(f (g (h x)))))
  76   (pass-if (equal? '{#(1 2 f(a) 4)}         '#(1 2 (f a) 4)))
  77   (pass-if (equal? '{ (f #;g(x) h(x)) }     '(f (h x))))
  78   (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x))))
  79   (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x))))
  80
  81   (pass-if (equal? '{ (f #(g h(x))) }       '(f #(g (h x)))))
  82   (pass-if (equal? '{ (f '(g h(x))) }       '(f '(g (h x)))))
  83   (pass-if (equal? '{ (f `(g h(x))) }       '(f `(g (h x)))))
  84   (pass-if (equal? '{ (f #'(g h(x))) }      '(f #'(g (h x)))))
  85   (pass-if (equal? '{ (f #2((g) (h(x)))) }  '(f #2((g) ((h x))))))
  86
  87   (pass-if (equal? '{(map - ns)}            '(map - ns)))
  88   (pass-if (equal? '{map(- ns)}             '(map - ns)))
  89   (pass-if (equal? '{n * factorial{n - 1}}  '(* n (factorial (- n 1)))))
  90   (pass-if (equal? '{2 * sin{- x}}          '(* 2 (sin (- x)))))
  91
  92   (pass-if (equal? '{3 + 4 +}               '($nfx$ 3 + 4 +)))
  93   (pass-if (equal? '{3 + 4 + 5 +}           '($nfx$ 3 + 4 + 5 +)))
  94   (pass-if (equal? '{a . z}                 '($nfx$ a . z)))
  95   (pass-if (equal? '{a + b - c}             '($nfx$ a + b - c)))
  96
  97   (pass-if (equal? '{read(. options)}       '(read . options)))
  98
  99   (pass-if (equal? '{a(x)(y)}               '((a x) y)))
 100   (pass-if (equal? '{x[a]}                  '($bracket-apply$ x a)))
 101   (pass-if (equal? '{y[a b]}                '($bracket-apply$ y a b)))
 102
 103   (pass-if (equal? '{f(g(x))}               '(f (g x))))
 104   (pass-if (equal? '{f(g(x) h(x))}          '(f (g x) (h x))))
 105
 106
 107   (pass-if (equal? '{}                      '()))
 108   (pass-if (equal? '{e}                     'e))
 109   (pass-if (equal? '{e1 e2}                 '(e1 e2)))
 110
 111   (pass-if (equal? '{a . t}                 '($nfx$ a . t)))
 112   (pass-if (equal? '{a b . t}               '($nfx$ a b . t)))
 113   (pass-if (equal? '{a b c . t}             '($nfx$ a b c . t)))
 114   (pass-if (equal? '{a b c d . t}           '($nfx$ a b c d . t)))
 115   (pass-if (equal? '{a + b +}               '($nfx$ a + b +)))
 116   (pass-if (equal? '{a + b + c +}           '($nfx$ a + b + c +)))
 117   (pass-if (equal? '{q + r * s}             '($nfx$ q + r * s)))
 118
 119   ;; The following two tests will become relevant when Guile's reader
 120   ;; supports datum labels, specified in SRFI-38 (External
 121   ;; Representation for Data With Shared Structure).
 122
 123   ;;(pass-if (equal? '{#1=f(#1#)}             '#1=(f #1#)))
 124   ;;(pass-if (equal? '#1={a + . #1#}          '($nfx$ . #1=(a + . #1#))))
 125
 126   (pass-if (equal? '{e()}                   '(e)))
 127   (pass-if (equal? '{e{}}                   '(e)))
 128   (pass-if (equal? '{e(1)}                  '(e 1)))
 129   (pass-if (equal? '{e{1}}                  '(e 1)))
 130   (pass-if (equal? '{e(1 2)}                '(e 1 2)))
 131   (pass-if (equal? '{e{1 2}}                '(e (1 2))))
 132   (pass-if (equal? '{f{n - 1}}              '(f (- n 1))))
 133   (pass-if (equal? '{f{n - 1}(x)}           '((f (- n 1)) x)))
 134   (pass-if (equal? '{f{n - 1}{y - 1}}       '((f (- n 1)) (- y 1))))
 135   (pass-if (equal? '{f{- x}[y]}             '($bracket-apply$ (f (- x)) y)))
 136   (pass-if (equal? '{g{- x}}                '(g (- x))))
 137   (pass-if (equal? '{( . e)}                'e))
 138
 139   (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
 140   (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
 141   (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
 142
 143   ;; Verify that source position information is not recorded if not
 144   ;; asked for.
 145   (with-test-prefix "no positions"
 146     (pass-if "simple curly-infix list"
 147       (let ((sexp (with-read-options '(curly-infix)
 148                     (lambda ()
 149                       (read-string " {1 + 2 + 3}")))))
 150         (and (not (source-property sexp 'line))
 151              (not (source-property sexp 'column)))))
 152     (pass-if "mixed curly-infix list"
 153       (let ((sexp (with-read-options '(curly-infix)
 154                     (lambda ()
 155                       (read-string " {1 + 2 * 3}")))))
 156         (and (not (source-property sexp 'line))
 157              (not (source-property sexp 'column)))))
 158     (pass-if "singleton curly-infix list"
 159       (let ((sexp (with-read-options '(curly-infix)
 160                     (lambda ()
 161                       (read-string " { 1.0 }")))))
 162         (and (not (source-property sexp 'line))
 163              (not (source-property sexp 'column)))))
 164     (pass-if "neoteric expression"
 165       (let ((sexp (with-read-options '(curly-infix)
 166                     (lambda ()
 167                       (read-string " { f(x) }")))))
 168         (and (not (source-property sexp 'line))
 169              (not (source-property sexp 'column))))))
 170
 171   ;; Verify that source position information is properly recorded.
 172   (with-test-prefix "positions"
 173     (pass-if "simple curly-infix list"
 174       (let ((sexp (with-read-options '(curly-infix positions)
 175                     (lambda ()
 176                       (read-string " {1 + 2 + 3}")))))
 177         (and (equal? (source-property sexp 'line) 0)
 178              (equal? (source-property sexp 'column) 1))))
 179     (pass-if "mixed curly-infix list"
 180       (let ((sexp (with-read-options '(curly-infix positions)
 181                     (lambda ()
 182                       (read-string " {1 + 2 * 3}")))))
 183         (and (equal? (source-property sexp 'line) 0)
 184              (equal? (source-property sexp 'column) 1))))
 185     (pass-if "singleton curly-infix list"
 186       (let ((sexp (with-read-options '(curly-infix positions)
 187                     (lambda ()
 188                       (read-string " { 1.0 }")))))
 189         (and (equal? (source-property sexp 'line) 0)
 190              (equal? (source-property sexp 'column) 3))))
 191     (pass-if "neoteric expression"
 192       (let ((sexp (with-read-options '(curly-infix positions)
 193                     (lambda ()
 194                       (read-string " { f(x) }")))))
 195         (and (equal? (source-property sexp 'line) 0)
 196              (equal? (source-property sexp 'column) 3)))))
 197
 198   ;; Verify that neoteric expressions are recognized only within curly braces.
 199   (pass-if (equal? '(a(x)(y))               '(a (x) (y))))
 200   (pass-if (equal? '(x[a])                  '(x [a])))
 201   (pass-if (equal? '(y[a b])                '(y [a b])))
 202   (pass-if (equal? '(a f{n - 1})            '(a f (- n 1))))
 203   (pass-if (equal? '(a f{n - 1}(x))         '(a f (- n 1) (x))))
 204   (pass-if (equal? '(a f{n - 1}[x])         '(a f (- n 1) [x])))
 205   (pass-if (equal? '(a f{n - 1}{y - 1})     '(a f (- n 1) (- y 1))))
 206
 207   ;; Verify that bracket lists are not recognized by default.
 208   (pass-if (equal? '{[]}                    '()))
 209   (pass-if (equal? '{[a]}                   '(a)))
 210   (pass-if (equal? '{[a b]}                 '(a b)))
 211   (pass-if (equal? '{[a . b]}               '(a . b)))
 212   (pass-if (equal? '[]                      '()))
 213   (pass-if (equal? '[a]                     '(a)))
 214   (pass-if (equal? '[a b]                   '(a b)))
 215   (pass-if (equal? '[a . b]                 '(a . b))))
 216
 217
 218 #!curly-infix-and-bracket-lists
 219
 220 (with-test-prefix "curly-infix-and-bracket-lists"
 221   ;; Verify that these neoteric expressions still work properly
 222   ;; when the 'square-brackets' read option is unset (which is done by
 223   ;; the '#!curly-infix-and-bracket-lists' reader directive above).
 224   (pass-if (equal? '{e[]}                   '($bracket-apply$ e)))
 225   (pass-if (equal? '{e[1 2]}                '($bracket-apply$ e 1 2)))
 226   (pass-if (equal? '{e[1 . 2]}              '($bracket-apply$ e 1 . 2)))
 227
 228   ;; The following expressions are not actually part of SRFI-105, but
 229   ;; they are handled when the 'curly-infix' read option is set and the
 230   ;; 'square-brackets' read option is unset.  This is a non-standard
 231   ;; extension of SRFI-105, and follows the convention of GNU Kawa.
 232   (pass-if (equal? '{[]}                    '($bracket-list$)))
 233   (pass-if (equal? '{[a]}                   '($bracket-list$ a)))
 234   (pass-if (equal? '{[a b]}                 '($bracket-list$ a b)))
 235   (pass-if (equal? '{[a . b]}               '($bracket-list$ a . b)))
 236
 237   (pass-if (equal? '[]                      '($bracket-list$)))
 238   (pass-if (equal? '[a]                     '($bracket-list$ a)))
 239   (pass-if (equal? '[a b]                   '($bracket-list$ a b)))
 240   (pass-if (equal? '[a . b]                 '($bracket-list$ a . b))))