Changeset 37954 in project


Ignore:
Timestamp:
10/09/19 21:10:38 (10 days ago)
Author:
Kon Lovett
Message:

add switch & named numeric value predicates, restructure test

Location:
release/5/moremacros/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/moremacros/trunk/moremacros.egg

    r37917 r37954  
    22
    33((synopsis "More misc macros")
    4  (version "2.0.0")
     4 (version "2.2.0")
    55 (category lang-exts)
    66 (author "[[kon lovett]]")
  • release/5/moremacros/trunk/moremacros.scm

    r37917 r37954  
    66
    77(;export
     8  switch
    89  ->boolean
    910  assure
     
    2425  (chicken base)
    2526  (chicken syntax)
    26   ;(only (chicken string) conc)
     27  (only (chicken string) ->string)
    2728  (only miscmacros repeat define-parameter))
    2829
     
    3637
    3738;;;
     39
     40;; (from moremacros select)
     41
     42(define-syntax switch
     43  (er-macro-transformer
     44    (lambda (frm ren cmp)
     45      (##sys#check-syntax 'switch frm '(_ _ . _))
     46      (let (
     47        (exp (cadr frm))
     48        (body (cddr frm))
     49        (tmp (ren 'tmp))
     50        (_else (ren 'else))
     51        (_or (ren 'or)) )
     52        `(let (
     53          (,tmp ,exp) )
     54          ,(let expd-form ((clauses body) (seen-else #f))
     55            (cond
     56              ((null? clauses)
     57                '(void) )
     58              ((not (pair? clauses))
     59                (syntax-error 'switch "invalid syntax" clauses) )
     60              (else
     61                (let (
     62                  (clause (car clauses))
     63                  (rclauses (cdr clauses)) )
     64                  (##sys#check-syntax 'switch clause '#(_ 1))
     65                  (cond
     66                    ((cmp _else (car clause))
     67                      (expd-form rclauses #t)
     68                      `(begin ,@(cdr clause)) )
     69                    (seen-else
     70                      (##sys#notice
     71                        "non-`else' clause following `else' clause in `switch'"
     72                        (strip-syntax clause))
     73                      (expd-form rclauses #t)
     74                      '(begin) )
     75                  (else
     76                    `(if
     77                      (,_or
     78                        ,@(map (lambda (x) `(equal? ,tmp ,x))
     79                        (car clause)))
     80                      (##core#begin
     81                        ,@(cdr clause))
     82                        ,(expd-form rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )
    3883
    3984;; Returns expression as #t or #f
     
    224269            ($grlaux$ (?name ?item ?ref (?body0 |:::|)) ?binds)) ) ) ) ) )
    225270
     271#; ;FIXME works in csi but not in hash-let compiled
     272(define-syntax define-reference-let
     273  (syntax-rules ()
     274    ((define-reference-let ?name ?ref)
     275      (letrec-syntax (
     276        ($grlaux$
     277          (syntax-rules |,,,| ()
     278            ;finished
     279            (($grlaux$ "gen" (?loc ?item ?ref (?body0 |,,,|)) (?var0 |,,,|) (?exp0 |,,,|) ())
     280              ((lambda (?var0 |,,,|) ?body0 |,,,|) ?exp0 |,,,|) )
     281            ;
     282            (($grlaux$ "gen" (?loc ?item ?ref ?body) (?var0 |,,,|) (?exp0 |,,,|) ((?var ?key ?def) ?tup0 |,,,|))
     283              ($grlaux$ "gen" (?loc ?item ?ref ?body)
     284                (?var ?var0 |,,,|) ((?ref ?item ?key ?def) ?exp0 |,,,|)
     285                (?tup0 |,,,|)) )
     286            ;all binds finished, generate
     287            (($grlaux$ "chk" ?cache ?tups ())
     288              ($grlaux$ "gen" ?cache () () ?tups) )
     289            ;
     290            (($grlaux$ "chk" ?cache (?tup0 |,,,|) ((?var ?key ?def) ?bnd0 |,,,|))
     291              ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 |,,,|) (?bnd0 |,,,|)) )
     292            ;
     293            (($grlaux$ "chk" ?cache (?tup0 |,,,|) ((?var ?key) ?bnd0 |,,,|))
     294              ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 |,,,|) (?bnd0 |,,,|)) )
     295            ;
     296            (($grlaux$ "chk" ?cache (?tup0 |,,,|) ((?var) ?bnd0 |,,,|))
     297              ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 |,,,|) (?bnd0 |,,,|)) )
     298            ;
     299            (($grlaux$ "chk" ?cache (?tup0 |,,,|) (?var ?bnd0 |,,,|))
     300              ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 |,,,|) (?bnd0 |,,,|)) )
     301            ;start
     302            (($grlaux$ ?cache ?bnds)
     303              ($grlaux$ "chk" ?cache () ?bnds) ) ) ) )
     304        (define-syntax ?name
     305          (syntax-rules |:::| ()
     306            ((?name ?item ?binds ?body0 |:::|)
     307              ($grlaux$ (?name ?item ?ref (?body0 |:::|)) ?binds)) ) ) ) ) ) )
     308
    226309;;
    227310
  • release/5/moremacros/trunk/numeric-macros.scm

    r37917 r37954  
    66
    77(;export
     8  ;
     9  one? two? three? four? five? six? seven? eight? nine? ten?
     10  ;
    811  ++
    912  --
     
    3033
    3134(import-for-syntax (only moremacros set!-op type-case))
     35
     36;;
     37
     38(define-syntax one? (syntax-rules () ((one? ?n) (= 1 ?n))))
     39(define-syntax two? (syntax-rules () ((two? ?n) (= 2 ?n))))
     40(define-syntax three? (syntax-rules () ((three? ?n) (= 3 ?n))))
     41(define-syntax four? (syntax-rules () ((four? ?n) (= 4 ?n))))
     42(define-syntax five? (syntax-rules () ((five? ?n) (= 5 ?n))))
     43(define-syntax six? (syntax-rules () ((six? ?n) (= 6 ?n))))
     44(define-syntax seven? (syntax-rules () ((seven? ?n) (= 7 ?n))))
     45(define-syntax eight? (syntax-rules () ((eight? ?n) (= 8 ?n))))
     46(define-syntax nine? (syntax-rules () ((nine? ?n) (= 9 ?n))))
     47(define-syntax ten? (syntax-rules () ((ten? ?n) (= 10 ?n))))
    3248
    3349;;
  • release/5/moremacros/trunk/tests/moremacros-test.scm

    r37917 r37954  
    55;;
    66
    7 (let ((a 1) (b 2))
    8   (test "swap! before" '(1 2) (list a b))
    9   (swap! a b)
    10   (test "swap! after" '(2 1) (list a b)) )
     7(test-group "switch"
     8  (test "switch" #t
     9    (switch '(foo)
     10      (("foo" 'foo)   'foo)
     11      (('(foo) 'foo)   #t)
     12      (else           #f)))
     13)
     14
     15(test-group "swap!"
     16  (let ((a 1) (b 2))
     17    (test "swap! before" '(1 2) (list a b))
     18    (swap! a b)
     19    (test "swap! after" '(2 1) (list a b)) )
     20)
    1121
    1222#;
    13 (test-group "Macro: swap-set!, fluid-set!, stiff-set!"
     23(test-group "swap-set!, fluid-set!, stiff-set!"
    1424  (let ((a 1) (b 2))
    1525    (test "swap-set! before" '(1 2) (list a b))
     
    2737)
    2838
    29 (test-group "Macro: set!-op"
     39(test-group "set!-op"
    3040  (let ((a 1) (b 2))
    3141    (set!-op a + 2 <> b)
     
    3343)
    3444
    35 (test-group "Macro: type-case"
     45(test-group "type-case"
    3646  (test 'numeric
    3747    (type-case 23
     
    5060(import numeric-macros)
    5161
    52 (test-group "Numeric"
     62(test-group "Numeric Macros"
    5363  (let ((ia 1) (fa 1.0))
    5464    (test 2 (fx++ ia))
     
    8595    (--! fa)
    8696    (test 1.0 fa) )
     97  (test-assert (seven? 7))
     98  (test-assert (not (seven? 5)))
    8799)
    88100
     
    91103(import hash-let srfi-69)
    92104
    93 (test-group "hash-let"
     105(test-group "Hash Let"
    94106  (define tbl (make-hash-table))
    95107
Note: See TracChangeset for help on using the changeset viewer.