101 lines
2.6 KiB
Scheme
101 lines
2.6 KiB
Scheme
|
|
#lang scheme/base
|
|
(require (for-syntax scheme/base)
|
|
(for-syntax scheme/private/struct-info)
|
|
scheme/list
|
|
scheme/match
|
|
"deriv.ss")
|
|
|
|
(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)))
|
|
|
|
;; ----
|
|
|
|
(define-syntax (make stx)
|
|
(syntax-case stx ()
|
|
[(make S expr ...)
|
|
(unless (identifier? #'S)
|
|
(raise-syntax-error #f "not an identifier" stx #'S))
|
|
(let ()
|
|
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
|
|
(define info
|
|
(extract-struct-info
|
|
(syntax-local-value #'S no-info)))
|
|
(define constructor (list-ref info 1))
|
|
(define accessors (list-ref info 3))
|
|
(unless (identifier? #'constructor)
|
|
(raise-syntax-error #f "constructor not available for struct" stx #'S))
|
|
(unless (andmap identifier? accessors)
|
|
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
|
|
(let ([num-slots (length accessors)]
|
|
[num-provided (length (syntax->list #'(expr ...)))])
|
|
(unless (= num-provided num-slots)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "wrong number of arguments for struct ~s (expected ~s)"
|
|
(syntax-e #'S)
|
|
num-slots)
|
|
stx)))
|
|
(with-syntax ([constructor constructor])
|
|
#'(constructor expr ...)))]))
|