Changeset 33907 in project


Ignore:
Timestamp:
03/25/17 21:24:59 (3 months ago)
Author:
kon
Message:

add macros from variable-item

Location:
release/4/moremacros
Files:
8 edited
1 copied

Legend:

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

    r19352 r33907  
    44(module hash-let *
    55
    6   (import scheme chicken srfi-69 moremacros)
     6(import scheme chicken)
     7(import srfi-69 moremacros)
    78
    89;;
  • release/4/moremacros/tags/1.4.0/moremacros.scm

    r33410 r33907  
    44(module moremacros
    55
    6   (;export
    7     (str# $conc$)
    8     ->boolean
    9     assure
    10     whennot
    11     type-case type-case*
    12     swap-set!
    13     fluid-set!
    14     stiff-set!
    15     set!/op
    16     make-reference-let
    17     ;must export helper macro, otherwise "hangs" during expansion of generated macro
    18     $grlaux$)
    19 
    20   (import scheme chicken (only data-structures conc))
    21 
    22   (import-for-syntax
    23     (only miscmacros repeat))
     6(;export
     7  (str# $conc$)
     8  ->boolean
     9  assure
     10  whennot
     11  type-case type-case*
     12  swap-set!
     13  fluid-set!
     14  stiff-set!
     15  set!/op
     16  make-reference-let
     17  ;
     18  warning-guard
     19  checked-guard
     20  ;define-parameter
     21  define-warning-parameter
     22  define-checked-parameter
     23  ;must export helper macro, otherwise "hangs" during expansion of generated macro
     24  $grlaux$)
     25
     26(import scheme chicken)
     27
     28(import (only data-structures conc))
     29
     30(import-for-syntax
     31  (only miscmacros repeat define-parameter))
    2432
    2533;;; Helpers
     
    200208;; Like C var <op>= <args>
    201209
    202 ; had a problem w/ `let-syntax' version of below:
    203 ; Error: during expansion of (syntax-rules ...) - too many ellipses: (?act1 ...)
     210#; ;too many ellipses: (?act1 ...)
     211(define-syntax set!/op
     212        (syntax-rules ()
     213                ((_ ?var ?op ?rest ...)
     214      (letrec-syntax (
     215          ($build-call$
     216            (syntax-rules (<>)
     217
     218              ((_ ?op ?var)
     219                (?op ?var) )
     220
     221              ((_ "aux" (?var #f) (?op ?act0 ...))
     222                (?op ?var ?act0 ...) )
     223
     224              ((_ "aux" (?var #t) (?op ?act0 ...))
     225                (?op ?act0 ...) )
     226
     227              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
     228                ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
     229
     230              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
     231                ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )
     232
     233              ((_ ?op ?var <> ?arg0 ...)
     234                ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )
     235
     236              ((_ ?op ?var ?arg0 ?arg1 ...)
     237                ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
     238        ;
     239        (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) ) )
    204240
    205241(define-syntax $build-call$
     
    233269
    234270;;
     271
     272#; ;too many ellipses
     273(define-syntax make-reference-let
     274  (syntax-rules ()
     275    ((_ ?name ?ref)
     276      (letrec-syntax (
     277          ;
     278          ($grlaux$
     279            (syntax-rules ()
     280
     281              ;finished
     282              ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
     283                ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )
     284
     285              ;
     286              ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
     287                ($grlaux$ "gen" (?loc ?item ?ref ?body)
     288                  (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
     289                  (?tup0 ...)) )
     290
     291              ;all binds finished, generate
     292              ((_ "chk" ?cache ?tups ())
     293                ($grlaux$ "gen" ?cache () () ?tups) )
     294
     295              ;
     296              ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
     297                ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )
     298
     299              ;
     300              ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
     301                ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )
     302
     303              ;
     304              ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
     305                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
     306
     307              ;
     308              ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
     309                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
     310
     311              ;start
     312              ((_ ?cache ?bnds)
     313                ($grlaux$ "chk" ?cache () ?bnds) ) ) ) )
     314        ;
     315        (define-syntax ?name
     316          (syntax-rules ::: ()
     317            ((_ ?item ?binds ?body0 :::)
     318              ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) ) )
    235319
    236320(define-syntax $grlaux$
     
    303387                ($grlaux$ (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )
    304388
     389;;
     390
     391(define-syntax warning-guard
     392  (er-macro-transformer
     393    (lambda (frm rnm cmp)
     394      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
     395      (let ((?getnam (cadr frm))
     396            (?typnam (caddr frm))
     397            (?body (cdddr frm))
     398            ;
     399            (_lambda (rnm 'lambda))
     400            (_if (rnm 'if))
     401            (_begin (rnm 'begin))
     402            (_warning-argument-type (rnm 'warning-argument-type)) )
     403        (let ((predname (make-identifier (symbol->string ?typnam) "?")))
     404          `(,_lambda (obj)
     405            (,_if (,predname obj)
     406              (,_begin ,@?body obj)
     407              (,_begin
     408                (,_warning-argument-type ',?getnam obj ',?typnam)
     409                (,?getnam) ) ) ) ) ) ) ) )
     410
     411(define-syntax checked-guard
     412  (er-macro-transformer
     413    (lambda (frm rnm cmp)
     414      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
     415      (let ((?locnam (cadr frm))
     416            (?typnam (caddr frm))
     417            (?body (cdddr frm))
     418            ;
     419            (_lambda (rnm 'lambda)) )
     420        (let ((chknam (make-identifier "check-" (symbol->string ?typnam))))
     421          `(,_lambda (obj)
     422            (,chknam ',?locnam obj)
     423            ,@?body
     424            obj ) ) ) ) ) )
     425
     426;;
     427
     428#; ;use miscmacros
     429(define-syntax define-parameter
     430  (syntax-rules ()
     431    ((_ ?name ?init) (define ?name (make-parameter ?init)) )
     432    ((_ ?name ?init ?guard) (define ?name (make-parameter ?init ?guard)) ) ) )
     433
     434(define-syntax define-warning-parameter
     435  (syntax-rules ()
     436    ((_ ?name ?init ?typnam ?body0 ...)
     437      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )
     438
     439(define-syntax define-checked-parameter
     440  (syntax-rules ()
     441    ((_ ?name ?init ?typnam ?body0 ...)
     442      (define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
     443
    305444) ;module moremacros
  • release/4/moremacros/tags/1.4.0/moremacros.setup

    r33410 r33907  
    55(verify-extension-name "moremacros")
    66
    7 (setup-shared-extension-module 'moremacros (extension-version "1.3.2"))
     7(setup-shared-extension-module 'moremacros (extension-version "1.4.0"))
    88
    9 (setup-shared-extension-module 'hash-let (extension-version "1.3.2"))
     9(setup-shared-extension-module 'hash-let (extension-version "1.4.0"))
    1010
    11 (setup-shared-extension-module 'numeric-macros (extension-version "1.3.2"))
     11(setup-shared-extension-module 'numeric-macros (extension-version "1.4.0"))
  • release/4/moremacros/tags/1.4.0/numeric-macros.scm

    r25611 r33907  
    44(module numeric-macros
    55
    6   (;export
    7     ++
    8     --
    9     fx++
    10     fx--
    11     fp++
    12     fp--
    13     fl++
    14     fl--
    15     ++!
    16     --!
    17     fx++!
    18     fx--!
    19     fp++!
    20     fp--!
    21     fl++!
    22     fl--!)
     6(;export
     7  ++
     8  --
     9  fx++
     10  fx--
     11  fp++
     12  fp--
     13  fl++
     14  fl--
     15  ++!
     16  --!
     17  fx++!
     18  fx--!
     19  fp++!
     20  fp--!
     21  fl++!
     22  fl--!)
    2323
    24   (import scheme chicken)
     24(import scheme chicken)
    2525
    26   (import-for-syntax
    27     (only moremacros set!/op type-case))
     26(import-for-syntax
     27  (only moremacros set!/op type-case))
    2828
    2929;;
  • release/4/moremacros/trunk/hash-let.scm

    r19352 r33907  
    44(module hash-let *
    55
    6   (import scheme chicken srfi-69 moremacros)
     6(import scheme chicken)
     7(import srfi-69 moremacros)
    78
    89;;
  • release/4/moremacros/trunk/moremacros.scm

    r33410 r33907  
    44(module moremacros
    55
    6   (;export
    7     (str# $conc$)
    8     ->boolean
    9     assure
    10     whennot
    11     type-case type-case*
    12     swap-set!
    13     fluid-set!
    14     stiff-set!
    15     set!/op
    16     make-reference-let
    17     ;must export helper macro, otherwise "hangs" during expansion of generated macro
    18     $grlaux$)
    19 
    20   (import scheme chicken (only data-structures conc))
    21 
    22   (import-for-syntax
    23     (only miscmacros repeat))
     6(;export
     7  (str# $conc$)
     8  ->boolean
     9  assure
     10  whennot
     11  type-case type-case*
     12  swap-set!
     13  fluid-set!
     14  stiff-set!
     15  set!/op
     16  make-reference-let
     17  ;
     18  warning-guard
     19  checked-guard
     20  ;define-parameter
     21  define-warning-parameter
     22  define-checked-parameter
     23  ;must export helper macro, otherwise "hangs" during expansion of generated macro
     24  $grlaux$)
     25
     26(import scheme chicken)
     27
     28(import (only data-structures conc))
     29
     30(import-for-syntax
     31  (only miscmacros repeat define-parameter))
    2432
    2533;;; Helpers
     
    200208;; Like C var <op>= <args>
    201209
    202 ; had a problem w/ `let-syntax' version of below:
    203 ; Error: during expansion of (syntax-rules ...) - too many ellipses: (?act1 ...)
     210#; ;too many ellipses: (?act1 ...)
     211(define-syntax set!/op
     212        (syntax-rules ()
     213                ((_ ?var ?op ?rest ...)
     214      (letrec-syntax (
     215          ($build-call$
     216            (syntax-rules (<>)
     217
     218              ((_ ?op ?var)
     219                (?op ?var) )
     220
     221              ((_ "aux" (?var #f) (?op ?act0 ...))
     222                (?op ?var ?act0 ...) )
     223
     224              ((_ "aux" (?var #t) (?op ?act0 ...))
     225                (?op ?act0 ...) )
     226
     227              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) <> ?arg0 ...)
     228                ($build-call$ "aux" (?var #t) (?op ?act0 ?act1 ... ?var) ?arg0 ...) )
     229
     230              ((_ "aux" (?var ?flag) (?op ?act0 ?act1 ...) ?arg0 ?arg1 ...)
     231                ($build-call$ "aux" (?var ?flag) (?op ?act0 ?act1 ... ?arg0) ?arg1 ...) )
     232
     233              ((_ ?op ?var <> ?arg0 ...)
     234                ($build-call$ "aux" (?var #t) (?op ?var) ?arg0 ...) )
     235
     236              ((_ ?op ?var ?arg0 ?arg1 ...)
     237                ($build-call$ "aux" (?var #f) (?op ?arg0) ?arg1 ...) ) ) ) )
     238        ;
     239        (set! ?var ($build-call$ ?op ?var ?rest ...)) ) ) ) )
    204240
    205241(define-syntax $build-call$
     
    233269
    234270;;
     271
     272#; ;too many ellipses
     273(define-syntax make-reference-let
     274  (syntax-rules ()
     275    ((_ ?name ?ref)
     276      (letrec-syntax (
     277          ;
     278          ($grlaux$
     279            (syntax-rules ()
     280
     281              ;finished
     282              ((_ "gen" (?loc ?item ?ref (?body0 ...)) (?var0 ...) (?exp0 ...) ())
     283                ((lambda (?var0 ...) ?body0 ...) ?exp0 ...) )
     284
     285              ;
     286              ((_ "gen" (?loc ?item ?ref ?body) (?var0 ...) (?exp0 ...) ((?var ?key ?def) ?tup0 ...))
     287                ($grlaux$ "gen" (?loc ?item ?ref ?body)
     288                  (?var ?var0 ...) ((?ref ?item ?key ?def) ?exp0 ...)
     289                  (?tup0 ...)) )
     290
     291              ;all binds finished, generate
     292              ((_ "chk" ?cache ?tups ())
     293                ($grlaux$ "gen" ?cache () () ?tups) )
     294
     295              ;
     296              ((_ "chk" ?cache (?tup0 ...) ((?var ?key ?def) ?bnd0 ...))
     297                ($grlaux$ "chk" ?cache ((?var ?key ?def) ?tup0 ...) (?bnd0 ...)) )
     298
     299              ;
     300              ((_ "chk" ?cache (?tup0 ...) ((?var ?key) ?bnd0 ...))
     301                ($grlaux$ "chk" ?cache ((?var ?key #f) ?tup0 ...) (?bnd0 ...)) )
     302
     303              ;
     304              ((_ "chk" ?cache (?tup0 ...) ((?var) ?bnd0 ...))
     305                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
     306
     307              ;
     308              ((_ "chk" ?cache (?tup0 ...) (?var ?bnd0 ...))
     309                ($grlaux$ "chk" ?cache ((?var '?var #f) ?tup0 ...) (?bnd0 ...)) )
     310
     311              ;start
     312              ((_ ?cache ?bnds)
     313                ($grlaux$ "chk" ?cache () ?bnds) ) ) ) )
     314        ;
     315        (define-syntax ?name
     316          (syntax-rules ::: ()
     317            ((_ ?item ?binds ?body0 :::)
     318              ($grlaux$ (?name ?item ?ref (?body0 :::)) ?binds)) ) ) ) ) ) )
    235319
    236320(define-syntax $grlaux$
     
    303387                ($grlaux$ (,?name ?item ,?ref (?body0 ...)) ?binds)) ) ) ) ) ) )
    304388
     389;;
     390
     391(define-syntax warning-guard
     392  (er-macro-transformer
     393    (lambda (frm rnm cmp)
     394      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
     395      (let ((?getnam (cadr frm))
     396            (?typnam (caddr frm))
     397            (?body (cdddr frm))
     398            ;
     399            (_lambda (rnm 'lambda))
     400            (_if (rnm 'if))
     401            (_begin (rnm 'begin))
     402            (_warning-argument-type (rnm 'warning-argument-type)) )
     403        (let ((predname (make-identifier (symbol->string ?typnam) "?")))
     404          `(,_lambda (obj)
     405            (,_if (,predname obj)
     406              (,_begin ,@?body obj)
     407              (,_begin
     408                (,_warning-argument-type ',?getnam obj ',?typnam)
     409                (,?getnam) ) ) ) ) ) ) ) )
     410
     411(define-syntax checked-guard
     412  (er-macro-transformer
     413    (lambda (frm rnm cmp)
     414      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
     415      (let ((?locnam (cadr frm))
     416            (?typnam (caddr frm))
     417            (?body (cdddr frm))
     418            ;
     419            (_lambda (rnm 'lambda)) )
     420        (let ((chknam (make-identifier "check-" (symbol->string ?typnam))))
     421          `(,_lambda (obj)
     422            (,chknam ',?locnam obj)
     423            ,@?body
     424            obj ) ) ) ) ) )
     425
     426;;
     427
     428#; ;use miscmacros
     429(define-syntax define-parameter
     430  (syntax-rules ()
     431    ((_ ?name ?init) (define ?name (make-parameter ?init)) )
     432    ((_ ?name ?init ?guard) (define ?name (make-parameter ?init ?guard)) ) ) )
     433
     434(define-syntax define-warning-parameter
     435  (syntax-rules ()
     436    ((_ ?name ?init ?typnam ?body0 ...)
     437      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )
     438
     439(define-syntax define-checked-parameter
     440  (syntax-rules ()
     441    ((_ ?name ?init ?typnam ?body0 ...)
     442      (define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )
     443
    305444) ;module moremacros
  • release/4/moremacros/trunk/moremacros.setup

    r33410 r33907  
    55(verify-extension-name "moremacros")
    66
    7 (setup-shared-extension-module 'moremacros (extension-version "1.3.2"))
     7(setup-shared-extension-module 'moremacros (extension-version "1.4.0"))
    88
    9 (setup-shared-extension-module 'hash-let (extension-version "1.3.2"))
     9(setup-shared-extension-module 'hash-let (extension-version "1.4.0"))
    1010
    11 (setup-shared-extension-module 'numeric-macros (extension-version "1.3.2"))
     11(setup-shared-extension-module 'numeric-macros (extension-version "1.4.0"))
  • release/4/moremacros/trunk/numeric-macros.scm

    r25611 r33907  
    44(module numeric-macros
    55
    6   (;export
    7     ++
    8     --
    9     fx++
    10     fx--
    11     fp++
    12     fp--
    13     fl++
    14     fl--
    15     ++!
    16     --!
    17     fx++!
    18     fx--!
    19     fp++!
    20     fp--!
    21     fl++!
    22     fl--!)
     6(;export
     7  ++
     8  --
     9  fx++
     10  fx--
     11  fp++
     12  fp--
     13  fl++
     14  fl--
     15  ++!
     16  --!
     17  fx++!
     18  fx--!
     19  fp++!
     20  fp--!
     21  fl++!
     22  fl--!)
    2323
    24   (import scheme chicken)
     24(import scheme chicken)
    2525
    26   (import-for-syntax
    27     (only moremacros set!/op type-case))
     26(import-for-syntax
     27  (only moremacros set!/op type-case))
    2828
    2929;;
Note: See TracChangeset for help on using the changeset viewer.