Changeset 9816 in project


Ignore:
Timestamp:
03/16/08 17:06:07 (12 years ago)
Author:
Kon Lovett
Message:

Removed syntax-case dependency. Full low-level macro support.

Location:
release/3/procedure-surface/trunk
Files:
6 edited

Legend:

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

    r9027 r9816  
    3636                (requires
    3737                        (url "lookup-table.html" "lookup-table")
    38                         (url "syntax-case.html" "syntax-case")
    3938                        (url "misc-extn.html" "misc-extn") )
    4039
     
    425424
    426425                (history
     426      (version "1.1.0" "Full low-level macro support.")
    427427      (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
    428428      (version "0.301" "Needs lookup-table")
  • release/3/procedure-surface/trunk/procedure-surface-support.scm

    r9027 r9816  
    172172    (if (null? pss)
    173173        ;then finished
    174       (alist->dict pal)
     174        (alist->dict pal)
    175175        ;else parse rest
    176       (let ([sym (car pss)]
    177             [nxt (cdr pss)])
    178         (unless (symbol? sym)
    179           (error "procedure identifier must be a symbol" sym))
    180         (when (null? nxt)
    181           (error "missing signature" sym))
    182         (loop
    183           (cdr nxt)
    184           (alist-cons sym (make-procedure-signature sym (car nxt)) pal))))))
    185 
    186 ;;
    187 
    188 (define (make-procedure-surface
    189           #!rest procedure-signatures
    190           #!key (immutable #f) (name #f))
     176        (let ([sym (car pss)]
     177              [nxt (cdr pss)])
     178          (unless (symbol? sym)
     179            (error "procedure identifier must be a symbol" sym))
     180          (when (null? nxt)
     181            (error "missing signature" sym))
     182          (loop (cdr nxt) (alist-cons sym (make-procedure-signature sym (car nxt)) pal))))))
     183
     184;;
     185
     186(define (make-procedure-surface #!rest procedure-signatures #!key (immutable #f) (name #f))
    191187  ;
    192188  (unless name
     
    397393        ; Load could fail, otherwise call-thru
    398394        (if (default-closure? proc)
    399           (error "incomplete procedure; not loaded" sym)
    400           (apply proc args))))
     395            (error "incomplete procedure; not loaded" sym)
     396            (apply proc args))))
    401397    DEFAULT-CLOSURE-TAG))
    402398
     
    499495        (let ([alias (car rst)]
    500496              [cls #f])
    501           (cond
    502             [(boolean? alias)
    503               (set! alias sym)
    504               (set! cls (symbol-value alias))]
    505             [(procedure? alias)
    506               (set! cls alias)
    507               (set! alias '<procedure>)]
    508             [(not (symbol? alias))
    509               (error "procedure alias must be a symbol, procedure, or boolean" sym alias)])
     497          (cond [(boolean? alias)
     498                  (set! alias sym)
     499                  (set! cls (symbol-value alias))]
     500                [(procedure? alias)
     501                  (set! cls alias)
     502                  (set! alias '<procedure>)]
     503                [(not (symbol? alias))
     504                  (error "procedure alias must be a symbol, procedure, or boolean" sym alias)])
    510505          ; Need a closure?
    511506          (unless cls
    512507            (set! cls (make-default-closure psm sym)))
    513           (loop
    514             (cdr rst)
    515             (alist-cons sym cls pal)
    516             (alist-cons sym alias sal)))))))
     508          (loop (cdr rst) (alist-cons sym cls pal) (alist-cons sym alias sal)))))))
    517509
    518510;;
  • release/3/procedure-surface/trunk/procedure-surface.html

    r9027 r9816  
    159159<ul>
    160160<li><a href="lookup-table.html">lookup-table</a></li>
    161 <li><a href="syntax-case.html">syntax-case</a></li>
    162161<li><a href="misc-extn.html">misc-extn</a></li></ul></div>
    163162<div class="section">
     
    504503<h3>Version</h3>
    505504<ul>
     505<li>1.1.0 Full low-level macro support.</li>
    506506<li>1.0.0 Use of &quot;fixup-extended-lambda-list-rest&quot;.</li>
    507507<li>0.301 Needs lookup-table</li>
  • release/3/procedure-surface/trunk/procedure-surface.meta

    r8934 r9816  
    77 (egg "procedure-surface.egg")
    88 (license "BSD")
    9  (needs syntax-case misc-extn lookup-table)
     9 (needs misc-extn lookup-table)
    1010 (files
    1111  "tests"
  • release/3/procedure-surface/trunk/procedure-surface.scm

    r9027 r9816  
    1313;; (which forces an explicit load).
    1414
    15 ; Force for now
    16 (use syntax-case)
    17 
    1815;;;
     16
     17(define-for-syntax (ps$literal-contract? itm)
     18  (or (null? itm)
     19      (and (pair? itm)
     20           (or (or (eq? '-> (car itm))
     21                   (eq? 'procedure (car itm)))
     22               (eq? 'or (car itm))
     23               (and (pair? (car itm))
     24                     (or (eq? '-> (caar itm))
     25                         (eq? 'procedure (caar itm))))))) )
    1926
    2027(cond-expand
    2128  [syntax-case
    2229
    23     (define-syntax (define-procedure-surface expr)
    24       (syntax-case expr ()
     30    (define-syntax (define-procedure-surface X)
     31      (syntax-case X ()
    2532        [(K NAME REST ...)
    2633          (with-syntax (
     
    2936                  (lambda (arg)
    3037                    (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])))
     38                      (cond [(keyword? itm)
     39                              arg]
     40                            [(symbol? itm)
     41                              (datum->syntax-object #'K `',itm)]
     42                            [(list? itm)
     43                              ; Quote literal contracts
     44                              (if (ps$literal-contract? itm)
     45                                  (datum->syntax-object #'K `',itm)
     46                                  arg)]
     47                            [else
     48                              arg])))
    4849                  #'(REST ...))])
    4950            #'(define NAME (make-procedure-surface ARG ... #:name 'NAME)))]))
    5051
    51     (define-syntax (declare-procedure-means expr)
    52       (syntax-case expr ()
     52    (define-syntax (declare-procedure-means X)
     53      (syntax-case X ()
    5354        [(K NAME PS REST ...)
    5455          (with-syntax (
     
    5859                    (lambda (arg)
    5960                      (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])))
     61                        (cond [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])))
    7171                    #'(REST ...)))])
    7272            #'(define NAME (make-procedure-means PS ARG ...)))]))
     
    7474    (define-syntax call-thru-procedure-means
    7575      (syntax-rules ()
     76
    7677        [(_ PSM PI)
    7778          ((procedure-means-ref PSM 'PI))]
     79
    7880        [(_ PSM PI ARG ...)
    7981          ((procedure-means-ref PSM 'PI) ARG ...)]))
     
    109111    (define-syntax call/means
    110112      (syntax-rules ()
     113
    111114        [(_ PSM PI)
    112115          (call-thru-procedure-means PSM PI)]
     116
    113117        [(_ PSM PI ARG ...)
    114118          (call-thru-procedure-means PSM PI ARG ...)]))
     
    126130  [else
    127131
     132    (define-macro (define-procedure-surface NAME . REST)
     133      (let ([ARGS
     134              (map (lambda (arg)
     135                     (cond [(keyword? arg)
     136                             arg]
     137                           [(symbol? arg)
     138                             `',arg]
     139                           [(list? arg)
     140                             ; Quote literal contracts
     141                             (if (ps$literal-contract? arg)
     142                                 `',arg
     143                                 arg)]
     144                           [else
     145                             arg]))
     146                   REST)])
     147        `(define ,NAME (make-procedure-surface ,@ARGS #:name ',NAME))))
     148
     149    (define-macro (declare-procedure-means NAME PS . REST)
     150      (let ([ARGS
     151              (let ([pass-thru? #f])
     152                (map (lambda (arg)
     153                       (cond [pass-thru?
     154                               (set! pass-thru? #f)
     155                               arg]
     156                             [(keyword? arg)
     157                               arg]
     158                             [(symbol? arg)
     159                               (set! pass-thru? #t)
     160                               `',arg]
     161                             [else
     162                               arg]))
     163                     REST))])
     164        `(define ,NAME (make-procedure-means ,PS ,@ARGS)) ) )
     165
    128166    (define-macro (call-thru-procedure-means PSM PI . ARGS)
    129167      `((procedure-means-ref ,PSM ',PI) ,@ARGS) )
    130168
    131     (define-syntax (apply-thru-procedure-means PSM PI . ARGS)
     169    (define-macro (apply-thru-procedure-means PSM PI . ARGS)
    132170      `(apply (procedure-means-ref ,PSM ',PI) ,@ARGS) )
    133171
    134172    (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)]) )
     173      (cond [(null? FORMS)
     174              `(begin ,@BODY)]
     175            [(pair? FORMS)
     176              (let ([form (car FORMS)]
     177                    [REST (cdr FORMS)])
     178                (cond [(pair? form)
     179                        (let ([VAR (car form)]
     180                              [PSM (cadr form)])
     181                          (if (pair? VAR)
     182                            `(let
     183                              ,(let loop ([pis VAR]
     184                                          [lst '()])
     185                                (if (null? pis)
     186                                    lst
     187                                    (let ([PI (car pis)])
     188                                      (loop (cdr pis)
     189                                            (cons `(,PI (procedure-means-closure ,PSM ',PI))
     190                                                  lst)))))
     191                              ,(macroexpand `(let-procedure-means ,REST ,@BODY)))
     192                            `(let ([,VAR (procedure-means-closure ,PSM ',VAR)])
     193                              ,(macroexpand `(let-procedure-means ,REST ,@BODY)))))]
     194                      [else
     195                        (syntax-error 'let-procedure-means "invalid let forms" FORMS)]))]
     196            [else
     197              (syntax-error 'let-procedure-means "invalid let forms" FORMS)]) )
    160198
    161199    ;;;
  • release/3/procedure-surface/trunk/procedure-surface.setup

    r8934 r9816  
    22
    33(required-extension-version
    4   'syntax-case            "6.9988"
    54  'lookup-table           "1.5"
    65  'misc-extn              "3.1")
     
    87(install-dynld signature-type *version*)
    98
    10 (install-dynld+syntax+docu procedure-surface procedure-surface-support *version*
    11         (require-at-runtime lookup-table signature-type))
     9(install-dynld+syntax+docu procedure-surface procedure-surface-support *version*)
    1210
    1311(install-test "procedure-surface-test.scm")
Note: See TracChangeset for help on using the changeset viewer.