tests/psyntax.test

   1 #! /bin/sh
   2 # -*-scheme-*-
   3 echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@"
   4 #paredit:||
   5 exit $?
   6 !#
   7
   8 ;;; -*-scheme-*-
   9
  10 ;;; Mes --- Maxwell Equations of Software
  11 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
  12 ;;;
  13 ;;; This file is part of Mes.
  14 ;;;
  15 ;;; Mes is free software; you can redistribute it and/or modify it
  16 ;;; under the terms of the GNU General Public License as published by
  17 ;;; the Free Software Foundation; either version 3 of the License, or (at
  18 ;;; your option) any later version.
  19 ;;;
  20 ;;; Mes is distributed in the hope that it will be useful, but
  21 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;; GNU General Public License for more details.
  24 ;;;
  25 ;;; You should have received a copy of the GNU General Public License
  26 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  27
  28 (mes-use-module (mes base-0))
  29 (mes-use-module (mes base))
  30 (mes-use-module (mes quasiquote))
  31 (mes-use-module (mes let))
  32 (mes-use-module (srfi srfi-0))
  33 (mes-use-module (mes scm))
  34 (mes-use-module (mes psyntax-0))
  35 (mes-use-module (mes psyntax-pp))
  36 (mes-use-module (mes psyntax-1))
  37 (mes-use-module (mes test))
  38
  39 (pass-if "first dummy" #t)
  40 (pass-if-not "second dummy" #f)
  41
  42 (cond-expand
  43  (guile
  44   ;;(use-modules (ice-9 syncase))
  45   (define sc-expand identity)
  46   (define syntax-object->datum syntax->datum)
  47   (define datum->syntax-object datum->syntax)
  48   )
  49  (mes))
  50
  51 (when (not guile?)
  52  (pass-if "andmap"
  53    (seq? (andmap (lambda (x) (> x 0)) '(3 2 1)) #t))
  54
  55  (pass-if "andmap 2"
  56    (seq? (andmap (lambda (x) (> x 0)) '(3 2 1 0)) #f))
  57
  58  (pass-if "putprop" (putprop 'foo '*sc-expander 'bar))
  59
  60  (pass-if "getprop"
  61    (seq? (getprop 'foo '*sc-expander) 'bar))
  62  )
  63
  64 (pass-if "syntax-case"
  65   (sequal? (let* ((sexp '(syntax-case '((1 2) (3 4)) ()
  66                            (((x ...) ...) (syntax (x ... ...)))))
  67                   (expanded (sc-expand sexp)))
  68              (primitive-eval expanded))
  69            '(1 2 3 4)))
  70
  71 (pass-if "sc-expand"
  72   (sequal? (let ()
  73              (syntax-case '((1 2) (3 4)) ()
  74                (((x ...) ...) (syntax (x ... ...)))))
  75            '(1 2 3 4)))
  76
  77 (pass-if "syntax-object->datum"
  78   (sequal? (syntax-object->datum (syntax (set! a b)))
  79            '(set! a b)))
  80
  81 (pass-if "syntax-case swap!"
  82   (sequal? (syntax-object->datum
  83             (let ((exp '(set! a b)))
  84               (syntax-case exp ()
  85                 ((swap! a b)
  86                  (syntax
  87                   (let ((temp a))
  88                     (set! a b)
  89                     (set! b temp)))))))
  90            '(let ((temp a)) (set! a b) (set! b temp))))
  91
  92 (when (not guile?)
  93   (pass-if "syntax-case manual swap!"
  94     (sequal?
  95      (let* ((sc (sc-expand '(syntax-case exp () ((swap! a b) (syntax (let ((temp a)) (set! a b) (set! b temp)))))))
  96             (exp '(swap foo bar))
  97             (foo "foo")
  98             (bar "bar")
  99             (s (eval sc (current-module)))
 100             (d (syntax-object->datum s)))
 101        (eval d (current-module))
 102        (list foo bar))
 103      '("bar" "foo"))))
 104
 105 (pass-if "define-syntax swap! [syntax-case]"
 106   (sequal?
 107    (let ()
 108      (define-syntax swap!
 109        (lambda (exp)
 110          (syntax-case exp ()
 111            ((swap! a b)
 112             (syntax
 113              (let ((temp a))
 114                (set! a b)
 115                (set! b temp)))))))
 116      (let ((foo "foo")
 117            (bar "bar"))
 118        (swap! foo bar)
 119        (list foo bar)))
 120    (list "bar" "foo")))
 121
 122 (result 'report)
 123