Changeset 35259 in project for release


Ignore:
Timestamp:
03/08/18 01:51:34 (4 months ago)
Author:
kon
Message:

bump ver, dep make-reference-let & set!/op, add define-reference-let & set!-op, re-flow

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

Legend:

Unmodified
Added
Removed
  • release/4/moremacros/trunk/hash-let.scm

    r33907 r35259  
    22;;;; Kon Lovett, Aug '10
    33
    4 (module hash-let *
     4(module hash-let
     5
     6(;export
     7  hash-let)
    58
    69(import scheme chicken)
    7 (import srfi-69 moremacros)
     10(use srfi-69 moremacros)
    811
    912;;
    1013
    11 (make-reference-let hash-let hash-table-ref/default)
     14(define-reference-let hash-let hash-table-ref/default)
    1215
    1316) ;module hash-let
  • release/4/moremacros/trunk/moremacros.scm

    r34785 r35259  
    55
    66(;export
    7   (str# $conc$)
     7  (str# concatenate->string)
    88  ->boolean
    99  assure
     
    1313  fluid-set!
    1414  stiff-set!
    15   set!/op
    16   make-reference-let
    17   ;
     15  set!-op
     16  define-reference-let
    1817  warning-guard
    1918  checked-guard
     
    2221  define-checked-parameter
    2322  ;must export helper macro, otherwise "hangs" during expansion of generated macro
    24   $grlaux$)
     23  $grlaux$
     24  ;deperecated
     25  set!/op
     26  make-reference-let)
    2527
    2628(import scheme chicken)
    27 
    28 (import (only data-structures conc))
    29 (require-library data-structures)
    30 
    31 (import
     29(use
     30  (only data-structures conc)
    3231  (only miscmacros repeat define-parameter))
    33 (require-library miscmacros)
    3432
    3533;;; Helpers
     
    4341;; Expression templates
    4442
    45 (define $conc$ conc)
     43(define concatenate->string conc)
    4644
    4745(define-syntax str#
    4846  (ir-macro-transformer
    4947    (lambda (frm inj cmp)
    50       ; (str# "...#{...}...#---...")
    51       (let ((strp (open-input-string (cadr frm))))
    52         ; interpret w/ {} as ()
     48      ;(str# "...#{...}...#---...")
     49      (let (
     50        (strp (open-input-string (cadr frm))) )
     51        ;interpret w/ {} as ()
    5352        (parameterize ((parentheses-synonyms #t))
    5453          (let loop ((ls '()) (sl #f))
    55             ; output char
     54            ;output char
    5655            (define (out-char ch)
    57               (if sl (cons ch sl) (list ch)) )
    58             ; end of interp
     56              (if sl
     57                (cons ch sl)
     58                (list ch)) )
     59            ;end of interp
    5960            (define (end-str)
    60               (if sl (cons (list->string (reverse sl)) ls) ls) )
    61             ; in the '#
     61              (if sl
     62                (cons (list->string (reverse sl)) ls)
     63                ls) )
     64            ;in the '#
    6265            (define (sharp-body)
    63               (let ((ch (peek-char strp)))
     66              (let (
     67                (ch (peek-char strp)) )
    6468                (cond
    6569                  ((eof-object? ch)
    6670                    (loop ls sl) )
    67                   ; dup so identity
     71                  ;dup so identity
    6872                  ((char=? #\# ch)
    6973                    (begin
    7074                      (read-char strp) ;drop char
    7175                      (loop ls (out-char #\#)) ) )
    72                   ; begin special eval region
     76                  ;begin special eval region
    7377                  ((char=? #\{ #;#\} ch)
    7478                    (loop (cons (inj (car (read strp))) (end-str)) #f) )
    75                   ; end special eval region no matter what
     79                  ;end special eval region no matter what
    7680                  ;!!! we do not test for #\} !!!
    7781                  (else
    7882                    (loop (cons (inj (read strp)) (end-str)) #f) ) ) ) )
    79             ; in the '# or not
     83            ;in the '# or not
    8084            (let ((ch (read-char strp)))
    8185              (cond
    82                 ; were done
     86                ;were done
    8387                ((eof-object? ch)
    84                   `($conc$ ,@(reverse (end-str))) )
    85                 ; we're interpolating
     88                  `(concatenate->string ,@(reverse (end-str))) )
     89                ;we're interpolating
    8690                ((char=? #\# ch)
    8791                  (sharp-body) )
    88                 ; ordinary char
     92                ;ordinary char
    8993                (else
    9094                  (loop ls (out-char ch)) ) ) ) ) ) ) ) ) )
     
    9599  (syntax-rules ()
    96100    ((_ ?obj)
    97       (and ?obj
    98            #t) ) ) )
     101      (and
     102        ?obj
     103        #t) ) ) )
    99104
    100105;; Returns expression value or error
     
    103108  (syntax-rules ()
    104109    ((_ ?expr ?loc ?arg0 ...)
    105       (or ?expr
    106           (error ?loc ?arg0 ...)) ) ) )
     110      (or
     111        ?expr
     112        (error ?loc ?arg0 ...)) ) ) )
    107113
    108114;;
     
    111117(define-syntax reverse-literal-list
    112118  (syntax-rules ()
    113 
     119    ;
    114120    ((_)
    115121      '() )
    116 
     122    ;
    117123    ((_ ?elt)
    118124      (list ?elt) )
    119 
     125    ;
    120126    ((_ "aux" (?eltn ?eltn-1 ...))
    121127      (list ?eltn ?eltn-1 ...) )
    122 
     128    ;
    123129    ((_ "aux" (?elti-1 ?elti-2 ...) ?elti ?elti+1 ...)
    124130      (reverse-literal-list "aux" (?elti ?elti-1 ?elti-2 ...) ?elti+1 ...) )
    125 
     131    ;
    126132    ((_ ?elt0 ?elt1 ...)
    127133      (reverse-literal-list "aux" (?elt0) ?elt1 ...) ) ) )
     
    132138  (syntax-rules ()
    133139    ((_ ?condition ?body0 ...)
    134       (unless ?condition ?body0 ...) ) ) )
    135 
    136 ;;
    137 
    138 (define-syntax ($type-case$ f r c)
    139   (let ((loc (cadr f))
    140         (?expr (caddr f))
    141         (?forms (cdddr f)) )
    142     (let ((var (if (c (r 'type-case*) loc) 'it (gensym))))
    143       (define (make-type-pred typnam)
    144         `(,(make-identifier typnam #\?) ,var))
    145       `(,(r 'let) ((,var ,?expr))
    146          (,(r 'cond)
    147            ,@(let loop ((forms ?forms)
    148                         (lst '()))
    149               (if (null? forms) (reverse lst)
    150                 (let* ((tcase (car forms))
    151                        (typnam (car tcase))
    152                        (next (cdr forms)) )
    153                   (if (c (r 'else) typnam)
    154                     (if (null? next) (loop '() (cons (cons (r 'else) (cdr tcase)) lst))
    155                       (syntax-error loc "else form out of position" tcase) )
    156                     (loop (cdr forms)
     140      (unless ?condition
     141        ?body0 ...) ) ) )
     142
     143;;
     144
     145(define-syntax $type-case$
     146  (er-macro-transformer
     147    (lambda (exp ren cmp)
     148      (let (
     149        (?loc (cadr exp))
     150        (?expr (caddr exp))
     151        (?forms (cdddr exp)) )
     152        (let ((var (if (cmp (ren 'type-case*) ?loc) 'it (gensym))))
     153          ;
     154          (define (make-type-pred typnam)
     155            `(,(make-identifier typnam #\?) ,var) )
     156          ;
     157          `(,(ren 'let) ((,var ,?expr))
     158             (,(ren 'cond)
     159               ,@(let loop (
     160                  (forms ?forms)
     161                  (lst '()) )
     162                  (if (null? forms) (reverse lst)
     163                    (let* (
     164                      (tcase (car forms))
     165                      (typnam (car tcase))
     166                      (next (cdr forms)) )
     167                      (if (cmp (ren 'else) typnam)
     168                        (if (null? next)
     169                          (loop '() (cons (cons (ren 'else) (cdr tcase)) lst))
     170                          (syntax-error ?loc "else form out of position" tcase) )
     171                        (loop
     172                          (cdr forms)
    157173                          (cons
    158174                            (cons
     
    161177                                ((pair? typnam)   `(or ,@(map make-type-pred typnam)) )
    162178                                (else
    163                                   (syntax-error loc "invalid case" tcase) ) )
     179                                  (syntax-error ?loc "invalid case" tcase) ) )
    164180                              (cdr tcase))
    165                             lst)) ) ) ) ) ) ) ) ) )
     181                            lst)) ) ) ) ) ) ) ) ) ) ) )
    166182
    167183(define-syntax type-case
    168         (syntax-rules ()
    169                 ((_ ?expr (typ0 exp0 ...) ...)
     184  (syntax-rules ()
     185    ((_ ?expr (typ0 exp0 ...) ...)
    170186      ($type-case$ type-case ?expr (typ0 exp0 ...) ...) ) ) )
    171187
    172188(define-syntax type-case*
    173         (syntax-rules ()
    174                 ((_ ?expr (typ0 exp0 ...) ...)
     189  (syntax-rules ()
     190    ((_ ?expr (typ0 exp0 ...) ...)
    175191      ($type-case$ type-case* ?expr (typ0 exp0 ...) ...) ) ) )
    176192
     
    178194
    179195(define-syntax swap-set!
    180         (syntax-rules ()
    181                 ((_ ?a ?b)
    182       (let ((_tmp ?a))
    183        (set! ?a ?b)
    184        (set! ?b _tmp)) ) ) )
     196  (syntax-rules ()
     197    ((_ ?a ?b)
     198      (let (
     199        (tmp ?a) )
     200        (set! ?a ?b)
     201        (set! ?b tmp)) ) ) )
    185202
    186203;; Parallel chained set
    187204
    188205(define-syntax fluid-set!
    189         (syntax-rules ()
    190 
    191                 ((_ ?var ?val)
    192                   (set! ?var ?val) )
    193 
    194                 ((_ ?var ?val ?rest ...)
    195                   (let ((_tmp ?val))
    196                     (fluid-set! ?rest ...)
    197                     (set! ?var _tmp) ) ) ) )
     206  (syntax-rules ()
     207    ;
     208    ((_ ?var ?val)
     209      (set! ?var ?val) )
     210    ;
     211    ((_ ?var ?val ?rest ...)
     212      (let (
     213        (tmp ?val) )
     214        (fluid-set! ?rest ...)
     215        (set! ?var tmp) ) ) ) )
    198216
    199217;; Serial chained set (CL SETQ like)
    200218
    201219(define-syntax stiff-set!
    202         (syntax-rules ()
    203 
    204                 ((_ ?var ?val)
    205                   (set! ?var ?val) )
    206 
    207                 ((_ ?var ?val ?rest ...)
    208                   (begin
    209                     (set! ?var ?val)
    210                     (stiff-set! ?rest ...) ) ) ) )
     220  (syntax-rules ()
     221    ;
     222    ((_ ?var ?val)
     223      (set! ?var ?val) )
     224    ;
     225    ((_ ?var ?val ?rest ...)
     226      (begin
     227        (set! ?var ?val)
     228        (stiff-set! ?rest ...) ) ) ) )
    211229
    212230;; Assign the result of the operation on the variable to itself
    213231;; Like C var <op>= <args>
    214232
    215 #; ;too many ellipses: (?act1 ...)
    216 (define-syntax set!/op
    217         (syntax-rules ()
    218                 ((_ ?var ?op ?rest ...)
     233(define-syntax set!-op
     234  (syntax-rules ::: ()
     235    ((_ ?var ?op ?rest :::)
    219236      (letrec-syntax (
    220           ($build-call$
     237          (build-call-aux
    221238            (syntax-rules (<>)
    222 
     239              ((_ (?var #f) (?op ?act0 ...))
     240                (?op ?var ?act0 ...) )
     241              ;
     242              ((_ (?var #t) (?op ?act0 ...))
     243                (?op ?act0 ...) )
     244              ;
     245              ((_ (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
     246                (build-call-aux (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
     247              ;
     248              ((_ (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
     249                (build-call-aux (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) ) ) )
     250
     251          (build-call
     252            (syntax-rules (<>)
     253              ;
    223254              ((_ ?op ?var)
    224255                (?op ?var) )
    225 
    226               ((_ "aux" (?var #f) (?op ?act0 ...))
    227                 (?op ?var ?act0 ...) )
    228 
    229               ((_ "aux" (?var #t) (?op ?act0 ...))
    230                 (?op ?act0 ...) )
    231 
    232               ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
    233                 ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
    234 
    235               ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
    236                 ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )
    237 
     256              ;
    238257              ((_ ?op ?var <> ?arg0 ...)
    239                 ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )
    240 
     258                (build-call-aux (?var #t) (?op ?var) ?arg0 ...) )
     259              ;
    241260              ((_ ?op ?var ?arg0 ?arg1 ...)
    242                 ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
     261                (build-call-aux (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
    243262        ;
    244         (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) ) )
    245 
    246 (define-syntax $build-call$
    247   (syntax-rules (<>)
    248 
    249     ((_ ?op ?var)
    250       (?op ?var) )
    251 
    252     ((_ "aux" (?var #f) (?op ?act0 ...))
    253       (?op ?var ?act0 ...) )
    254 
    255     ((_ "aux" (?var #t) (?op ?act0 ...))
    256       (?op ?act0 ...) )
    257 
    258     ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
    259       ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
    260 
    261     ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
    262       ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )
    263 
    264     ((_ ?op ?var <> ?arg0 ...)
    265       ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )
    266 
    267     ((_ ?op ?var ?arg0 ?arg1 ...)
    268       ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) )
    269 
     263        (set! ?var (build-call ?op ?var ?rest :::)) ) ) ) )
     264
     265;deprecated
    270266(define-syntax set!/op
    271         (syntax-rules ()
    272                 ((_ ?var ?op ?rest ...)
    273                   (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) )
    274 
    275 ;;
    276 
    277 #; ;too many ellipses
    278 (define-syntax make-reference-let
    279   (syntax-rules ()
    280     ((_ ?name ?ref)
    281       (letrec-syntax (
    282           ;
    283           ($grlaux$
    284             (syntax-rules ()
    285 
    286               ;finished
    287               ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
    288                 ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )
    289 
    290               ;
    291               ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
    292                 ($grlaux$ "gen" (?loc ?item ?ref ?body)
    293                   (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
    294                   (?tup0 ...)) )
    295 
    296               ;all binds finished, generate
    297               ((_ "chk" ?cache ?tups ())
    298                 ($grlaux$ "gen" ?cache () () ?tups) )
    299 
    300               ;
    301               ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
    302                 ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )
    303 
    304               ;
    305               ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
    306                 ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )
    307 
    308               ;
    309               ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
    310                 ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    311 
    312               ;
    313               ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
    314                 ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    315 
    316               ;start
    317               ((_ ?cache ?bnds)
    318                 ($grlaux$ "chk" ?cache () ?bnds) ) ) ) )
    319         ;
    320         (define-syntax ?name
    321           (syntax-rules ::: ()
    322             ((_ ?item ?binds ?body0 :::)
    323               ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) ) )
     267  (syntax-rules ()
     268    ((_ ?var ?op ?rest ...)
     269      (set!-op ?var ?op ?rest ...) ) ) )
     270
     271;;
    324272
    325273(define-syntax $grlaux$
    326274  (syntax-rules ()
    327 
    328275    ;finished
    329276    ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
    330277      ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )
    331 
    332278    ;
    333279    ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
     
    335281        (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
    336282        (?tup0 ...)) )
    337 
    338283    ;all binds finished, generate
    339284    ((_ "chk" ?cache ?tups ())
    340285      ($grlaux$ "gen" ?cache () () ?tups) )
    341 
    342286    ;
    343287    ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
    344288      ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )
    345 
    346289    ;
    347290    ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
    348291      ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )
    349 
    350292    ;
    351293    ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
    352294      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    353 
    354295    ;
    355296    ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
    356297      ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
    357 
    358298    ;start
    359299    ((_ ?cache ?bnds)
    360300      ($grlaux$ "chk" ?cache () ?bnds) ) ) )
    361301
    362 (define-syntax make-reference-let
     302(define-syntax define-reference-let
    363303  (syntax-rules ()
    364304    ((_ ?name ?ref)
     
    368308            ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) )
    369309
    370 #;
     310;deperecated
    371311(define-syntax make-reference-let
    372   (er-macro-transformer
    373     (lambda (f r c)
    374       (##sys#check-syntax 'make-reference-let f '(_ symbol _))
    375       (let ((?name (cadr f))
    376             (?ref (caddr f)) )
    377         `(,(r 'define-syntax) ,?name
    378           (,(r 'syntax-rules) ()
    379             ((_ ?item ?binds ?body0 ...)
    380               (,(r '$grlaux$) (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )
    381 
    382 #;
    383 (define-syntax make-reference-let
    384   (ir-macro-transformer
    385     (lambda (f i c)
    386       (##sys#check-syntax 'make-reference-let f '(_ symbol _))
    387         (let ((?name (cadr f))
    388               (?ref (caddr f)) )
    389           `(define-syntax ,?name
    390             (syntax-rules ()
    391               ((_ ?item ?binds ?body0 ...)
    392                 ($grlaux$ (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )
     312  (syntax-rules ()
     313    ((_ ?name ?ref)
     314      (define-reference-let ?name ?ref) ) ) )
    393315
    394316;;
     
    398320    (lambda (frm rnm cmp)
    399321      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
    400       (let ((?getnam (cadr frm))
    401             (?typnam (caddr frm))
    402             (?body (cdddr frm))
    403             ;
    404             (_lambda (rnm 'lambda))
    405             (_if (rnm 'if))
    406             (_begin (rnm 'begin))
    407             (_warning-argument-type (rnm 'warning-argument-type)) )
    408         (let ((predname (make-identifier (symbol->string ?typnam) "?")))
     322      (let (
     323        (?getnam (cadr frm))
     324        (?typnam (caddr frm))
     325        (?body (cdddr frm))
     326        (_lambda (rnm 'lambda))
     327        (_if (rnm 'if))
     328        (_begin (rnm 'begin))
     329        (_warning-argument-type (rnm 'warning-argument-type)) )
     330        (let (
     331          (predname (make-identifier (symbol->string ?typnam) "?")) )
    409332          `(,_lambda (obj)
    410333            (,_if (,predname obj)
     
    418341    (lambda (frm rnm cmp)
    419342      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
    420       (let ((?locnam (cadr frm))
    421             (?typnam (caddr frm))
    422             (?body (cdddr frm))
    423             ;
    424             (_lambda (rnm 'lambda)) )
    425         (let ((chknam (make-identifier "check-" (symbol->string ?typnam))))
     343      (let (
     344        (?locnam (cadr frm))
     345        (?typnam (caddr frm))
     346        (?body (cdddr frm))
     347        (_lambda (rnm 'lambda)) )
     348        (let (
     349          (chknam (make-identifier "check-" (symbol->string ?typnam))) )
    426350          `(,_lambda (obj)
    427351            (,chknam ',?locnam obj)
     
    431355;;
    432356
    433 #; ;use miscmacros
    434 (define-syntax define-parameter
    435   (syntax-rules ()
    436     ((_ ?name ?init) (define ?name (make-parameter ?init)) )
    437     ((_ ?name ?init ?guard) (define ?name (make-parameter ?init ?guard)) ) ) )
    438 
    439357(define-syntax define-warning-parameter
    440358  (syntax-rules ()
  • release/4/moremacros/trunk/moremacros.setup

    r34785 r35259  
    55(verify-extension-name "moremacros")
    66
    7 (setup-shared-extension-module 'moremacros (extension-version "1.4.2"))
     7(setup-shared-extension-module 'moremacros (extension-version "1.5.0"))
    88
    9 (setup-shared-extension-module 'hash-let (extension-version "1.4.2"))
     9(setup-shared-extension-module 'hash-let (extension-version "1.5.0"))
    1010
    11 (setup-shared-extension-module 'numeric-macros (extension-version "1.4.2"))
     11(setup-shared-extension-module 'numeric-macros (extension-version "1.5.0"))
  • release/4/moremacros/trunk/tests/run.scm

    r25611 r35259  
    1 (use test)
    2 (use moremacros)
    3 (use hash-let srfi-69)
    4 (use numeric-macros)
    51
    6 (test-group "Macro: str#"
    7         (test "" (str# ""))
    8         (test "abc" (str# "abc"))
    9         (test "(+ 1 2) = 3" (str# "(+ 1 2) = #(+ 1 2)"))
    10         (test "(+ a b) = 3" (let ((a 1) (b 2)) (str# "(+ a b) = #(+ a b)")))
    11         (test "must have sharp (#) characters" (str# "must have sharp (##) characters"))
    12         (test "issues with #-expressions" (str# "issues with #(conc #\\# #\\- \"expressions\")"))
    13         (test "1:2" (let ((a 1) (b 2)) (str# "#(identity a):#(identity b)")))
    14         (test "2345" (str# "#(+ 23)#(+ 45)"))
    15         (test "23#45" (str# "#(+ 23)###(+ 45)"))
    16         (test "23:45" (str# "#(+ 23):#(+ 45)"))
    17   ;
    18         (test "" (str# ""))
    19         (test "abc" (str# "abc"))
    20         (test "(+ 1 2) = 3" (str# "(+ 1 2) = #{(+ 1 2)}"))
    21         (test "(+ a b) = 3" (let ((a 1) (b 2)) (str# "(+ a b) = #{(+ a b)}")))
    22         (test "must have sharp (#) characters" (str# "must have sharp (##) characters"))
    23         (test "issues with #-expressions" (str# "issues with #{(conc #\\# #\\- \"expressions\")}"))
    24         (test "1:2" (let ((a 1) (b 2)) (str# "#{a}:#{b}")))
    25         (test "2345" (str# "#{23}#{45}"))
    26         (test "23#45" (str# "#{23}###{45}"))
    27         (test "23:45" (str# "#{23}:#{45}"))
    28 )
     2(define EGG-NAME "moremacros")
    293
    30 (test-group "Macro: swap-set!, fluid-set!, stiff-set!"
    31   (let ((a 1) (b 2))
    32     ;(test '(1 2) (list a b))
    33     (swap-set! a b)
    34     (test '(2 1) (list a b)) )
    35   (let ((a 1) (b 2))
    36     ;(test '(1 2) (list a b))
    37     (fluid-set! a 23 b (+ a b))
    38     (test '(23 3) (list a b)) )
    39   (let ((a 1) (b 2))
    40     ;(test '(1 2) (list a b))
    41     (stiff-set! a 23 b (+ a b))
    42     (test '(23 25) (list a b)) )
    43 )
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    445
    45 (test-group "Macro: set!/op"
    46   (let ((a 1) (b 2))
    47     (set!/op a + 2 <> b)
    48     (test 5 a) )
    49 )
     6(use files)
    507
    51 (test-group "Macro: type-case"
    52   (test 'numeric
    53         (type-case 23
    54           ((symbol string char) 'symbolic)
    55           (number               'numeric)
    56           (else                 'otheric)))
    57   (test '(23 numeric)
    58         (type-case* 23
    59           ((symbol string char) (list it 'symbolic))
    60           (number               (list it 'numeric))
    61           (else                 (list it 'otheric))))
    62 )
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    6310
    64 (test-group "Numeric"
    65   (let ((ia 1) (fa 1.0))
    66     (test 2 (fx++ ia))
    67     (test 0 (fx-- ia))
    68     (test 2.0 (fp++ fa))
    69     (test 0.0 (fp-- fa))
    70     (test 2.0 (fl++ fa))
    71     (test 0.0 (fl-- fa))
    72     (test 2 (++ ia))
    73     (test 2.0 (++ fa))
    74     (test 0 (-- ia))
    75     (test 0.0 (-- fa)) )
    76   (let ((ia 1))
    77     (fx++! ia)
    78     (test 2 ia)
    79     (fx--! ia)
    80     (test 1 ia) )
    81   (let ((fa 1.0))
    82     (fp++! fa)
    83     (test 2.0 fa)
    84     (fp--! fa)
    85     (test 1.0 fa)
    86     (fl++! fa)
    87     (test 2.0 fa)
    88     (fl--! fa)
    89     (test 1.0 fa) )
    90   (let ((ia 1) (fa 1.0))
    91     (++! ia)
    92     (test 2 ia)
    93     (++! fa)
    94     (test 2.0 fa)
    95     (--! ia)
    96     (test 1 ia)
    97     (--! fa)
    98     (test 1.0 fa) )
    99 )
     11(define *args* (argv))
    10012
    101 (test-group "hash-let"
    102   (define tbl (make-hash-table))
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    10315
    104   (hash-table-set! tbl 'abc "commercial network")
    105   (hash-table-set! tbl "abc" "commercial network")
    106   (hash-table-set! tbl 'cbs "commercial network")
    107   (hash-table-set! tbl "cbs" "commercial network")
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    10824
    109   (hash-let tbl ((abc)
    110                  (cbs "cbs")
    111                  (pbs (string-append "p" "bs") #t)
    112                  tbs)
    113     (test "commercial network" abc)
    114     (test "commercial network" cbs)
    115     (test #t pbs)
    116     (test #f tbs) )
    117 )
     25;;;
    11826
    119 (test-exit)
     27(set! EGG-NAME (egg-name))
     28
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.