source: project/release/5/expand-full/trunk/tests/expand-full-test.scm @ 39009

Last change on this file since 39009 was 39009, checked in by Kon Lovett, 7 weeks ago

chicken.csi is missing, simplify

File size: 3.3 KB
Line 
1;;;; expand-full-test.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(import test)
5
6(test-begin "Expand Full")
7
8(import expand-full)
9
10;;;
11
12(import (chicken syntax))
13
14(define-syntax stream-match-pattern
15  (syntax-rules (_)
16    ((stream-match-pattern STRM () (BINDING ...) BODY)
17     (and (stream-null? STRM) (let (BINDING ...) BODY)))
18    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
19     (and (stream-pair? STRM)
20          (let ((STRM (stream-cdr STRM)))
21            (stream-match-pattern STRM REST (BINDING ...) BODY))))
22    ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
23     (and (stream-pair? STRM)
24          (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
25            (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
26    ((stream-match-pattern STRM _ (BINDING ...) BODY)
27     (let (BINDING ...) BODY))
28    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
29     (let ((VAR STRM) BINDING ...) BODY))))
30
31(define-syntax stream-match-test
32  (syntax-rules ()
33    ((stream-match-test STRM (PATTERN FENDER EXPR))
34     (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
35    ((stream-match-test STRM (PATTERN EXPR))
36     (stream-match-pattern STRM PATTERN () (list EXPR)))))
37
38(define-syntax stream-match
39  (syntax-rules ()
40    ((stream-match STRM-EXPR CLAUSE ...)
41     (let ((strm STRM-EXPR))
42       (cond ((not (stream? strm)) (error-invalid-stream 'stream-match strm))
43             ((stream-match-test strm CLAUSE) => car) ...
44             (else (error 'stream-match "pattern failure")))))))
45
46;csc : invalid syntax in macro form: (y . ys)
47;bug?
48
49(define expd-test-data-1
50  '(stream-match yy
51    (() (stream (stream x)))
52    ((y . ys)
53      (stream-append
54        (stream (stream-cons x yy))
55        (stream-map (lambda (z) (stream-cons y z))
56                    (stream-intersperse ys x))))))
57
58(define expd-test-result-1
59  '(##core#let
60    ((strm yy))
61    (##core#if
62      (not (stream? strm))
63      (##core#begin (error-invalid-stream (##core#quote stream-match) strm))
64      (##core#let
65        ((tmp (##core#if
66                (stream-null? strm)
67                (##core#let () (list (stream (stream x))))
68                #f)))
69        (##core#if
70          tmp
71          (car tmp)
72          (##core#let
73            ((tmp (##core#if
74                    (stream-pair? strm)
75                    (##core#let
76                      ((temp (stream-car strm)) (strm (stream-cdr strm)))
77                      (##core#let
78                        ((ys strm) (y temp))
79                        (list (stream-append
80                                (stream (stream-cons x yy))
81                                (stream-map
82                                  (##core#lambda (z) (stream-cons y z))
83                                  (stream-intersperse ys x))))))
84                    #f)))
85            (##core#if
86              tmp
87              (car tmp)
88              (##core#begin
89                (error (##core#quote stream-match) "pattern failure")))))))))
90
91(test-group "ppexpand*"
92  (print) (print "stream s-expr expand")
93  (ppexpand* expd-test-data-1)
94  ;(test "stream s-expr expand" expd-test-result-1 (strip-gensym (expand* expd-test-data-1)))
95
96  (print) (print "'(and a b) expand")
97  (ppexpand* '(and a b))
98  ;(test '(##core#if a b #f) (strip-gensym (expand* '(and a b))))
99)
100
101;;;
102
103(test-end "Expand Full")
104
105(test-exit)
Note: See TracBrowser for help on using the repository browser.