72 lines
2.4 KiB
Racket
72 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
(require syntax/parse
|
|
(for-syntax racket/base
|
|
syntax/parse
|
|
racket/syntax
|
|
phc-toolkit/untyped)
|
|
"parameters.rkt"
|
|
"no-order.rkt"
|
|
"nop.rkt")
|
|
|
|
(provide ~pre-check
|
|
~pre-fail
|
|
~named-seq
|
|
~maybe/empty)
|
|
|
|
(define-eh-mixin-expander ~pre-check
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ pat post)
|
|
(begin (eh-pre-accumulate! '~pre-check #'post)
|
|
#'pat)]
|
|
[(_ post)
|
|
(begin (eh-pre-accumulate! '~pre-check #'post)
|
|
#'(~nop))])))
|
|
|
|
(define-for-syntax (pre-fail stx)
|
|
(syntax-case stx ()
|
|
[(_ message #:when condition)
|
|
(let ()
|
|
(define/with-syntax clause-present (get-new-clause!))
|
|
(eh-pre-accumulate! '~pre-fail
|
|
#`(~fail #:when (and (attribute clause-present)
|
|
condition)
|
|
message))
|
|
#'(~bind [clause-present #t]))]
|
|
[(self #:when condition message)
|
|
(pre-fail #'(self message #:when condition))]
|
|
[(self message #:unless unless-condition)
|
|
(pre-fail #'(self message #:when (not unless-condition)))]
|
|
[(self #:unless unless-condition message)
|
|
(pre-fail #'(self message #:when (not unless-condition)))]))
|
|
|
|
(define-eh-mixin-expander ~pre-fail pre-fail)
|
|
|
|
(define-eh-mixin-expander ~named-seq
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ id . pats)
|
|
(identifier? #'id)
|
|
(let ()
|
|
(define/with-syntax clause-present (get-new-clause!))
|
|
(define/with-syntax clause (get-new-clause!))
|
|
(eh-pre-accumulate! '~named-seq
|
|
#'(~bind [(id 1) (if (attribute clause-present)
|
|
(attribute clause)
|
|
(list))]))
|
|
#'(~and (~bind [clause-present #t])
|
|
(~seq clause (... ...))
|
|
(~seq . pats)))])))
|
|
|
|
(define-eh-mixin-expander ~maybe/empty
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ . pats)
|
|
(let ()
|
|
(define/with-syntax clause-present (get-new-clause!))
|
|
(eh-pre-accumulate! '~maybe/empty
|
|
#'(~parse {~no-order {~seq . pats}}
|
|
#'(clause (... ...))))
|
|
#'{~optional {~and {~bind [clause-present #t]}
|
|
{~seq clause (... ...)}}})]))) |