Changeset 29545 in project


Ignore:
Timestamp:
08/08/13 14:30:41 (6 years ago)
Author:
juergen
Message:

define-macro now includes define-ir-macro and define-er-macro, which are no longer exported

Location:
release/4/list-bindings
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/list-bindings/tags/1.3/list-bindings.scm

    r29527 r29545  
    3939  (export list-bindings bind bindable? bind-case bind/cc
    4040          bind-let bind-let*
    41           define-er-macro define-ir-macro define-macro)
    42   (import scheme chicken)
     41          define-macro)
     42  (import scheme (only chicken condition-case error))
    4343
    4444 ;;; (bind pat list-xpr . body)
     
    5050  (ir-macro-transformer
    5151    (lambda (form inject compare?)
    52       (if (fx< (length form) 4)
    53         (error 'bind "macro-form doesn't match pattern "
     52      (if (< (length form) 4)
     53        (error 'bind "macro-code doesn't match pattern "
    5454               '(_ pat lst xpr . xprs))
    5555        (let ((pat (cadr form))
     
    179179  (ir-macro-transformer
    180180    (lambda (f i c?)
    181       (if (not (fx= (length f) 3))
    182         `(error 'define-ir-macro
    183                 "form doesn't match pattern"
    184                 '(_ macro-form inject-xpr))
    185         (let ((macro-form (cadr f))
    186               (inject-xpr (caddr f))
    187               (strip-suffix
    188                 (lambda (suf id)
    189                   (let ((sufstring (symbol->string suf))
    190                         (idstring (symbol->string id)))
    191                     (string->symbol
    192                       (substring idstring
    193                                  0
    194                                  (fx- (string-length idstring)
    195                                       (string-length sufstring))))))))
    196           (cond
    197             ((not (pair? macro-form))
    198              `(error 'define-ir-macro "not a macro form" ',macro-form))
    199             ((not (and (list? inject-xpr)
    200                        (fx= (length inject-xpr) 3)
    201                        (c? (car inject-xpr) 'injecting)
    202                        (list? (cadr inject-xpr))))
    203              `(error 'define-ir-macro "not an injecting expression"
    204                      ',inject-xpr))
    205             (else
    206               (let ((name (car macro-form))
    207                     (args (cdr macro-form))
    208                     (identifiers (cadr inject-xpr))
    209                     (compare-xpr (caddr inject-xpr)))
    210                 (if (not (and (list? compare-xpr)
    211                               (c? (car compare-xpr) 'comparing)
    212                               (list? (cadr compare-xpr))))
    213                   `(error 'define-ir-macro "not a comparing expression"
    214                           ',compare-xpr)
    215                   (let ((predicates (cadr compare-xpr))
    216                         (body (cddr compare-xpr)))
    217                     (cond
    218                       ((and (null? identifiers) (null? predicates))
    219                        `(define-syntax ,name
    220                           (ir-macro-transformer
    221                             (lambda (form inject compare?)
    222                               (bind ,args (cdr form) ,@body)))))
    223                       ((null? predicates)
    224                        `(define-syntax ,name
    225                           (ir-macro-transformer
    226                             (lambda (form inject compare?)
    227                               (bind ,args (cdr form)
    228                                 (bind ,identifiers (map inject ',identifiers)
    229                                   ,@body))))))
    230                       (else
    231                         (let ((suffix (car predicates))
    232                               (suffixed-keywords (cdr predicates)))
    233                           (let ((syms (map (lambda (id) (strip-suffix suffix id))
    234                                            suffixed-keywords)))
    235                             (if (null? identifiers)
    236                               `(define-syntax ,name
    237                                  (ir-macro-transformer
    238                                    (lambda (form inject compare?)
    239                                      (bind ,args (cdr form)
    240                                        (bind ,suffixed-keywords
    241                                          (list ,@(map (lambda (s)
    242                                                         `(lambda (n)
    243                                                            (compare? n ',(i s))))
    244                                                       syms))
    245                                          ,@body)))))
    246                               `(define-syntax ,name
    247                                  (ir-macro-transformer
    248                                    (lambda (form inject compare?)
    249                                      (bind ,args (cdr form)
    250                                        (bind ,identifiers (map inject ',identifiers)
    251                                          (bind ,suffixed-keywords
    252                                            (list ,@(map (lambda (s)
    253                                                           `(lambda (n)
    254                                                              (compare? n ',(i s))))
    255                                                         syms))
    256                                            ,@body)))))))))))))))))))))
     181      (let ((macro-code (cadr f))
     182            (inject-xpr (caddr f))
     183            (strip-suffix
     184              (lambda (suf id)
     185                (let ((sufstring (symbol->string suf))
     186                      (idstring (symbol->string id)))
     187                  (string->symbol
     188                    (substring idstring
     189                               0
     190                               (- (string-length idstring)
     191                                  (string-length sufstring))))))))
     192        (let ((name (car macro-code))
     193              (args (cdr macro-code))
     194              (identifiers (cadr inject-xpr))
     195              (compare-xpr (caddr inject-xpr)))
     196          (let ((predicates (cadr compare-xpr))
     197                (body (caddr compare-xpr)))
     198            (cond
     199              ((and (null? identifiers) (null? predicates))
     200               `(define-syntax ,name
     201                  (ir-macro-transformer
     202                    (lambda (form inject compare?)
     203                      (bind ,args (cdr form)
     204                        ,body)))))
     205              ((null? predicates)
     206               `(define-syntax ,name
     207                  (ir-macro-transformer
     208                    (lambda (form inject compare?)
     209                      (bind ,args (cdr form)
     210                        (bind ,identifiers (map inject ',identifiers)
     211                          ,body))))))
     212              (else
     213                (let ((suffix (car predicates))
     214                      (suffixed-keywords (cdr predicates)))
     215                  (let ((syms (map (lambda (id) (strip-suffix suffix id))
     216                                   suffixed-keywords)))
     217                    (if (null? identifiers)
     218                      `(define-syntax ,name
     219                         (ir-macro-transformer
     220                           (lambda (form inject compare?)
     221                             (bind ,args (cdr form)
     222                               (bind ,suffixed-keywords
     223                                 (list ,@(map (lambda (s)
     224                                                `(lambda (n)
     225                                                   (compare? n ',(i s))))
     226                                              syms))
     227                                 ,body)))))
     228                      `(define-syntax ,name
     229                         (ir-macro-transformer
     230                           (lambda (form inject compare?)
     231                             (bind ,args (cdr form)
     232                               (bind ,identifiers (map inject ',identifiers)
     233                                 (bind ,suffixed-keywords
     234                                   (list ,@(map (lambda (s)
     235                                                  `(lambda (n)
     236                                                     (compare? n ',(i s))))
     237                                                syms))
     238                                   ,body)))))))))))))))))
    257239
    258240;;; (define-er-macro (name . args)
     
    266248  (er-macro-transformer
    267249    (lambda (f r c?)
    268       (if (not (fx= (length f) 3))
    269         `(error 'define-er-macro
    270                 "macro-form doesn't match pattern"
    271                 '(_ macro-form rename-xpr))
    272         (let ((macro-form (cadr f))
    273               (rename-xpr (caddr f))
    274               (strip-prefix (lambda (pre id)
    275                               (string->symbol
    276                                 (substring (symbol->string id)
    277                                            (string-length
    278                                              (symbol->string pre))))))
    279               (strip-suffix
    280                 (lambda (suf id)
    281                   (let ((sufstring (symbol->string suf))
    282                         (idstring (symbol->string id)))
    283                     (string->symbol
    284                       (substring idstring
    285                                  0
    286                                  (fx- (string-length idstring)
    287                                       (string-length sufstring))))))))
    288           (cond
    289             ((not (pair? macro-form))
    290              `(error 'define-er-macro "not a macro form" ',macro-form))
    291             ((not (and (list? rename-xpr)
    292                        (fx= (length rename-xpr) 3)
    293                        (c? (car rename-xpr) (r 'renaming))
    294                        (pair? (cadr rename-xpr))))
    295              `(error 'define-er-macro "not a renaming expression"
    296                      ',rename-xpr))
    297             (else
    298               (let ((name (car macro-form))
    299                     (args (cdr macro-form))
    300                     (prefix (caadr rename-xpr))
    301                     (prefixed-identifiers (cdadr rename-xpr))
    302                     (compare-xpr (caddr rename-xpr)))
    303                 (if (not (and (list? compare-xpr)
    304                               (c? (car compare-xpr) (r 'comparing))
    305                               (list? (cadr compare-xpr))))
    306                   `(error 'define-er-macro "not a comparing expression"
    307                           ',compare-xpr)
    308                   (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
    309                                           prefixed-identifiers))
    310                         (predicates (cadr compare-xpr))
    311                         (body (cddr compare-xpr))
    312                         (%er-macro-transformer (r 'er-macro-transformer))
    313                         (%define-syntax (r 'define-syntax))
    314                         (%compare? (r 'compare?))
    315                         (%rename (r 'rename))
    316                         (%lambda (r 'lambda))
    317                         (%bind (r 'bind))
    318                         (%list (r 'list))
    319                         (%form (r 'form))
    320                         (%cdr (r 'cdr))
    321                         (%map (r 'map)))
    322                     (if (null? predicates)
    323                       `(,%define-syntax ,name
    324                          (,%er-macro-transformer
    325                            (,%lambda (,%form ,%rename ,%compare?)
    326                              (,%bind ,args (,%cdr ,%form)
    327                                (,%bind ,prefixed-identifiers
    328                                        (,%map ,%rename ',identifiers)
    329                                  ,@body)))))
    330                       (let ((suffix (car predicates))
    331                             (suffixed-keywords (cdr predicates)))
    332                         (let ((syms (map (lambda (id) (strip-suffix suffix id))
    333                                          suffixed-keywords)))
    334                           `(,%define-syntax ,name
    335                              (,%er-macro-transformer
    336                                (,%lambda (,%form ,%rename ,%compare?)
    337                                  (,%bind ,args (,%cdr ,%form)
    338                                    (,%bind ,prefixed-identifiers
    339                                            (,%map ,%rename ',identifiers)
    340                                      (,%bind ,suffixed-keywords
    341                                        (,%list ,@(map (lambda (s)
    342                                                         `(lambda (n)
    343                                                            (,%compare? n (,%rename ',s))))
    344                                                       syms))
    345                                        ,@body)))))))))))))))))))
     250      (let ((macro-code (cadr f))
     251            (rename-xpr (caddr f))
     252            (strip-prefix (lambda (pre id)
     253                            (string->symbol
     254                              (substring (symbol->string id)
     255                                         (string-length
     256                                           (symbol->string pre))))))
     257            (strip-suffix
     258              (lambda (suf id)
     259                (let ((sufstring (symbol->string suf))
     260                      (idstring (symbol->string id)))
     261                  (string->symbol
     262                    (substring idstring
     263                               0
     264                               (- (string-length idstring)
     265                                  (string-length sufstring))))))))
     266        (let ((name (car macro-code))
     267              (args (cdr macro-code))
     268              (prefix (caadr rename-xpr))
     269              (prefixed-identifiers (cdadr rename-xpr))
     270              (compare-xpr (caddr rename-xpr)))
     271          (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
     272                                  prefixed-identifiers))
     273                (predicates (cadr compare-xpr))
     274                (body (caddr compare-xpr))
     275                (%er-macro-transformer (r 'er-macro-transformer))
     276                (%define-syntax (r 'define-syntax))
     277                (%compare? (r 'compare?))
     278                (%rename (r 'rename))
     279                (%lambda (r 'lambda))
     280                (%bind (r 'bind))
     281                (%list (r 'list))
     282                (%form (r 'form))
     283                (%cdr (r 'cdr))
     284                (%map (r 'map)))
     285            (if (null? predicates)
     286              `(,%define-syntax ,name
     287                  (,%er-macro-transformer
     288                    (,%lambda (,%form ,%rename ,%compare?)
     289                      (,%bind ,args (,%cdr ,%form)
     290                              (,%bind ,prefixed-identifiers
     291                                      (,%map ,%rename ',identifiers)
     292                                ,body)))))
     293              (let ((suffix (car predicates))
     294                    (suffixed-keywords (cdr predicates)))
     295                (let ((syms (map (lambda (id) (strip-suffix suffix id))
     296                                 suffixed-keywords)))
     297                  `(,%define-syntax ,name
     298                      (,%er-macro-transformer
     299                        (,%lambda (,%form ,%rename ,%compare?)
     300                          (,%bind ,args (,%cdr ,%form)
     301                            (,%bind ,prefixed-identifiers
     302                                    (,%map ,%rename ',identifiers)
     303                              (,%bind ,suffixed-keywords
     304                                      (,%list ,@(map (lambda (s)
     305                                                       `(lambda (n)
     306                                                          (,%compare? n (,%rename ',s))))
     307                                                     syms))
     308                                      ,body)))))))))))))))
    346309
    347310(define-syntax define-macro
    348   (syntax-rules ()
    349     ((_ macro-form xpr . xprs)
    350      (define-ir-macro macro-form
    351        (injecting ()
    352          (comparing () xpr . xprs))))))
     311  (ir-macro-transformer
     312    (lambda (form inject compare?)
     313      (if (not (= (length form) 3))
     314        (error 'define-macro "macro-code doesn't match pattern"
     315               '(_ macro-code body))
     316        (let ((macro-code (cadr form)) (body (caddr form)))
     317          ;; create standard body
     318          (let ((body (if (and (list? body)
     319                               (= (length body) 3)
     320                               (list? (cadr body)))
     321                        (cond
     322                          ((compare? (car body) 'comparing)
     323                           `(injecting () ,body))
     324                          ((compare? (car body) 'injecting)
     325                           (let ((rest (caddr body)))
     326                             (if (and (list? rest)
     327                                      (= (length rest) 3)
     328                                      (list? (cadr rest))
     329                                      (compare? (car rest) 'comparing))
     330                               body
     331                               `(injecting ,(cadr body)
     332                                  (comparing () ,(caddr body))))))
     333                          ((compare? (car body) 'renaming)
     334                           (let ((rest (caddr body)))
     335                             (if (and (list? rest)
     336                                      (= (length rest) 3)
     337                                      (list? (cadr rest))
     338                                      (compare? (car rest) 'comparing))
     339                               body
     340                               `(renaming ,(cadr body)
     341                                 (comparing () ,(caddr body))))))
     342                          (else
     343                            (error 'define-macro "not a macro body" body)))
     344                        `(injecting ()
     345                          (comparing () ,body)))))
     346            (if (compare? (car body) 'injecting)
     347              `(define-ir-macro ,macro-code ,body)
     348              `(define-er-macro ,macro-code ,body))))))))
    353349
    354350(define (list-bindings . args)
    355   (let ((lst '(bind bind-let* bind-let bind-case bindable? bind/cc define-er-macro define-ir-macro)))
     351  (let ((lst '(bind bind-let* bind-let bind-case bindable? bind/cc
     352                define-macro)))
    356353    (if (null? args)
    357354      lst
     
    381378            (_ cont . body)
    382379            "captures current continuation, binds it to cont and executes body in this scope"))
    383         ((define-er-macro)
    384          '(macro (renaming comparing)
    385             (_ (name . args)
    386                (renaming (prefix . prefixed-identifiers)
    387                  (comparing predicates
    388                    . body)))
    389             "where renaming and comparing are keywords and predicates is either () or of the form (suffix . suffixed-keywords).  Simplifies explicit-renaming macros by destructuring the macro-form (name . args), binding prefixed-identifiers to its own name but with prefix stripped and providing predicates to check if a symbol compares to the predicate's name with the suffix stripped"))
    390         ((define-ir-macro)
    391          '(macro (injecting comparing)
    392             (_ (name . args)
    393                (injecting identifiers
    394                  (comparing predicates
    395                    . body)))
    396             "where injecting and comparing are keywords and predicates is either () or of the form (suffix .  suffixed-keywords).  Simplifies implicit-renaming macros by destructuring the macro-form (name . args), injecting the identifiers and providing predicates to check if a symbol compares to the predicate's name with its suffix stripped"))
    397380        ((define-macro)
    398          '(macro ()
    399             (_ (name . args) xpr . xprs)
    400             "defines hygienic macro name with no additional keyword and body xpr . xprs by destructuring the macro-code (name .  args)"))
     381         '(macro (injecting renaming comparing)
     382            (_ (name . args) body)
     383            "where body is either a renaming expression of the form (renaming (prefix . prefixed-identifiers) comparing-expression), an injecting expression of the form (injecting identifiers comparing-expression) or any other expression. A comparing expression is of the form (comparing predicates xpr) where predicates is either null or of the form (suffixed .  suffixed-keywords). defines macro name by destructuring the macro-code (name .  args) and binding identifiers or prefixed-identifiers with injected or renamed and prefix-stripped versions of itself as well as binding suffixed-keywords to predicates comparing its only argument to suffix-stripped versions of itself.  Evaluates xpr in this context or body if body is neither an injecting nor a renaming expression."))
    401384        (else lst)))))
    402385
    403386) ; module list-bindings
    404387
    405 ;(import list-bindings)
    406 ;(use simple-tests) 
    407 ;
    408 ;
    409 ;(pe '(define-ir-macro (ifreeze xpr)
    410 ;       (injecting ()
    411 ;         (comparing () `(lambda () ,xpr)))))
    412 ;
    413 ;(pe '(define-ir-macro (alambda args xpr . xprs)
    414 ;       (injecting (self)
    415 ;         (comparing ()
    416 ;           `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    417 ;              ,self)))))
    418 ;
    419 ;(pe '(define-ir-macro (name . args)
    420 ;       (injecting ()
    421 ;         (comparing (? a? b?) body))))
    422 ;(pe '(define-ir-macro (name . args)
    423 ;       (injecting (x y)
    424 ;         (comparing (? a? b?) body))))
    425 ;
    426 ;(pe '(define-er-macro (name . args)
    427 ;       (renaming (% %x %y)
    428 ;         (comparing () body))))
    429 ;(pe '(define-er-macro (name . args)
    430 ;       (renaming (% %x %y)
    431 ;         (comparing (? a? b?) body))))
    432 ;(pe '(define-er-macro (foo pair)
    433 ;       (renaming (% %if)
    434 ;         (comparing (? bar?)
    435 ;           `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))))
    436 ;
    437 ;(pe '(bind-let* (((a b) '(1 2)) ((x . y) (list a))) body))
    438 ;(pe '(bind-let (((a b) '(1 2)) ((x . y) '(3))) body))
  • release/4/list-bindings/tags/1.3/list-bindings.setup

    r29527 r29545  
    77 'list-bindings
    88 '("list-bindings.so" "list-bindings.import.so")
    9  '((version "1.2")))
     9 '((version "1.3")))
    1010
  • release/4/list-bindings/tags/1.3/tests/run.scm

    r29527 r29545  
    9595          '(1 2 3 (4 4)))
    9696  "TEST LOW-LEVEL MACROS"
    97   (define-er-macro (efreeze xpr)
     97  (define-macro (efreeze xpr)
    9898    (renaming (% %lambda)
    99       (comparing ()
    100         `(,%lambda () ,xpr))))
     99      `(,%lambda () ,xpr)))
    101100  (= ((efreeze 3)) 3)
    102   (define-ir-macro (ifreeze xpr)
    103     (injecting ()
    104       (comparing ()
    105         `(lambda () ,xpr))))
     101  (define-macro (ifreeze xpr)
     102    `(lambda () ,xpr))
    106103  (= ((ifreeze 5)) 5)
    107   (define-ir-macro (alambda args xpr . xprs)
     104  (define-macro (alambda args xpr . xprs)
    108105    (injecting (self)
    109       (comparing ()
    110         `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    111            ,self))))
     106      `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     107         ,self)))
    112108  (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
    113109  (= (! 5) 120)
    114   (define-ir-macro (foo pair)
    115     (injecting ()
    116       (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked))))
     110  (define-macro (foo pair)
     111    (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))
    117112  (eq? (foo (bar 'checked)) 'checked)
    118113  (eq? (foo (baz 'checked)) 'unchecked)
    119   (define-er-macro (baz pair)
     114  (define-macro (baz pair)
    120115    (renaming (% %if)
    121116      (comparing (? bar?)
     
    128123          '(y x))
    129124  )
     125
  • release/4/list-bindings/trunk/list-bindings.scm

    r29527 r29545  
    3939  (export list-bindings bind bindable? bind-case bind/cc
    4040          bind-let bind-let*
    41           define-er-macro define-ir-macro define-macro)
    42   (import scheme chicken)
     41          define-macro)
     42  (import scheme (only chicken condition-case error))
    4343
    4444 ;;; (bind pat list-xpr . body)
     
    5050  (ir-macro-transformer
    5151    (lambda (form inject compare?)
    52       (if (fx< (length form) 4)
    53         (error 'bind "macro-form doesn't match pattern "
     52      (if (< (length form) 4)
     53        (error 'bind "macro-code doesn't match pattern "
    5454               '(_ pat lst xpr . xprs))
    5555        (let ((pat (cadr form))
     
    179179  (ir-macro-transformer
    180180    (lambda (f i c?)
    181       (if (not (fx= (length f) 3))
    182         `(error 'define-ir-macro
    183                 "form doesn't match pattern"
    184                 '(_ macro-form inject-xpr))
    185         (let ((macro-form (cadr f))
    186               (inject-xpr (caddr f))
    187               (strip-suffix
    188                 (lambda (suf id)
    189                   (let ((sufstring (symbol->string suf))
    190                         (idstring (symbol->string id)))
    191                     (string->symbol
    192                       (substring idstring
    193                                  0
    194                                  (fx- (string-length idstring)
    195                                       (string-length sufstring))))))))
    196           (cond
    197             ((not (pair? macro-form))
    198              `(error 'define-ir-macro "not a macro form" ',macro-form))
    199             ((not (and (list? inject-xpr)
    200                        (fx= (length inject-xpr) 3)
    201                        (c? (car inject-xpr) 'injecting)
    202                        (list? (cadr inject-xpr))))
    203              `(error 'define-ir-macro "not an injecting expression"
    204                      ',inject-xpr))
    205             (else
    206               (let ((name (car macro-form))
    207                     (args (cdr macro-form))
    208                     (identifiers (cadr inject-xpr))
    209                     (compare-xpr (caddr inject-xpr)))
    210                 (if (not (and (list? compare-xpr)
    211                               (c? (car compare-xpr) 'comparing)
    212                               (list? (cadr compare-xpr))))
    213                   `(error 'define-ir-macro "not a comparing expression"
    214                           ',compare-xpr)
    215                   (let ((predicates (cadr compare-xpr))
    216                         (body (cddr compare-xpr)))
    217                     (cond
    218                       ((and (null? identifiers) (null? predicates))
    219                        `(define-syntax ,name
    220                           (ir-macro-transformer
    221                             (lambda (form inject compare?)
    222                               (bind ,args (cdr form) ,@body)))))
    223                       ((null? predicates)
    224                        `(define-syntax ,name
    225                           (ir-macro-transformer
    226                             (lambda (form inject compare?)
    227                               (bind ,args (cdr form)
    228                                 (bind ,identifiers (map inject ',identifiers)
    229                                   ,@body))))))
    230                       (else
    231                         (let ((suffix (car predicates))
    232                               (suffixed-keywords (cdr predicates)))
    233                           (let ((syms (map (lambda (id) (strip-suffix suffix id))
    234                                            suffixed-keywords)))
    235                             (if (null? identifiers)
    236                               `(define-syntax ,name
    237                                  (ir-macro-transformer
    238                                    (lambda (form inject compare?)
    239                                      (bind ,args (cdr form)
    240                                        (bind ,suffixed-keywords
    241                                          (list ,@(map (lambda (s)
    242                                                         `(lambda (n)
    243                                                            (compare? n ',(i s))))
    244                                                       syms))
    245                                          ,@body)))))
    246                               `(define-syntax ,name
    247                                  (ir-macro-transformer
    248                                    (lambda (form inject compare?)
    249                                      (bind ,args (cdr form)
    250                                        (bind ,identifiers (map inject ',identifiers)
    251                                          (bind ,suffixed-keywords
    252                                            (list ,@(map (lambda (s)
    253                                                           `(lambda (n)
    254                                                              (compare? n ',(i s))))
    255                                                         syms))
    256                                            ,@body)))))))))))))))))))))
     181      (let ((macro-code (cadr f))
     182            (inject-xpr (caddr f))
     183            (strip-suffix
     184              (lambda (suf id)
     185                (let ((sufstring (symbol->string suf))
     186                      (idstring (symbol->string id)))
     187                  (string->symbol
     188                    (substring idstring
     189                               0
     190                               (- (string-length idstring)
     191                                  (string-length sufstring))))))))
     192        (let ((name (car macro-code))
     193              (args (cdr macro-code))
     194              (identifiers (cadr inject-xpr))
     195              (compare-xpr (caddr inject-xpr)))
     196          (let ((predicates (cadr compare-xpr))
     197                (body (caddr compare-xpr)))
     198            (cond
     199              ((and (null? identifiers) (null? predicates))
     200               `(define-syntax ,name
     201                  (ir-macro-transformer
     202                    (lambda (form inject compare?)
     203                      (bind ,args (cdr form)
     204                        ,body)))))
     205              ((null? predicates)
     206               `(define-syntax ,name
     207                  (ir-macro-transformer
     208                    (lambda (form inject compare?)
     209                      (bind ,args (cdr form)
     210                        (bind ,identifiers (map inject ',identifiers)
     211                          ,body))))))
     212              (else
     213                (let ((suffix (car predicates))
     214                      (suffixed-keywords (cdr predicates)))
     215                  (let ((syms (map (lambda (id) (strip-suffix suffix id))
     216                                   suffixed-keywords)))
     217                    (if (null? identifiers)
     218                      `(define-syntax ,name
     219                         (ir-macro-transformer
     220                           (lambda (form inject compare?)
     221                             (bind ,args (cdr form)
     222                               (bind ,suffixed-keywords
     223                                 (list ,@(map (lambda (s)
     224                                                `(lambda (n)
     225                                                   (compare? n ',(i s))))
     226                                              syms))
     227                                 ,body)))))
     228                      `(define-syntax ,name
     229                         (ir-macro-transformer
     230                           (lambda (form inject compare?)
     231                             (bind ,args (cdr form)
     232                               (bind ,identifiers (map inject ',identifiers)
     233                                 (bind ,suffixed-keywords
     234                                   (list ,@(map (lambda (s)
     235                                                  `(lambda (n)
     236                                                     (compare? n ',(i s))))
     237                                                syms))
     238                                   ,body)))))))))))))))))
    257239
    258240;;; (define-er-macro (name . args)
     
    266248  (er-macro-transformer
    267249    (lambda (f r c?)
    268       (if (not (fx= (length f) 3))
    269         `(error 'define-er-macro
    270                 "macro-form doesn't match pattern"
    271                 '(_ macro-form rename-xpr))
    272         (let ((macro-form (cadr f))
    273               (rename-xpr (caddr f))
    274               (strip-prefix (lambda (pre id)
    275                               (string->symbol
    276                                 (substring (symbol->string id)
    277                                            (string-length
    278                                              (symbol->string pre))))))
    279               (strip-suffix
    280                 (lambda (suf id)
    281                   (let ((sufstring (symbol->string suf))
    282                         (idstring (symbol->string id)))
    283                     (string->symbol
    284                       (substring idstring
    285                                  0
    286                                  (fx- (string-length idstring)
    287                                       (string-length sufstring))))))))
    288           (cond
    289             ((not (pair? macro-form))
    290              `(error 'define-er-macro "not a macro form" ',macro-form))
    291             ((not (and (list? rename-xpr)
    292                        (fx= (length rename-xpr) 3)
    293                        (c? (car rename-xpr) (r 'renaming))
    294                        (pair? (cadr rename-xpr))))
    295              `(error 'define-er-macro "not a renaming expression"
    296                      ',rename-xpr))
    297             (else
    298               (let ((name (car macro-form))
    299                     (args (cdr macro-form))
    300                     (prefix (caadr rename-xpr))
    301                     (prefixed-identifiers (cdadr rename-xpr))
    302                     (compare-xpr (caddr rename-xpr)))
    303                 (if (not (and (list? compare-xpr)
    304                               (c? (car compare-xpr) (r 'comparing))
    305                               (list? (cadr compare-xpr))))
    306                   `(error 'define-er-macro "not a comparing expression"
    307                           ',compare-xpr)
    308                   (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
    309                                           prefixed-identifiers))
    310                         (predicates (cadr compare-xpr))
    311                         (body (cddr compare-xpr))
    312                         (%er-macro-transformer (r 'er-macro-transformer))
    313                         (%define-syntax (r 'define-syntax))
    314                         (%compare? (r 'compare?))
    315                         (%rename (r 'rename))
    316                         (%lambda (r 'lambda))
    317                         (%bind (r 'bind))
    318                         (%list (r 'list))
    319                         (%form (r 'form))
    320                         (%cdr (r 'cdr))
    321                         (%map (r 'map)))
    322                     (if (null? predicates)
    323                       `(,%define-syntax ,name
    324                          (,%er-macro-transformer
    325                            (,%lambda (,%form ,%rename ,%compare?)
    326                              (,%bind ,args (,%cdr ,%form)
    327                                (,%bind ,prefixed-identifiers
    328                                        (,%map ,%rename ',identifiers)
    329                                  ,@body)))))
    330                       (let ((suffix (car predicates))
    331                             (suffixed-keywords (cdr predicates)))
    332                         (let ((syms (map (lambda (id) (strip-suffix suffix id))
    333                                          suffixed-keywords)))
    334                           `(,%define-syntax ,name
    335                              (,%er-macro-transformer
    336                                (,%lambda (,%form ,%rename ,%compare?)
    337                                  (,%bind ,args (,%cdr ,%form)
    338                                    (,%bind ,prefixed-identifiers
    339                                            (,%map ,%rename ',identifiers)
    340                                      (,%bind ,suffixed-keywords
    341                                        (,%list ,@(map (lambda (s)
    342                                                         `(lambda (n)
    343                                                            (,%compare? n (,%rename ',s))))
    344                                                       syms))
    345                                        ,@body)))))))))))))))))))
     250      (let ((macro-code (cadr f))
     251            (rename-xpr (caddr f))
     252            (strip-prefix (lambda (pre id)
     253                            (string->symbol
     254                              (substring (symbol->string id)
     255                                         (string-length
     256                                           (symbol->string pre))))))
     257            (strip-suffix
     258              (lambda (suf id)
     259                (let ((sufstring (symbol->string suf))
     260                      (idstring (symbol->string id)))
     261                  (string->symbol
     262                    (substring idstring
     263                               0
     264                               (- (string-length idstring)
     265                                  (string-length sufstring))))))))
     266        (let ((name (car macro-code))
     267              (args (cdr macro-code))
     268              (prefix (caadr rename-xpr))
     269              (prefixed-identifiers (cdadr rename-xpr))
     270              (compare-xpr (caddr rename-xpr)))
     271          (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
     272                                  prefixed-identifiers))
     273                (predicates (cadr compare-xpr))
     274                (body (caddr compare-xpr))
     275                (%er-macro-transformer (r 'er-macro-transformer))
     276                (%define-syntax (r 'define-syntax))
     277                (%compare? (r 'compare?))
     278                (%rename (r 'rename))
     279                (%lambda (r 'lambda))
     280                (%bind (r 'bind))
     281                (%list (r 'list))
     282                (%form (r 'form))
     283                (%cdr (r 'cdr))
     284                (%map (r 'map)))
     285            (if (null? predicates)
     286              `(,%define-syntax ,name
     287                  (,%er-macro-transformer
     288                    (,%lambda (,%form ,%rename ,%compare?)
     289                      (,%bind ,args (,%cdr ,%form)
     290                              (,%bind ,prefixed-identifiers
     291                                      (,%map ,%rename ',identifiers)
     292                                ,body)))))
     293              (let ((suffix (car predicates))
     294                    (suffixed-keywords (cdr predicates)))
     295                (let ((syms (map (lambda (id) (strip-suffix suffix id))
     296                                 suffixed-keywords)))
     297                  `(,%define-syntax ,name
     298                      (,%er-macro-transformer
     299                        (,%lambda (,%form ,%rename ,%compare?)
     300                          (,%bind ,args (,%cdr ,%form)
     301                            (,%bind ,prefixed-identifiers
     302                                    (,%map ,%rename ',identifiers)
     303                              (,%bind ,suffixed-keywords
     304                                      (,%list ,@(map (lambda (s)
     305                                                       `(lambda (n)
     306                                                          (,%compare? n (,%rename ',s))))
     307                                                     syms))
     308                                      ,body)))))))))))))))
    346309
    347310(define-syntax define-macro
    348   (syntax-rules ()
    349     ((_ macro-form xpr . xprs)
    350      (define-ir-macro macro-form
    351        (injecting ()
    352          (comparing () xpr . xprs))))))
     311  (ir-macro-transformer
     312    (lambda (form inject compare?)
     313      (if (not (= (length form) 3))
     314        (error 'define-macro "macro-code doesn't match pattern"
     315               '(_ macro-code body))
     316        (let ((macro-code (cadr form)) (body (caddr form)))
     317          ;; create standard body
     318          (let ((body (if (and (list? body)
     319                               (= (length body) 3)
     320                               (list? (cadr body)))
     321                        (cond
     322                          ((compare? (car body) 'comparing)
     323                           `(injecting () ,body))
     324                          ((compare? (car body) 'injecting)
     325                           (let ((rest (caddr body)))
     326                             (if (and (list? rest)
     327                                      (= (length rest) 3)
     328                                      (list? (cadr rest))
     329                                      (compare? (car rest) 'comparing))
     330                               body
     331                               `(injecting ,(cadr body)
     332                                  (comparing () ,(caddr body))))))
     333                          ((compare? (car body) 'renaming)
     334                           (let ((rest (caddr body)))
     335                             (if (and (list? rest)
     336                                      (= (length rest) 3)
     337                                      (list? (cadr rest))
     338                                      (compare? (car rest) 'comparing))
     339                               body
     340                               `(renaming ,(cadr body)
     341                                 (comparing () ,(caddr body))))))
     342                          (else
     343                            (error 'define-macro "not a macro body" body)))
     344                        `(injecting ()
     345                          (comparing () ,body)))))
     346            (if (compare? (car body) 'injecting)
     347              `(define-ir-macro ,macro-code ,body)
     348              `(define-er-macro ,macro-code ,body))))))))
    353349
    354350(define (list-bindings . args)
    355   (let ((lst '(bind bind-let* bind-let bind-case bindable? bind/cc define-er-macro define-ir-macro)))
     351  (let ((lst '(bind bind-let* bind-let bind-case bindable? bind/cc
     352                define-macro)))
    356353    (if (null? args)
    357354      lst
     
    381378            (_ cont . body)
    382379            "captures current continuation, binds it to cont and executes body in this scope"))
    383         ((define-er-macro)
    384          '(macro (renaming comparing)
    385             (_ (name . args)
    386                (renaming (prefix . prefixed-identifiers)
    387                  (comparing predicates
    388                    . body)))
    389             "where renaming and comparing are keywords and predicates is either () or of the form (suffix . suffixed-keywords).  Simplifies explicit-renaming macros by destructuring the macro-form (name . args), binding prefixed-identifiers to its own name but with prefix stripped and providing predicates to check if a symbol compares to the predicate's name with the suffix stripped"))
    390         ((define-ir-macro)
    391          '(macro (injecting comparing)
    392             (_ (name . args)
    393                (injecting identifiers
    394                  (comparing predicates
    395                    . body)))
    396             "where injecting and comparing are keywords and predicates is either () or of the form (suffix .  suffixed-keywords).  Simplifies implicit-renaming macros by destructuring the macro-form (name . args), injecting the identifiers and providing predicates to check if a symbol compares to the predicate's name with its suffix stripped"))
    397380        ((define-macro)
    398          '(macro ()
    399             (_ (name . args) xpr . xprs)
    400             "defines hygienic macro name with no additional keyword and body xpr . xprs by destructuring the macro-code (name .  args)"))
     381         '(macro (injecting renaming comparing)
     382            (_ (name . args) body)
     383            "where body is either a renaming expression of the form (renaming (prefix . prefixed-identifiers) comparing-expression), an injecting expression of the form (injecting identifiers comparing-expression) or any other expression. A comparing expression is of the form (comparing predicates xpr) where predicates is either null or of the form (suffixed .  suffixed-keywords). defines macro name by destructuring the macro-code (name .  args) and binding identifiers or prefixed-identifiers with injected or renamed and prefix-stripped versions of itself as well as binding suffixed-keywords to predicates comparing its only argument to suffix-stripped versions of itself.  Evaluates xpr in this context or body if body is neither an injecting nor a renaming expression."))
    401384        (else lst)))))
    402385
    403386) ; module list-bindings
    404387
    405 ;(import list-bindings)
    406 ;(use simple-tests) 
    407 ;
    408 ;
    409 ;(pe '(define-ir-macro (ifreeze xpr)
    410 ;       (injecting ()
    411 ;         (comparing () `(lambda () ,xpr)))))
    412 ;
    413 ;(pe '(define-ir-macro (alambda args xpr . xprs)
    414 ;       (injecting (self)
    415 ;         (comparing ()
    416 ;           `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    417 ;              ,self)))))
    418 ;
    419 ;(pe '(define-ir-macro (name . args)
    420 ;       (injecting ()
    421 ;         (comparing (? a? b?) body))))
    422 ;(pe '(define-ir-macro (name . args)
    423 ;       (injecting (x y)
    424 ;         (comparing (? a? b?) body))))
    425 ;
    426 ;(pe '(define-er-macro (name . args)
    427 ;       (renaming (% %x %y)
    428 ;         (comparing () body))))
    429 ;(pe '(define-er-macro (name . args)
    430 ;       (renaming (% %x %y)
    431 ;         (comparing (? a? b?) body))))
    432 ;(pe '(define-er-macro (foo pair)
    433 ;       (renaming (% %if)
    434 ;         (comparing (? bar?)
    435 ;           `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))))
    436 ;
    437 ;(pe '(bind-let* (((a b) '(1 2)) ((x . y) (list a))) body))
    438 ;(pe '(bind-let (((a b) '(1 2)) ((x . y) '(3))) body))
  • release/4/list-bindings/trunk/list-bindings.setup

    r29527 r29545  
    77 'list-bindings
    88 '("list-bindings.so" "list-bindings.import.so")
    9  '((version "1.2")))
     9 '((version "1.3")))
    1010
  • release/4/list-bindings/trunk/tests/run.scm

    r29527 r29545  
    9595          '(1 2 3 (4 4)))
    9696  "TEST LOW-LEVEL MACROS"
    97   (define-er-macro (efreeze xpr)
     97  (define-macro (efreeze xpr)
    9898    (renaming (% %lambda)
    99       (comparing ()
    100         `(,%lambda () ,xpr))))
     99      `(,%lambda () ,xpr)))
    101100  (= ((efreeze 3)) 3)
    102   (define-ir-macro (ifreeze xpr)
    103     (injecting ()
    104       (comparing ()
    105         `(lambda () ,xpr))))
     101  (define-macro (ifreeze xpr)
     102    `(lambda () ,xpr))
    106103  (= ((ifreeze 5)) 5)
    107   (define-ir-macro (alambda args xpr . xprs)
     104  (define-macro (alambda args xpr . xprs)
    108105    (injecting (self)
    109       (comparing ()
    110         `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    111            ,self))))
     106      `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     107         ,self)))
    112108  (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
    113109  (= (! 5) 120)
    114   (define-ir-macro (foo pair)
    115     (injecting ()
    116       (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked))))
     110  (define-macro (foo pair)
     111    (comparing (? bar?) `(if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))
    117112  (eq? (foo (bar 'checked)) 'checked)
    118113  (eq? (foo (baz 'checked)) 'unchecked)
    119   (define-er-macro (baz pair)
     114  (define-macro (baz pair)
    120115    (renaming (% %if)
    121116      (comparing (? bar?)
     
    128123          '(y x))
    129124  )
     125
Note: See TracChangeset for help on using the changeset viewer.