69 lines
1.4 KiB
Racket
69 lines
1.4 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/match
|
|
unstable/struct
|
|
"deriv.rkt")
|
|
|
|
(provide make
|
|
|
|
Wrap
|
|
|
|
ok-node?
|
|
interrupted-node?
|
|
|
|
wderiv-e1
|
|
wderiv-e2
|
|
wlderiv-es1
|
|
wlderiv-es2
|
|
wbderiv-es1
|
|
wbderiv-es2
|
|
|
|
wderivlist-es2)
|
|
|
|
;; Wrap matcher
|
|
;; Matches unwrapped, interrupted wrapped, or error wrapped
|
|
(define-match-expander Wrap
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(Wrap S (var ...))
|
|
(syntax/loc stx (struct S (var ...)))])))
|
|
|
|
;; ----
|
|
|
|
(define (check sym pred type x)
|
|
(unless (pred x)
|
|
(raise-type-error sym type x)))
|
|
|
|
(define (ok-node? x)
|
|
(check 'ok-node? node? "node" x)
|
|
(and (node-z1 x) #t))
|
|
(define (interrupted-node? x)
|
|
(check 'interrupted-node? node? "node" x)
|
|
(not (node-z2 x)))
|
|
|
|
|
|
(define (wderiv-e1 x)
|
|
(check 'wderiv-e1 deriv? "deriv" x)
|
|
(node-z1 x))
|
|
(define (wderiv-e2 x)
|
|
(check 'wderiv-e2 deriv? "deriv" x)
|
|
(node-z2 x))
|
|
|
|
(define (wlderiv-es1 x)
|
|
(check 'wlderiv-es1 lderiv? "lderiv" x)
|
|
(node-z1 x))
|
|
(define (wlderiv-es2 x)
|
|
(check 'wlderiv-es2 lderiv? "lderiv" x)
|
|
(node-z2 x))
|
|
|
|
(define (wbderiv-es1 x)
|
|
(check 'wbderiv-es1 bderiv? "bderiv" x)
|
|
(node-z1 x))
|
|
(define (wbderiv-es2 x)
|
|
(check 'wbderiv-es2 bderiv? "bderiv" x))
|
|
|
|
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
|
|
(define (wderivlist-es2 xs)
|
|
(let ([es2 (map wderiv-e2 xs)])
|
|
(and (andmap syntax? es2) es2)))
|