Changeset 8904 in project for release/3/F-operator/reflect-reify.scm


Ignore:
Timestamp:
02/25/08 16:11:05 (12 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/F-operator/reflect-reify.scm

    r2773 r8904  
    66;; Monads from shift and reset (from Filinski, POPL '94)
    77
    8 (cond-expand (syntax-case
     8(cond-expand
     9  [syntax-case
    910
    10 (define-syntax define-bind
    11   (lambda (exp)
    12     (syntax-case exp ()
    13       [(sk kind body ...)
    14         (identifier? #'kind)
    15         (with-syntax (
    16             [monad (datum->syntax-object #'sk 'monad)]
    17             [func (datum->syntax-object #'sk 'func)]
    18             [bind
    19               (datum->syntax-object #'sk
    20                 (string->symbol
    21                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
    22           #'(define (bind monad func) body ...))]
    23     ) ) )
     11    (define-syntax (define-bind exp)
     12      (syntax-case exp ()
     13        [(sk kind body ...)
     14          (identifier? #'kind)
     15          (with-syntax (
     16              [monad (datum->syntax-object #'sk 'monad)]
     17              [func (datum->syntax-object #'sk 'func)]
     18              [bind
     19                (datum->syntax-object #'sk
     20                  (string->symbol
     21                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
     22            #'(define (bind monad func) body ...))] ) )
    2423
    25 (define-syntax define-unit
    26   (lambda (exp)
    27     (syntax-case exp ()
    28       [(sk kind body ...)
    29         (identifier? #'kind)
    30         (with-syntax (
    31             [obj (datum->syntax-object #'sk 'obj)]
    32             [unit
    33               (datum->syntax-object #'sk
    34                 (string->symbol
    35                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
    36           #'(define (unit obj) body ...))]
    37     ) ) )
     24    (define-syntax (define-unit exp)
     25      (syntax-case exp ()
     26        [(sk kind body ...)
     27          (identifier? #'kind)
     28          (with-syntax (
     29              [obj (datum->syntax-object #'sk 'obj)]
     30              [unit
     31                (datum->syntax-object #'sk
     32                  (string->symbol
     33                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
     34            #'(define (unit obj) body ...))] ) )
    3835
    39 (define-syntax reflect
    40   (lambda (exp)
    41     (syntax-case exp ()
    42       [(sk kind meaning)
    43         (identifier? #'kind)
    44         (with-syntax (
    45             [bind
    46               (datum->syntax-object #'sk
    47                 (string->symbol
    48                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
    49           #'(shift k (bind meaning k)))]
    50     ) ) )
     36    (define-syntax (reflect exp)
     37      (syntax-case exp ()
     38        [(sk kind meaning)
     39          (identifier? #'kind)
     40          (with-syntax (
     41              [bind
     42                (datum->syntax-object #'sk
     43                  (string->symbol
     44                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
     45            #'(shift k (bind meaning k)))] ) )
    5146
    52 (define-syntax reflect-values
    53   (lambda (exp)
    54     (syntax-case exp ()
    55       [(sk kind meaning)
    56         (identifier? #'kind)
    57         (with-syntax (
    58             [bind
    59               (datum->syntax-object #'sk
    60                 (string->symbol
    61                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
    62           #'(shift-values k (bind meaning k)))]
    63     ) ) )
     47    (define-syntax (reflect-values exp)
     48      (syntax-case exp ()
     49        [(sk kind meaning)
     50          (identifier? #'kind)
     51          (with-syntax (
     52              [bind
     53                (datum->syntax-object #'sk
     54                  (string->symbol
     55                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
     56            #'(shift-values k (bind meaning k)))] ) )
    6457
    65 (define-syntax %reflect
    66   (lambda (exp)
    67     (syntax-case exp ()
    68       [(sk kind meaning)
    69         (identifier? #'kind)
    70         (with-syntax (
    71             [bind
    72               (datum->syntax-object #'sk
    73                 (string->symbol
    74                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
    75           #'(%shift k (bind meaning k)))]
    76     ) ) )
     58    (define-syntax (%reflect exp)
     59      (syntax-case exp ()
     60        [(sk kind meaning)
     61          (identifier? #'kind)
     62          (with-syntax (
     63              [bind
     64                (datum->syntax-object #'sk
     65                  (string->symbol
     66                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "bind")))])
     67            #'(%shift k (bind meaning k)))] ) )
    7768
    78 (define-syntax reify
    79   (lambda (exp)
    80     (syntax-case exp ()
    81       [(sk kind exp)
    82         (identifier? #'kind)
    83         (with-syntax (
    84             [unit
    85               (datum->syntax-object #'sk
    86                 (string->symbol
    87                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
    88           #'(reset (unit exp)))]
    89     ) ) )
     69    (define-syntax (reify exp)
     70      (syntax-case exp ()
     71        [(sk kind exp)
     72          (identifier? #'kind)
     73          (with-syntax (
     74              [unit
     75                (datum->syntax-object #'sk
     76                  (string->symbol
     77                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
     78            #'(reset (unit exp)))] ) )
    9079
    91 (define-syntax reify-values
    92   (lambda (exp)
    93     (syntax-case exp ()
    94       [(sk kind exp)
    95         (identifier? #'kind)
    96         (with-syntax (
    97             [unit
    98               (datum->syntax-object #'sk
    99                 (string->symbol
    100                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
    101           #'(reset-values (unit exp)))]
    102     ) ) )
     80    (define-syntax (reify-values exp)
     81      (syntax-case exp ()
     82        [(sk kind exp)
     83          (identifier? #'kind)
     84          (with-syntax (
     85              [unit
     86                (datum->syntax-object #'sk
     87                  (string->symbol
     88                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
     89            #'(reset-values (unit exp)))] ) )
    10390
    104 (define-syntax %reify
    105   (lambda (exp)
    106     (syntax-case exp ()
    107       [(sk kind exp)
    108         (identifier? #'kind)
    109         (with-syntax (
    110             [unit
    111               (datum->syntax-object #'sk
    112                 (string->symbol
    113                   (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
    114           #'(%reset (unit exp)))]
    115     ) ) )
     91    (define-syntax (%reify exp)
     92      (syntax-case exp ()
     93        [(sk kind exp)
     94          (identifier? #'kind)
     95          (with-syntax (
     96              [unit
     97                (datum->syntax-object #'sk
     98                  (string->symbol
     99                    (conc (symbol->string (syntax-object->datum #'kind)) #\- "unit")))])
     100            #'(%reset (unit exp)))] ) ) ]
    116101
    117 )(else
     102  [else
    118103
    119 (define-macro (define-bind KIND . BODY)
    120   (let ([BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
    121     `(define (,BIND monad func) ,@BODY) ) )
     104    (define-macro (define-bind KIND . BODY)
     105      (let ([BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
     106        `(define (,BIND monad func) ,@BODY) ) )
    122107
    123 (define-macro (define-unit KIND . BODY)
    124   (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
    125     `(define (,UNIT obj) ,@BODY) ) )
     108    (define-macro (define-unit KIND . BODY)
     109      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
     110        `(define (,UNIT obj) ,@BODY) ) )
    126111
    127 (define-macro (reflect KIND MEANING)
    128   (let ([K (gensym)]
    129         [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
    130     `(shift ,K (,BIND ,MEANING ,K)) ) )
     112    (define-macro (reflect KIND MEANING)
     113      (let ([K (gensym)]
     114            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
     115        `(shift ,K (,BIND ,MEANING ,K)) ) )
    131116
    132 (define-macro (reflect-values KIND MEANING)
    133   (let ([K (gensym)]
    134         [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
    135     `(shift-values ,K (,BIND ,MEANING ,K)) ) )
     117    (define-macro (reflect-values KIND MEANING)
     118      (let ([K (gensym)]
     119            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
     120        `(shift-values ,K (,BIND ,MEANING ,K)) ) )
    136121
    137 (define-macro (%reflect KIND MEANING)
    138   (let ([K (gensym)]
    139         [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
    140     `(%shift ,K (,BIND ,MEANING ,K)) ) )
     122    (define-macro (%reflect KIND MEANING)
     123      (let ([K (gensym)]
     124            [BIND (string->symbol (conc (symbol->string KIND) #\- "bind"))])
     125        `(%shift ,K (,BIND ,MEANING ,K)) ) )
    141126
    142 (define-macro (reify KIND EXP)
    143   (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
    144     `(reset (,UNIT ,EXP)) ) )
     127    (define-macro (reify KIND EXP)
     128      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
     129        `(reset (,UNIT ,EXP)) ) )
    145130
    146 (define-macro (reify-values KIND EXP)
    147   (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
    148     `(reset-values (,UNIT ,EXP)) ) )
     131    (define-macro (reify-values KIND EXP)
     132      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
     133        `(reset-values (,UNIT ,EXP)) ) )
    149134
    150 (define-macro (%reify KIND EXP)
    151   (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
    152     `(%reset (,UNIT ,EXP)) ) )
    153 
    154 ) )
     135    (define-macro (%reify KIND EXP)
     136      (let ([UNIT (string->symbol (conc (symbol->string KIND) #\- "unit"))])
     137        `(%reset (,UNIT ,EXP)) ) ) ] )
Note: See TracChangeset for help on using the changeset viewer.