www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

deriv-util.rkt (2988B)

      1 #lang racket/base
      2 (require (for-syntax racket/base racket/struct-info)
      3          racket/match
      4          "deriv.rkt")
      5 
      6 (provide make
      7 
      8          Wrap
      9          
     10          ok-node?
     11          interrupted-node?
     12 
     13          wderiv-e1
     14          wderiv-e2
     15          wlderiv-es1
     16          wlderiv-es2
     17          wbderiv-es1
     18          wbderiv-es2
     19 
     20          wderivlist-es2)
     21 
     22 ;; Wrap matcher
     23 ;; Matches unwrapped, interrupted wrapped, or error wrapped
     24 (define-match-expander Wrap
     25   (lambda (stx)
     26     (syntax-case stx ()
     27       [(Wrap S (var ...))
     28        (syntax/loc stx (struct S (var ...)))])))
     29 
     30 ;; ----
     31 
     32 (define (check sym pred type x)
     33   (unless (pred x)
     34     (raise-type-error sym type x)))
     35 
     36 (define (ok-node? x)
     37   (check 'ok-node? node? "node" x)
     38   (and (node-z2 x) #t))
     39 (define (interrupted-node? x)
     40   (check 'interrupted-node? node? "node" x)
     41   (not (node-z2 x)))
     42 
     43 
     44 (define (wderiv-e1 x)
     45   (check 'wderiv-e1 deriv? "deriv" x)
     46   (node-z1 x))
     47 (define (wderiv-e2 x)
     48   (check 'wderiv-e2 deriv? "deriv" x)
     49   (node-z2 x))
     50 
     51 (define (wlderiv-es1 x)
     52   (check 'wlderiv-es1 lderiv? "lderiv" x)
     53   (node-z1 x))
     54 (define (wlderiv-es2 x)
     55   (check 'wlderiv-es2 lderiv? "lderiv" x)
     56   (node-z2 x))
     57 
     58 (define (wbderiv-es1 x)
     59   (check 'wbderiv-es1 bderiv? "bderiv" x)
     60   (node-z1 x))
     61 (define (wbderiv-es2 x)
     62   (check 'wbderiv-es2 bderiv? "bderiv" x))
     63 
     64 ;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
     65 (define (wderivlist-es2 xs)
     66   (let ([es2 (map wderiv-e2 xs)])
     67     (and (andmap syntax? es2) es2)))
     68 
     69 ;; get-struct-info : identifier stx -> struct-info-list
     70 (define-for-syntax (get-struct-info id ctx)
     71   (define (bad-struct-name x)
     72     (raise-syntax-error #f "expected struct name" ctx x))
     73   (unless (identifier? id)
     74     (bad-struct-name id))
     75   (let ([value (syntax-local-value id (lambda () #f))])
     76     (unless (struct-info? value)
     77       (bad-struct-name id))
     78     (extract-struct-info value)))
     79 
     80 ;; (make struct-name field-expr ...)
     81 ;; Checks that correct number of fields given.
     82 (define-syntax (make stx)
     83   (syntax-case stx ()
     84     [(make S expr ...)
     85      (let ()
     86        (define info (get-struct-info #'S stx))
     87        (define constructor (list-ref info 1))
     88        (define accessors (list-ref info 3))
     89        (unless (identifier? #'constructor)
     90          (raise-syntax-error #f "constructor not available for struct" stx #'S))
     91        (unless (andmap identifier? accessors)
     92          (raise-syntax-error #f "incomplete info for struct type" stx #'S))
     93        (let ([num-slots (length accessors)]
     94              [num-provided (length (syntax->list #'(expr ...)))])
     95          (unless (= num-provided num-slots)
     96            (raise-syntax-error
     97             #f
     98             (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
     99                     (syntax-e #'S)
    100                     num-slots
    101                     num-provided)
    102             stx)))
    103        (with-syntax ([constructor constructor])
    104          (syntax-property #'(constructor expr ...)
    105                           'disappeared-use
    106                           #'S)))]))