Changeset 9027 in project


Ignore:
Timestamp:
02/26/08 15:41:46 (12 years ago)
Author:
Kon Lovett
Message:

Rel 1.0.0 (no real changes)

Location:
release/3/procedure-surface
Files:
10 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/procedure-surface/tags/1.0.0/procedure-surface-eggdoc.scm

    r8935 r9027  
    425425
    426426                (history
     427      (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
    427428      (version "0.301" "Needs lookup-table")
    428429      (version "0.3" "Added support for explicit library pathname")
  • release/3/procedure-surface/tags/1.0.0/procedure-surface-support.scm

    r8934 r9027  
    2525;;
    2626;; - Allow multiple impl procs for a sig, w/ failure criteria & automatic try?
    27 
    28 (use srfi-1 srfi-2 lolevel extras utils)
    29 (use lookup-table misc-extn-record misc-extn-control misc-extn-list misc-extn-symbol)
    30 (use signature-type)
    3127
    3228(eval-when (compile)
     
    7672      procedure-identifier->closure) ) )
    7773
    78 ;;
     74(use srfi-1 srfi-2 lolevel extras utils)
     75(use lookup-table misc-extn-record misc-extn-control
     76     misc-extn-list misc-extn-dsssl misc-extn-symbol)
     77(use signature-type)
     78
     79;;;
     80
     81;;
     82
    7983(define-inline-unchecked-record-type procedure-signature
    8084  (%make-procedure-signature id contract)
     
    8488
    8589;;
     90
    8691(define-record-printer (procedure-signature obj out)
    8792  (fprintf out "#<procedure-signature ~S ~S>"
     
    9095
    9196;;
     97
    9298(define-inline (check-procedure-signature obj loc)
    9399  (unless (%procedure-signature? obj)
     
    95101
    96102;;
     103
    97104(define (make-procedure-signature id contract)
    98105  (%make-procedure-signature
     
    102109
    103110;;
     111
    104112(define (procedure-signature? obj)
    105113  (%procedure-signature? obj))
    106114
    107115;; Returns the contract or #f when no contract or error
    108 ;;
     116
    109117(define (procedure-signature-identifier obj)
    110118  (check-procedure-signature obj 'procedure-signature-identifier)
     
    112120
    113121;; Returns the contract or #f when no contract or error
    114 ;;
     122
    115123(define (procedure-signature-contract obj)
    116124  (check-procedure-signature obj 'procedure-signature-contract)
     
    122130
    123131;;
     132
    124133(define-inline-unchecked-record-type procedure-surface
    125134  (%make-procedure-surface name immutable signature-map)
     
    130139
    131140;;
     141
    132142(define-inline (check-procedure-surface obj loc)
    133143  (unless (%procedure-surface? obj)
     
    135145
    136146;;
     147
    137148(define-inline (check-procedure-surface-mutable obj loc)
    138149  (check-procedure-surface obj loc)
     
    141152
    142153;;
     154
    143155(define-inline (%procedure-surface-ref ps key)
    144156  (dict-ref (%procedure-surface-signature-map ps) key))
    145157
    146158;;
     159
    147160(define-inline (%procedure-surface-set! ps lt)
    148161  (dict-merge! (%procedure-surface-signature-map ps) lt) )
    149162
    150163;;
     164
    151165(define-inline (%procedure-surface-delete! ps key)
    152166  (dict-delete! (%procedure-surface-signature-map ps) key) )
    153167
    154168;;
     169
    155170(define (parse-procedure-signatures pss)
    156171  (let loop ([pss pss] [pal '()])
     
    170185
    171186;;
     187
    172188(define (make-procedure-surface
    173189          #!rest procedure-signatures
     
    188204    immutable
    189205    (parse-procedure-signatures
    190       (filter-rest-argument! procedure-signatures '(#:immutable #:name)))))
    191 
    192 ;;
     206      (fixup-extended-lambda-list-rest '(#:immutable #:name) procedure-signatures))))
     207
     208;;
     209
    193210(define (procedure-surface? obj)
    194211  (%procedure-surface? obj))
    195212
    196213;;
     214
    197215(define (procedure-surface-name obj)
    198216  (check-procedure-surface obj 'procedure-surface-name)
     
    202220
    203221;;
     222
    204223(define (procedure-surface-immutable? obj)
    205224  (check-procedure-surface obj 'procedure-surface-immutable?)
     
    207226
    208227;;
     228
    209229(define (procedure-surface-mutable? obj)
    210230  (check-procedure-surface obj 'procedure-surface-mutable?)
     
    212232
    213233;; Returns a procedural signature or #f
    214 ;;
     234
    215235(define (procedure-surface-ref obj key)
    216236  (check-procedure-surface obj 'procedure-surface-ref)
     
    218238
    219239;; Creates or updates one or more signatures.
    220 ;;
     240
    221241(define (procedure-surface-set! obj #!rest pss)
    222242  (check-procedure-surface-mutable obj 'procedure-surface-set!)
     
    224244
    225245;; Removes a signature. Does not complain when key has no match.
    226 ;;
     246
    227247(define (procedure-surface-delete! obj key)
    228248  (check-procedure-surface-mutable obj 'procedure-surface-delete!)
     
    230250
    231251;;
     252
    232253(define (procedure-surface->alist obj)
    233254  (check-procedure-surface obj 'procedure-surface->alist)
     
    237258;; If any of the combined procedure surfaces is immutable
    238259;; then the composite is immutable.
    239 ;;
     260
    240261(define (make-composite-procedure-surface . rest)
    241262  ; Start with nothing
     
    270291
    271292;;
     293
    272294(define (composite-procedure-surface? obj)
    273295  (check-procedure-surface obj 'composite-procedure-surface?)
     
    279301
    280302;;
     303
    281304(define-inline-unchecked-record-type procedure-means
    282305  (%make-procedure-means
     
    293316
    294317;;
     318
    295319(define-inline (check-procedure-means obj loc)
    296320  (unless (%procedure-means? obj)
     
    298322
    299323;;
     324
    300325(define-inline (check-procedure-means-mutable obj loc)
    301326  (check-procedure-means obj loc)
     
    304329
    305330;;
     331
    306332(define-inline (%check-procedure-means-complete psm loc)
    307333  (unless (null? (%procedure-means-incompletes psm))
     
    309335
    310336;; Returns alias
    311 ;;
     337
    312338(define-inline (%procedure-means-alias psm key)
    313339  (dict-ref (%procedure-means-identifier-map psm) key) )
    314340
    315341;; Returns a binding
    316 ;;
     342
    317343(define-inline (%procedure-means-ref psm key)
    318344  (dict-ref (%procedure-means-closure-map psm) key) )
    319345
    320346;; Returns a closure, forces load
    321 ;;
     347
    322348(define-inline (%procedure-means-closure psm key)
    323349  (%procedure-means-load psm)
     
    325351
    326352;;
     353
    327354(define-inline (%procedure-means-set! psm cm im)
    328355  (%procedure-means-finalized-set! psm #f)
     
    331358
    332359;;
     360
    333361(define-inline (%procedure-means-delete! psm key)
    334362  (dict-delete! (%procedure-means-closure-map psm) key)
     
    336364
    337365;;
     366
    338367(define-inline (%procedure-means-loaded? psm)
    339368  (not (memq #f (%procedure-means-loaded psm))) )
    340369
    341370;;
     371
    342372(define (procedure-identifier->closure sym)
    343373  (unless (symbol? sym)
     
    346376
    347377;;
     378
    348379(define DEFAULT-CLOSURE-TAG (gensym))
    349380
    350381;;
     382
    351383(define-inline (default-closure? obj)
    352384  (and (extended-procedure? obj)
     
    357389;; Note that subsequent closure references will be to the loaded procedure
    358390;; & not this default.
    359 ;;
     391
    360392(define (make-default-closure psm sym)
    361393  (extend-procedure
     
    370402
    371403;; Returns procedure symbols in the surface w/o an alias in the means
    372 ;;
     404
    373405(define (%procedure-means-incompletes psm)
    374406  (let ([incmplts '()])
     
    384416
    385417;; Returns procedure symbols in the surface w/o a binding in the means
    386 ;;
     418
    387419(define (%procedure-means-unbounds psm)
    388420  (let ([unbnds '()])
     
    398430
    399431;; Resolve to closure for each procedure symbol
    400 ;;
     432
    401433(define (resolve-closures psm)
    402434  (let ([cm (%procedure-means-closure-map psm)])
     
    412444
    413445;;
     446
    414447(define (perform-load psm)
    415448  (let ([loadeds '()])
     
    439472
    440473;; Performs load if needed
    441 ;;
     474
    442475(define (%procedure-means-load psm)
    443476  (or (%procedure-means-finalized? psm)
     
    451484
    452485;;
     486
    453487(define (parse-procedure-identifier-mapping pim psm)
    454488  (let loop ([pim pim] [pal '()] [sal '()])
     
    483517
    484518;;
     519
    485520(define (make-procedure-means implements
    486521          #!rest procedure-identifier-mapping
     
    529564          ([plt slt]
    530565            (parse-procedure-identifier-mapping
    531               (filter-rest-argument! procedure-identifier-mapping
    532                 '(#:immutable #:extension #:library #:pathname))
     566              (fixup-extended-lambda-list-rest
     567               '(#:immutable #:extension #:library #:pathname)
     568               procedure-identifier-mapping)
    533569              psm)))
    534570        (%procedure-means-closure-map-set! psm plt)
     
    541577
    542578;;
     579
    543580(define (procedure-means? obj)
    544581  (%procedure-means? obj))
    545582
    546583;;
     584
    547585(define (procedure-means-immutable? obj)
    548586  (check-procedure-means obj 'procedure-means-immutable?)
     
    550588
    551589;;
     590
    552591(define (procedure-means-mutable? obj)
    553592  (check-procedure-means obj 'procedure-means-mutable?)
     
    555594
    556595;;
     596
    557597(define (procedure-means-complete? obj)
    558598  (check-procedure-means obj 'procedure-means-complete?)
     
    560600
    561601;;
     602
    562603(define (procedure-means-incompletes obj)
    563604  (check-procedure-means obj 'procedure-means-incompletes)
     
    565606
    566607;;
     608
    567609(define (procedure-means-bound? obj)
    568610  (check-procedure-means obj 'procedure-means-bound?)
     
    570612
    571613;;
     614
    572615(define (procedure-means-unbounds obj)
    573616  (check-procedure-means obj 'procedure-means-unbounds)
     
    575618
    576619;;
     620
    577621(define (procedure-means-implements obj)
    578622  (check-procedure-means obj 'procedure-means-implements)
     
    582626
    583627;; Returns alias
    584 ;;
     628
    585629(define (procedure-means-alias obj key)
    586630  (check-procedure-means obj 'procedure-means-alias)
     
    588632
    589633;; Returns a binding
    590 ;;
     634
    591635(define (procedure-means-ref obj key)
    592636  (check-procedure-means obj 'procedure-means-ref)
     
    594638
    595639;; Returns a closure, forces load
    596 ;;
     640
    597641(define (procedure-means-closure obj key)
    598642  (check-procedure-means obj 'procedure-means-closure)
     
    600644
    601645;; Creates or updates one or more procedure & identifier mappings
    602 ;;
     646
    603647(define (procedure-means-set! obj #!rest pim)
    604648  (check-procedure-means-mutable obj 'procedure-means-set!)
     
    607651
    608652;; Removes a  procedure & identifier mappings. Does not complain when key has no match.
    609 ;;
     653
    610654(define (procedure-means-delete! obj key)
    611655  (check-procedure-means-mutable obj 'procedure-means-delete!)
     
    613657
    614658;;
     659
    615660(define (procedure-means->alist obj)
    616661  (check-procedure-means obj 'procedure-means->alist)
     
    620665;; If any of the combined procedure means is immutable
    621666;; then the composite is immutable.
    622 ;;
     667
    623668(define (make-composite-procedure-means . rest)
    624669  ; Start with nothing
     
    681726
    682727;;
     728
    683729(define (composite-procedure-means? obj)
    684730  (check-procedure-means obj 'composite-procedure-means?)
     
    687733
    688734;; Peform any needed loading & return #t or #f
    689 ;;
     735
    690736(define (procedure-means-load! obj)
    691737  (check-procedure-means obj 'procedure-means-load!)
     
    694740
    695741;; Is this procedure loaded?
    696 ;;
     742
    697743(define (procedure-unbound? obj)
    698744  (default-closure? obj) )
    699745
    700746;; Does this procedure have an alias?
    701 ;;
     747
    702748(define (procedure-means-incomplete-closure? obj sym)
    703749  (check-procedure-means obj 'procedure-means-incomplete-closure?)
  • release/3/procedure-surface/tags/1.0.0/procedure-surface.html

    r8934 r9027  
    155155<div class="section">
    156156<h3>Author</h3>Kon Lovett</div>
    157 <div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>0.3001 Needs lookup-table</li>
    161 <li>0.3 Added support for explicit library pathname</li>
    162 <li>0.2 Needs misc-extn &gt; 2.0</li>
    163 <li>0.1 Initial release</li></ul></div>
    164157<div class="section">
    165158<h3>Requires</h3>
     
    509502<li>future</li></ul></div></div></div>
    510503<div class="section">
     504<h3>Version</h3>
     505<ul>
     506<li>1.0.0 Use of &quot;fixup-extended-lambda-list-rest&quot;.</li>
     507<li>0.301 Needs lookup-table</li>
     508<li>0.3 Added support for explicit library pathname</li>
     509<li>0.2 Needs misc-extn &gt; 2.0</li>
     510<li>0.1 Initial release</li></ul></div>
     511<div class="section">
    511512<h3>License</h3>
    512513<pre>Copyright (c) 2006, Kon Lovett.  All rights reserved.
  • release/3/procedure-surface/tags/1.0.0/procedure-surface.scm

    r8934 r9027  
    1818;;;
    1919
    20 (cond-expand [hygienic-macros
     20(cond-expand
     21  [syntax-case
    2122
    22 (define-syntax (define-procedure-surface expr)
    23   (syntax-case expr ()
    24     [(K NAME REST ...)
    25       (with-syntax (
    26           [(ARG ...)
    27             (map
    28               (lambda (arg)
    29                 (let ([itm (syntax-object->datum arg)])
    30                   (cond
    31                     [(keyword? itm)
    32                       arg]
    33                     [(symbol? itm)
    34                       (datum->syntax-object #'K `',itm)]
    35                     [(list? itm)
    36                       ; Quote literal contracts
    37                       (if (or (null? itm)
    38                               (and (pair? itm)
    39                                     (or (or (eq? '-> (car itm)) (eq? 'procedure (car itm)))
    40                                         (eq? 'or (car itm))
    41                                         (and (pair? (car itm))
    42                                               (or (eq? '-> (caar itm)) (eq? 'procedure (caar itm)))))))
    43                         (datum->syntax-object #'K `',itm)
    44                         arg)]
    45                     [else
    46                       arg])))
    47               #'(REST ...))])
    48         #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
     23    (define-syntax (define-procedure-surface expr)
     24      (syntax-case expr ()
     25        [(K NAME REST ...)
     26          (with-syntax (
     27              [(ARG ...)
     28                (map
     29                  (lambda (arg)
     30                    (let ([itm (syntax-object->datum arg)])
     31                      (cond
     32                        [(keyword? itm)
     33                          arg]
     34                        [(symbol? itm)
     35                          (datum->syntax-object #'K `',itm)]
     36                        [(list? itm)
     37                          ; Quote literal contracts
     38                          (if (or (null? itm)
     39                                  (and (pair? itm)
     40                                        (or (or (eq? '-> (car itm)) (eq? 'procedure (car itm)))
     41                                            (eq? 'or (car itm))
     42                                            (and (pair? (car itm))
     43                                                  (or (eq? '-> (caar itm)) (eq? 'procedure (caar itm)))))))
     44                            (datum->syntax-object #'K `',itm)
     45                            arg)]
     46                        [else
     47                          arg])))
     48                  #'(REST ...))])
     49            #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
    4950
    50 (define-syntax (declare-procedure-means expr)
    51   (syntax-case expr ()
    52     [(K NAME PS REST ...)
    53       (with-syntax (
    54           [(ARG ...)
    55             (let ([pass-thru? #f])
    56               (map
    57                 (lambda (arg)
    58                   (let ([itm (syntax-object->datum arg)])
    59                     (cond
    60                       [pass-thru?
    61                         (set! pass-thru? #f)
    62                         arg]
    63                       [(keyword? itm)
    64                         arg]
    65                       [(symbol? itm)
    66                         (set! pass-thru? #t)
    67                         (datum->syntax-object #'K `',itm)]
    68                       [else
    69                         arg])))
    70                 #'(REST ...)))])
    71         #'(define NAME (make-procedure-means PS ARG ...)))]))
     51    (define-syntax (declare-procedure-means expr)
     52      (syntax-case expr ()
     53        [(K NAME PS REST ...)
     54          (with-syntax (
     55              [(ARG ...)
     56                (let ([pass-thru? #f])
     57                  (map
     58                    (lambda (arg)
     59                      (let ([itm (syntax-object->datum arg)])
     60                        (cond
     61                          [pass-thru?
     62                            (set! pass-thru? #f)
     63                            arg]
     64                          [(keyword? itm)
     65                            arg]
     66                          [(symbol? itm)
     67                            (set! pass-thru? #t)
     68                            (datum->syntax-object #'K `',itm)]
     69                          [else
     70                            arg])))
     71                    #'(REST ...)))])
     72            #'(define NAME (make-procedure-means PS ARG ...)))]))
    7273
    73 (define-syntax call-thru-procedure-means
    74   (syntax-rules ()
    75     [(_ PSM PI)
    76       ((procedure-means-ref PSM 'PI))]
    77     [(_ PSM PI ARG ...)
    78       ((procedure-means-ref PSM 'PI) ARG ...)]))
     74    (define-syntax call-thru-procedure-means
     75      (syntax-rules ()
     76        [(_ PSM PI)
     77          ((procedure-means-ref PSM 'PI))]
     78        [(_ PSM PI ARG ...)
     79          ((procedure-means-ref PSM 'PI) ARG ...)]))
    7980
    80 (define-syntax apply-thru-procedure-means
    81   (syntax-rules ()
    82     [(_ PSM PI ARG ...)
    83       (apply (procedure-means-ref PSM 'PI) ARG ...)]))
     81    (define-syntax apply-thru-procedure-means
     82      (syntax-rules ()
     83        [(_ PSM PI ARG ...)
     84          (apply (procedure-means-ref PSM 'PI) ARG ...)]))
    8485
    85 (define-syntax let-procedure-means
    86   (syntax-rules ()
     86    (define-syntax let-procedure-means
     87      (syntax-rules ()
    8788
    88     [(_ ([(PI ...) PSM]) BODY ...)
    89       (let ([PI (procedure-means-closure PSM 'PI)] ...)
    90         BODY ...)]
     89        [(_ ([(PI ...) PSM]) BODY ...)
     90          (let ([PI (procedure-means-closure PSM 'PI)] ...)
     91            BODY ...)]
    9192
    92     [(_ ([(PI ...) PSM] MORE ...) BODY ...)
    93       (let ([PI (procedure-means-closure PSM 'PI)] ...)
    94         (let-procedure-means (MORE ...)
    95           BODY ...))]
     93        [(_ ([(PI ...) PSM] MORE ...) BODY ...)
     94          (let ([PI (procedure-means-closure PSM 'PI)] ...)
     95            (let-procedure-means (MORE ...)
     96              BODY ...))]
    9697
    97     [(_ ([PI PSM]) BODY ...)
    98       (let ([PI (procedure-means-closure PSM 'PI)])
    99         BODY ...)]
     98        [(_ ([PI PSM]) BODY ...)
     99          (let ([PI (procedure-means-closure PSM 'PI)])
     100            BODY ...)]
    100101
    101     [(_ ([PI PSM] MORE ...) BODY ...)
    102       (let ([PI (procedure-means-closure PSM 'PI)])
    103         (let-procedure-means (MORE ...)
    104           BODY ...))]))
     102        [(_ ([PI PSM] MORE ...) BODY ...)
     103          (let ([PI (procedure-means-closure PSM 'PI)])
     104            (let-procedure-means (MORE ...)
     105              BODY ...))]))
    105106
    106 ;;;
     107    ;;;
    107108
    108 (define-syntax call/means
    109   (syntax-rules ()
    110     [(_ PSM PI)
    111       (call-thru-procedure-means PSM PI)]
    112     [(_ PSM PI ARG ...)
    113       (call-thru-procedure-means PSM PI ARG ...)]))
     109    (define-syntax call/means
     110      (syntax-rules ()
     111        [(_ PSM PI)
     112          (call-thru-procedure-means PSM PI)]
     113        [(_ PSM PI ARG ...)
     114          (call-thru-procedure-means PSM PI ARG ...)]))
    114115
    115 (define-syntax apply/means
    116   (syntax-rules ()
    117     [(_ PSM PI ARG ...)
    118       (apply-thru-procedure-means PSM PI ARG ...)]))
     116    (define-syntax apply/means
     117      (syntax-rules ()
     118        [(_ PSM PI ARG ...)
     119          (apply-thru-procedure-means PSM PI ARG ...)]))
    119120
    120 (define-syntax let/means
    121   (syntax-rules ()
    122     [(_ MORE ...)
    123       (let-procedure-means MORE ...)]))
     121    (define-syntax let/means
     122      (syntax-rules ()
     123        [(_ MORE ...)
     124          (let-procedure-means MORE ...)])) ]
    124125
    125 ][else
     126  [else
    126127
    127 (define-macro (call-thru-procedure-means PSM PI . ARGS)
    128   `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
     128    (define-macro (call-thru-procedure-means PSM PI . ARGS)
     129      `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
    129130
    130 (define-syntax (apply-thru-procedure-means PSM PI . ARGS)
    131   `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
     131    (define-syntax (apply-thru-procedure-means PSM PI . ARGS)
     132      `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
    132133
    133 (define-macro (let-procedure-means FORMS . BODY)
    134   (cond
    135     [(null? FORMS)
    136       `(begin ,@BODY)]
    137     [(pair? FORMS)
    138       (let ([form (car FORMS)]
    139             [REST (cdr FORMS)])
    140         (cond
    141           [(pair? form)
    142             (let ([VAR (car form)]
    143                   [PSM (cadr form)])
    144               (if (pair? VAR)
    145                 `(let
    146                     ,(let loop ([pis VAR] [lst '()])
    147                       (if (null? pis)
    148                         lst
    149                         (let ([PI (car pis)])
    150                           (loop (cdr pis)
    151                                 (cons `(,PI (procedure-means-closure ,PSM ',PI)) lst)))))
    152                   ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
    153                 `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
    154                   ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
    155           [else
    156             (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
    157     [else
    158       (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
     134    (define-macro (let-procedure-means FORMS . BODY)
     135      (cond
     136        [(null? FORMS)
     137          `(begin ,@BODY)]
     138        [(pair? FORMS)
     139          (let ([form (car FORMS)]
     140                [REST (cdr FORMS)])
     141            (cond
     142              [(pair? form)
     143                (let ([VAR (car form)]
     144                      [PSM (cadr form)])
     145                  (if (pair? VAR)
     146                    `(let
     147                        ,(let loop ([pis VAR] [lst '()])
     148                          (if (null? pis)
     149                            lst
     150                            (let ([PI (car pis)])
     151                              (loop (cdr pis)
     152                                    (cons `(,PI (procedure-means-closure ,PSM ',PI)) lst)))))
     153                      ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
     154                    `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
     155                      ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
     156              [else
     157                (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
     158        [else
     159          (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
    159160
    160 ;;;
     161    ;;;
    161162
    162 (define-macro (call/means PSM PI . ARGS)
    163   `(call-thru-procedure-means ,PSM ,PI ,@ARGS) )
     163    (define-macro (call/means PSM PI . ARGS)
     164      `(call-thru-procedure-means ,PSM ,PI ,@ARGS) )
    164165
    165 (define-macro (apply/meansPSM PI . ARGS)
    166   `(apply-thru-procedure-means ,PSM ,PI ,@ARGS) )
     166    (define-macro (apply/meansPSM PI . ARGS)
     167      `(apply-thru-procedure-means ,PSM ,PI ,@ARGS) )
    167168
    168 (define-macro (let/means . MORE)
    169   `(let-procedure-means ,@MORE) )
    170 
    171 ])
     169    (define-macro (let/means . MORE)
     170      `(let-procedure-means ,@MORE) ) ] )
  • release/3/procedure-surface/tags/1.0.0/signature-type.scm

    r8934 r9027  
    11;;;; signature-type.scm
    22;;;; Kon Lovett, May '06
    3 
    4 (use srfi-1 srfi-26 extras utils)
    5 (use lookup-table misc-extn-record misc-extn-control misc-extn-symbol)
    63
    74(eval-when (compile)
     
    3229      make-signature-contract) ) )
    3330
     31(use srfi-1 srfi-26 extras utils)
     32(use lookup-table misc-extn-record misc-extn-control misc-extn-symbol)
     33
    3434;;;
    3535
     
    4646
    4747;;
     48
    4849(define-record-printer (signature-type obj out)
    4950  (fprintf out "#<signature-type ~S ~S ~S ~S ~S>"
  • release/3/procedure-surface/trunk/procedure-surface-eggdoc.scm

    r8935 r9027  
    425425
    426426                (history
     427      (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
    427428      (version "0.301" "Needs lookup-table")
    428429      (version "0.3" "Added support for explicit library pathname")
  • release/3/procedure-surface/trunk/procedure-surface-support.scm

    r8934 r9027  
    2525;;
    2626;; - Allow multiple impl procs for a sig, w/ failure criteria & automatic try?
    27 
    28 (use srfi-1 srfi-2 lolevel extras utils)
    29 (use lookup-table misc-extn-record misc-extn-control misc-extn-list misc-extn-symbol)
    30 (use signature-type)
    3127
    3228(eval-when (compile)
     
    7672      procedure-identifier->closure) ) )
    7773
    78 ;;
     74(use srfi-1 srfi-2 lolevel extras utils)
     75(use lookup-table misc-extn-record misc-extn-control
     76     misc-extn-list misc-extn-dsssl misc-extn-symbol)
     77(use signature-type)
     78
     79;;;
     80
     81;;
     82
    7983(define-inline-unchecked-record-type procedure-signature
    8084  (%make-procedure-signature id contract)
     
    8488
    8589;;
     90
    8691(define-record-printer (procedure-signature obj out)
    8792  (fprintf out "#<procedure-signature ~S ~S>"
     
    9095
    9196;;
     97
    9298(define-inline (check-procedure-signature obj loc)
    9399  (unless (%procedure-signature? obj)
     
    95101
    96102;;
     103
    97104(define (make-procedure-signature id contract)
    98105  (%make-procedure-signature
     
    102109
    103110;;
     111
    104112(define (procedure-signature? obj)
    105113  (%procedure-signature? obj))
    106114
    107115;; Returns the contract or #f when no contract or error
    108 ;;
     116
    109117(define (procedure-signature-identifier obj)
    110118  (check-procedure-signature obj 'procedure-signature-identifier)
     
    112120
    113121;; Returns the contract or #f when no contract or error
    114 ;;
     122
    115123(define (procedure-signature-contract obj)
    116124  (check-procedure-signature obj 'procedure-signature-contract)
     
    122130
    123131;;
     132
    124133(define-inline-unchecked-record-type procedure-surface
    125134  (%make-procedure-surface name immutable signature-map)
     
    130139
    131140;;
     141
    132142(define-inline (check-procedure-surface obj loc)
    133143  (unless (%procedure-surface? obj)
     
    135145
    136146;;
     147
    137148(define-inline (check-procedure-surface-mutable obj loc)
    138149  (check-procedure-surface obj loc)
     
    141152
    142153;;
     154
    143155(define-inline (%procedure-surface-ref ps key)
    144156  (dict-ref (%procedure-surface-signature-map ps) key))
    145157
    146158;;
     159
    147160(define-inline (%procedure-surface-set! ps lt)
    148161  (dict-merge! (%procedure-surface-signature-map ps) lt) )
    149162
    150163;;
     164
    151165(define-inline (%procedure-surface-delete! ps key)
    152166  (dict-delete! (%procedure-surface-signature-map ps) key) )
    153167
    154168;;
     169
    155170(define (parse-procedure-signatures pss)
    156171  (let loop ([pss pss] [pal '()])
     
    170185
    171186;;
     187
    172188(define (make-procedure-surface
    173189          #!rest procedure-signatures
     
    188204    immutable
    189205    (parse-procedure-signatures
    190       (filter-rest-argument! procedure-signatures '(#:immutable #:name)))))
    191 
    192 ;;
     206      (fixup-extended-lambda-list-rest '(#:immutable #:name) procedure-signatures))))
     207
     208;;
     209
    193210(define (procedure-surface? obj)
    194211  (%procedure-surface? obj))
    195212
    196213;;
     214
    197215(define (procedure-surface-name obj)
    198216  (check-procedure-surface obj 'procedure-surface-name)
     
    202220
    203221;;
     222
    204223(define (procedure-surface-immutable? obj)
    205224  (check-procedure-surface obj 'procedure-surface-immutable?)
     
    207226
    208227;;
     228
    209229(define (procedure-surface-mutable? obj)
    210230  (check-procedure-surface obj 'procedure-surface-mutable?)
     
    212232
    213233;; Returns a procedural signature or #f
    214 ;;
     234
    215235(define (procedure-surface-ref obj key)
    216236  (check-procedure-surface obj 'procedure-surface-ref)
     
    218238
    219239;; Creates or updates one or more signatures.
    220 ;;
     240
    221241(define (procedure-surface-set! obj #!rest pss)
    222242  (check-procedure-surface-mutable obj 'procedure-surface-set!)
     
    224244
    225245;; Removes a signature. Does not complain when key has no match.
    226 ;;
     246
    227247(define (procedure-surface-delete! obj key)
    228248  (check-procedure-surface-mutable obj 'procedure-surface-delete!)
     
    230250
    231251;;
     252
    232253(define (procedure-surface->alist obj)
    233254  (check-procedure-surface obj 'procedure-surface->alist)
     
    237258;; If any of the combined procedure surfaces is immutable
    238259;; then the composite is immutable.
    239 ;;
     260
    240261(define (make-composite-procedure-surface . rest)
    241262  ; Start with nothing
     
    270291
    271292;;
     293
    272294(define (composite-procedure-surface? obj)
    273295  (check-procedure-surface obj 'composite-procedure-surface?)
     
    279301
    280302;;
     303
    281304(define-inline-unchecked-record-type procedure-means
    282305  (%make-procedure-means
     
    293316
    294317;;
     318
    295319(define-inline (check-procedure-means obj loc)
    296320  (unless (%procedure-means? obj)
     
    298322
    299323;;
     324
    300325(define-inline (check-procedure-means-mutable obj loc)
    301326  (check-procedure-means obj loc)
     
    304329
    305330;;
     331
    306332(define-inline (%check-procedure-means-complete psm loc)
    307333  (unless (null? (%procedure-means-incompletes psm))
     
    309335
    310336;; Returns alias
    311 ;;
     337
    312338(define-inline (%procedure-means-alias psm key)
    313339  (dict-ref (%procedure-means-identifier-map psm) key) )
    314340
    315341;; Returns a binding
    316 ;;
     342
    317343(define-inline (%procedure-means-ref psm key)
    318344  (dict-ref (%procedure-means-closure-map psm) key) )
    319345
    320346;; Returns a closure, forces load
    321 ;;
     347
    322348(define-inline (%procedure-means-closure psm key)
    323349  (%procedure-means-load psm)
     
    325351
    326352;;
     353
    327354(define-inline (%procedure-means-set! psm cm im)
    328355  (%procedure-means-finalized-set! psm #f)
     
    331358
    332359;;
     360
    333361(define-inline (%procedure-means-delete! psm key)
    334362  (dict-delete! (%procedure-means-closure-map psm) key)
     
    336364
    337365;;
     366
    338367(define-inline (%procedure-means-loaded? psm)
    339368  (not (memq #f (%procedure-means-loaded psm))) )
    340369
    341370;;
     371
    342372(define (procedure-identifier->closure sym)
    343373  (unless (symbol? sym)
     
    346376
    347377;;
     378
    348379(define DEFAULT-CLOSURE-TAG (gensym))
    349380
    350381;;
     382
    351383(define-inline (default-closure? obj)
    352384  (and (extended-procedure? obj)
     
    357389;; Note that subsequent closure references will be to the loaded procedure
    358390;; & not this default.
    359 ;;
     391
    360392(define (make-default-closure psm sym)
    361393  (extend-procedure
     
    370402
    371403;; Returns procedure symbols in the surface w/o an alias in the means
    372 ;;
     404
    373405(define (%procedure-means-incompletes psm)
    374406  (let ([incmplts '()])
     
    384416
    385417;; Returns procedure symbols in the surface w/o a binding in the means
    386 ;;
     418
    387419(define (%procedure-means-unbounds psm)
    388420  (let ([unbnds '()])
     
    398430
    399431;; Resolve to closure for each procedure symbol
    400 ;;
     432
    401433(define (resolve-closures psm)
    402434  (let ([cm (%procedure-means-closure-map psm)])
     
    412444
    413445;;
     446
    414447(define (perform-load psm)
    415448  (let ([loadeds '()])
     
    439472
    440473;; Performs load if needed
    441 ;;
     474
    442475(define (%procedure-means-load psm)
    443476  (or (%procedure-means-finalized? psm)
     
    451484
    452485;;
     486
    453487(define (parse-procedure-identifier-mapping pim psm)
    454488  (let loop ([pim pim] [pal '()] [sal '()])
     
    483517
    484518;;
     519
    485520(define (make-procedure-means implements
    486521          #!rest procedure-identifier-mapping
     
    529564          ([plt slt]
    530565            (parse-procedure-identifier-mapping
    531               (filter-rest-argument! procedure-identifier-mapping
    532                 '(#:immutable #:extension #:library #:pathname))
     566              (fixup-extended-lambda-list-rest
     567               '(#:immutable #:extension #:library #:pathname)
     568               procedure-identifier-mapping)
    533569              psm)))
    534570        (%procedure-means-closure-map-set! psm plt)
     
    541577
    542578;;
     579
    543580(define (procedure-means? obj)
    544581  (%procedure-means? obj))
    545582
    546583;;
     584
    547585(define (procedure-means-immutable? obj)
    548586  (check-procedure-means obj 'procedure-means-immutable?)
     
    550588
    551589;;
     590
    552591(define (procedure-means-mutable? obj)
    553592  (check-procedure-means obj 'procedure-means-mutable?)
     
    555594
    556595;;
     596
    557597(define (procedure-means-complete? obj)
    558598  (check-procedure-means obj 'procedure-means-complete?)
     
    560600
    561601;;
     602
    562603(define (procedure-means-incompletes obj)
    563604  (check-procedure-means obj 'procedure-means-incompletes)
     
    565606
    566607;;
     608
    567609(define (procedure-means-bound? obj)
    568610  (check-procedure-means obj 'procedure-means-bound?)
     
    570612
    571613;;
     614
    572615(define (procedure-means-unbounds obj)
    573616  (check-procedure-means obj 'procedure-means-unbounds)
     
    575618
    576619;;
     620
    577621(define (procedure-means-implements obj)
    578622  (check-procedure-means obj 'procedure-means-implements)
     
    582626
    583627;; Returns alias
    584 ;;
     628
    585629(define (procedure-means-alias obj key)
    586630  (check-procedure-means obj 'procedure-means-alias)
     
    588632
    589633;; Returns a binding
    590 ;;
     634
    591635(define (procedure-means-ref obj key)
    592636  (check-procedure-means obj 'procedure-means-ref)
     
    594638
    595639;; Returns a closure, forces load
    596 ;;
     640
    597641(define (procedure-means-closure obj key)
    598642  (check-procedure-means obj 'procedure-means-closure)
     
    600644
    601645;; Creates or updates one or more procedure & identifier mappings
    602 ;;
     646
    603647(define (procedure-means-set! obj #!rest pim)
    604648  (check-procedure-means-mutable obj 'procedure-means-set!)
     
    607651
    608652;; Removes a  procedure & identifier mappings. Does not complain when key has no match.
    609 ;;
     653
    610654(define (procedure-means-delete! obj key)
    611655  (check-procedure-means-mutable obj 'procedure-means-delete!)
     
    613657
    614658;;
     659
    615660(define (procedure-means->alist obj)
    616661  (check-procedure-means obj 'procedure-means->alist)
     
    620665;; If any of the combined procedure means is immutable
    621666;; then the composite is immutable.
    622 ;;
     667
    623668(define (make-composite-procedure-means . rest)
    624669  ; Start with nothing
     
    681726
    682727;;
     728
    683729(define (composite-procedure-means? obj)
    684730  (check-procedure-means obj 'composite-procedure-means?)
     
    687733
    688734;; Peform any needed loading & return #t or #f
    689 ;;
     735
    690736(define (procedure-means-load! obj)
    691737  (check-procedure-means obj 'procedure-means-load!)
     
    694740
    695741;; Is this procedure loaded?
    696 ;;
     742
    697743(define (procedure-unbound? obj)
    698744  (default-closure? obj) )
    699745
    700746;; Does this procedure have an alias?
    701 ;;
     747
    702748(define (procedure-means-incomplete-closure? obj sym)
    703749  (check-procedure-means obj 'procedure-means-incomplete-closure?)
  • release/3/procedure-surface/trunk/procedure-surface.html

    r8934 r9027  
    155155<div class="section">
    156156<h3>Author</h3>Kon Lovett</div>
    157 <div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>0.3001 Needs lookup-table</li>
    161 <li>0.3 Added support for explicit library pathname</li>
    162 <li>0.2 Needs misc-extn &gt; 2.0</li>
    163 <li>0.1 Initial release</li></ul></div>
    164157<div class="section">
    165158<h3>Requires</h3>
     
    509502<li>future</li></ul></div></div></div>
    510503<div class="section">
     504<h3>Version</h3>
     505<ul>
     506<li>1.0.0 Use of &quot;fixup-extended-lambda-list-rest&quot;.</li>
     507<li>0.301 Needs lookup-table</li>
     508<li>0.3 Added support for explicit library pathname</li>
     509<li>0.2 Needs misc-extn &gt; 2.0</li>
     510<li>0.1 Initial release</li></ul></div>
     511<div class="section">
    511512<h3>License</h3>
    512513<pre>Copyright (c) 2006, Kon Lovett.  All rights reserved.
  • release/3/procedure-surface/trunk/procedure-surface.scm

    r8934 r9027  
    1818;;;
    1919
    20 (cond-expand [hygienic-macros
     20(cond-expand
     21  [syntax-case
    2122
    22 (define-syntax (define-procedure-surface expr)
    23   (syntax-case expr ()
    24     [(K NAME REST ...)
    25       (with-syntax (
    26           [(ARG ...)
    27             (map
    28               (lambda (arg)
    29                 (let ([itm (syntax-object->datum arg)])
    30                   (cond
    31                     [(keyword? itm)
    32                       arg]
    33                     [(symbol? itm)
    34                       (datum->syntax-object #'K `',itm)]
    35                     [(list? itm)
    36                       ; Quote literal contracts
    37                       (if (or (null? itm)
    38                               (and (pair? itm)
    39                                     (or (or (eq? '-> (car itm)) (eq? 'procedure (car itm)))
    40                                         (eq? 'or (car itm))
    41                                         (and (pair? (car itm))
    42                                               (or (eq? '-> (caar itm)) (eq? 'procedure (caar itm)))))))
    43                         (datum->syntax-object #'K `',itm)
    44                         arg)]
    45                     [else
    46                       arg])))
    47               #'(REST ...))])
    48         #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
     23    (define-syntax (define-procedure-surface expr)
     24      (syntax-case expr ()
     25        [(K NAME REST ...)
     26          (with-syntax (
     27              [(ARG ...)
     28                (map
     29                  (lambda (arg)
     30                    (let ([itm (syntax-object->datum arg)])
     31                      (cond
     32                        [(keyword? itm)
     33                          arg]
     34                        [(symbol? itm)
     35                          (datum->syntax-object #'K `',itm)]
     36                        [(list? itm)
     37                          ; Quote literal contracts
     38                          (if (or (null? itm)
     39                                  (and (pair? itm)
     40                                        (or (or (eq? '-> (car itm)) (eq? 'procedure (car itm)))
     41                                            (eq? 'or (car itm))
     42                                            (and (pair? (car itm))
     43                                                  (or (eq? '-> (caar itm)) (eq? 'procedure (caar itm)))))))
     44                            (datum->syntax-object #'K `',itm)
     45                            arg)]
     46                        [else
     47                          arg])))
     48                  #'(REST ...))])
     49            #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
    4950
    50 (define-syntax (declare-procedure-means expr)
    51   (syntax-case expr ()
    52     [(K NAME PS REST ...)
    53       (with-syntax (
    54           [(ARG ...)
    55             (let ([pass-thru? #f])
    56               (map
    57                 (lambda (arg)
    58                   (let ([itm (syntax-object->datum arg)])
    59                     (cond
    60                       [pass-thru?
    61                         (set! pass-thru? #f)
    62                         arg]
    63                       [(keyword? itm)
    64                         arg]
    65                       [(symbol? itm)
    66                         (set! pass-thru? #t)
    67                         (datum->syntax-object #'K `',itm)]
    68                       [else
    69                         arg])))
    70                 #'(REST ...)))])
    71         #'(define NAME (make-procedure-means PS ARG ...)))]))
     51    (define-syntax (declare-procedure-means expr)
     52      (syntax-case expr ()
     53        [(K NAME PS REST ...)
     54          (with-syntax (
     55              [(ARG ...)
     56                (let ([pass-thru? #f])
     57                  (map
     58                    (lambda (arg)
     59                      (let ([itm (syntax-object->datum arg)])
     60                        (cond
     61                          [pass-thru?
     62                            (set! pass-thru? #f)
     63                            arg]
     64                          [(keyword? itm)
     65                            arg]
     66                          [(symbol? itm)
     67                            (set! pass-thru? #t)
     68                            (datum->syntax-object #'K `',itm)]
     69                          [else
     70                            arg])))
     71                    #'(REST ...)))])
     72            #'(define NAME (make-procedure-means PS ARG ...)))]))
    7273
    73 (define-syntax call-thru-procedure-means
    74   (syntax-rules ()
    75     [(_ PSM PI)
    76       ((procedure-means-ref PSM 'PI))]
    77     [(_ PSM PI ARG ...)
    78       ((procedure-means-ref PSM 'PI) ARG ...)]))
     74    (define-syntax call-thru-procedure-means
     75      (syntax-rules ()
     76        [(_ PSM PI)
     77          ((procedure-means-ref PSM 'PI))]
     78        [(_ PSM PI ARG ...)
     79          ((procedure-means-ref PSM 'PI) ARG ...)]))
    7980
    80 (define-syntax apply-thru-procedure-means
    81   (syntax-rules ()
    82     [(_ PSM PI ARG ...)
    83       (apply (procedure-means-ref PSM 'PI) ARG ...)]))
     81    (define-syntax apply-thru-procedure-means
     82      (syntax-rules ()
     83        [(_ PSM PI ARG ...)
     84          (apply (procedure-means-ref PSM 'PI) ARG ...)]))
    8485
    85 (define-syntax let-procedure-means
    86   (syntax-rules ()
     86    (define-syntax let-procedure-means
     87      (syntax-rules ()
    8788
    88     [(_ ([(PI ...) PSM]) BODY ...)
    89       (let ([PI (procedure-means-closure PSM 'PI)] ...)
    90         BODY ...)]
     89        [(_ ([(PI ...) PSM]) BODY ...)
     90          (let ([PI (procedure-means-closure PSM 'PI)] ...)
     91            BODY ...)]
    9192
    92     [(_ ([(PI ...) PSM] MORE ...) BODY ...)
    93       (let ([PI (procedure-means-closure PSM 'PI)] ...)
    94         (let-procedure-means (MORE ...)
    95           BODY ...))]
     93        [(_ ([(PI ...) PSM] MORE ...) BODY ...)
     94          (let ([PI (procedure-means-closure PSM 'PI)] ...)
     95            (let-procedure-means (MORE ...)
     96              BODY ...))]
    9697
    97     [(_ ([PI PSM]) BODY ...)
    98       (let ([PI (procedure-means-closure PSM 'PI)])
    99         BODY ...)]
     98        [(_ ([PI PSM]) BODY ...)
     99          (let ([PI (procedure-means-closure PSM 'PI)])
     100            BODY ...)]
    100101
    101     [(_ ([PI PSM] MORE ...) BODY ...)
    102       (let ([PI (procedure-means-closure PSM 'PI)])
    103         (let-procedure-means (MORE ...)
    104           BODY ...))]))
     102        [(_ ([PI PSM] MORE ...) BODY ...)
     103          (let ([PI (procedure-means-closure PSM 'PI)])
     104            (let-procedure-means (MORE ...)
     105              BODY ...))]))
    105106
    106 ;;;
     107    ;;;
    107108
    108 (define-syntax call/means
    109   (syntax-rules ()
    110     [(_ PSM PI)
    111       (call-thru-procedure-means PSM PI)]
    112     [(_ PSM PI ARG ...)
    113       (call-thru-procedure-means PSM PI ARG ...)]))
     109    (define-syntax call/means
     110      (syntax-rules ()
     111        [(_ PSM PI)
     112          (call-thru-procedure-means PSM PI)]
     113        [(_ PSM PI ARG ...)
     114          (call-thru-procedure-means PSM PI ARG ...)]))
    114115
    115 (define-syntax apply/means
    116   (syntax-rules ()
    117     [(_ PSM PI ARG ...)
    118       (apply-thru-procedure-means PSM PI ARG ...)]))
     116    (define-syntax apply/means
     117      (syntax-rules ()
     118        [(_ PSM PI ARG ...)
     119          (apply-thru-procedure-means PSM PI ARG ...)]))
    119120
    120 (define-syntax let/means
    121   (syntax-rules ()
    122     [(_ MORE ...)
    123       (let-procedure-means MORE ...)]))
     121    (define-syntax let/means
     122      (syntax-rules ()
     123        [(_ MORE ...)
     124          (let-procedure-means MORE ...)])) ]
    124125
    125 ][else
     126  [else
    126127
    127 (define-macro (call-thru-procedure-means PSM PI . ARGS)
    128   `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
     128    (define-macro (call-thru-procedure-means PSM PI . ARGS)
     129      `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
    129130
    130 (define-syntax (apply-thru-procedure-means PSM PI . ARGS)
    131   `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
     131    (define-syntax (apply-thru-procedure-means PSM PI . ARGS)
     132      `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
    132133
    133 (define-macro (let-procedure-means FORMS . BODY)
    134   (cond
    135     [(null? FORMS)
    136       `(begin ,@BODY)]
    137     [(pair? FORMS)
    138       (let ([form (car FORMS)]
    139             [REST (cdr FORMS)])
    140         (cond
    141           [(pair? form)
    142             (let ([VAR (car form)]
    143                   [PSM (cadr form)])
    144               (if (pair? VAR)
    145                 `(let
    146                     ,(let loop ([pis VAR] [lst '()])
    147                       (if (null? pis)
    148                         lst
    149                         (let ([PI (car pis)])
    150                           (loop (cdr pis)
    151                                 (cons `(,PI (procedure-means-closure ,PSM ',PI)) lst)))))
    152                   ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
    153                 `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
    154                   ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
    155           [else
    156             (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
    157     [else
    158       (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
     134    (define-macro (let-procedure-means FORMS . BODY)
     135      (cond
     136        [(null? FORMS)
     137          `(begin ,@BODY)]
     138        [(pair? FORMS)
     139          (let ([form (car FORMS)]
     140                [REST (cdr FORMS)])
     141            (cond
     142              [(pair? form)
     143                (let ([VAR (car form)]
     144                      [PSM (cadr form)])
     145                  (if (pair? VAR)
     146                    `(let
     147                        ,(let loop ([pis VAR] [lst '()])
     148                          (if (null? pis)
     149                            lst
     150                            (let ([PI (car pis)])
     151                              (loop (cdr pis)
     152                                    (cons `(,PI (procedure-means-closure ,PSM ',PI)) lst)))))
     153                      ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
     154                    `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
     155                      ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
     156              [else
     157                (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
     158        [else
     159          (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
    159160
    160 ;;;
     161    ;;;
    161162
    162 (define-macro (call/means PSM PI . ARGS)
    163   `(call-thru-procedure-means ,PSM ,PI ,@ARGS) )
     163    (define-macro (call/means PSM PI . ARGS)
     164      `(call-thru-procedure-means ,PSM ,PI ,@ARGS) )
    164165
    165 (define-macro (apply/meansPSM PI . ARGS)
    166   `(apply-thru-procedure-means ,PSM ,PI ,@ARGS) )
     166    (define-macro (apply/meansPSM PI . ARGS)
     167      `(apply-thru-procedure-means ,PSM ,PI ,@ARGS) )
    167168
    168 (define-macro (let/means . MORE)
    169   `(let-procedure-means ,@MORE) )
    170 
    171 ])
     169    (define-macro (let/means . MORE)
     170      `(let-procedure-means ,@MORE) ) ] )
  • release/3/procedure-surface/trunk/signature-type.scm

    r8934 r9027  
    11;;;; signature-type.scm
    22;;;; Kon Lovett, May '06
    3 
    4 (use srfi-1 srfi-26 extras utils)
    5 (use lookup-table misc-extn-record misc-extn-control misc-extn-symbol)
    63
    74(eval-when (compile)
     
    3229      make-signature-contract) ) )
    3330
     31(use srfi-1 srfi-26 extras utils)
     32(use lookup-table misc-extn-record misc-extn-control misc-extn-symbol)
     33
    3434;;;
    3535
     
    4646
    4747;;
     48
    4849(define-record-printer (signature-type obj out)
    4950  (fprintf out "#<signature-type ~S ~S ~S ~S ~S>"
Note: See TracChangeset for help on using the changeset viewer.