146 lines
5.2 KiB
Racket
146 lines
5.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide (except-out (all-defined-out) test-delimiter))
|
|
(require "debug.rkt"
|
|
racket/match
|
|
syntax/parse
|
|
syntax/parse/experimental/reflect
|
|
racket/set
|
|
(for-syntax racket/base
|
|
racket/set
|
|
syntax/parse
|
|
"debug.rkt"
|
|
)
|
|
syntax/stx
|
|
racket/list)
|
|
|
|
|
|
(define (delim-identifier=? a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
|
|
(define extract-until
|
|
(case-lambda
|
|
[(r ids keep?)
|
|
(let loop ([r r][val-stxs null])
|
|
(cond
|
|
[(stx-null? r)
|
|
(values #f #f #f)]
|
|
[(and (identifier? (stx-car r))
|
|
(ormap (lambda (id)
|
|
(delim-identifier=? id (stx-car r)))
|
|
ids))
|
|
(values (reverse (if keep?
|
|
(cons (stx-car r) val-stxs)
|
|
val-stxs))
|
|
r
|
|
(stx-car r))]
|
|
[else
|
|
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
|
|
[(r ids) (extract-until r ids #f)]))
|
|
|
|
(define-syntax-rule (call-values values-producing function)
|
|
(call-with-values (lambda () values-producing) function))
|
|
|
|
;; shortcut for treating arguments as syntax objects
|
|
(define-syntax (syntax-lambda stx)
|
|
(syntax-case stx ()
|
|
[(_ (arg ...) body ...)
|
|
(with-syntax ([(temp ...) (generate-temporaries #'(arg ...))])
|
|
#'(lambda (temp ...)
|
|
(with-syntax ([arg temp] ...)
|
|
body ...)))]))
|
|
|
|
;; removes the last element of a list
|
|
(define (drop-last lst)
|
|
(take lst (sub1 (length lst))))
|
|
|
|
(define (test-delimiter)
|
|
(let* ([original #'(a b c d e)]
|
|
[delimiter #'c]
|
|
[expected-before #'(a b)]
|
|
[expected-rest #'(c d e)]
|
|
[expected-delimiter #'c]
|
|
)
|
|
(let-values ([(before rest hit) (extract-until original (list delimiter))])
|
|
;; is there a better way to test equality between two syntaxes?
|
|
(when (not (and (equal? (syntax->datum expected-before)
|
|
(map syntax->datum before))
|
|
(equal? (syntax->datum expected-rest)
|
|
(map syntax->datum rest))
|
|
(equal? (syntax->datum expected-delimiter)
|
|
(syntax->datum hit))))
|
|
(debug "failure: original ~a until ~a\n" (syntax->datum original) (map syntax->datum (list delimiter)))
|
|
(debug " before expected ~a actual ~a\n" (syntax->datum expected-before) (map syntax->datum before))
|
|
(debug " rest expected ~a actual ~a\n" (syntax->datum expected-rest) (map syntax->datum rest))
|
|
(debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
|
|
))))
|
|
|
|
;; better version of caddadadr-type functions
|
|
(define-syntax (list-match stx)
|
|
(define (convert-pattern pattern)
|
|
(syntax-case pattern ()
|
|
[(x ...) (with-syntax ([(x* ...) (map convert-pattern (syntax->list #'(x ...)))])
|
|
#'(list x* ...))]
|
|
[x #'x]))
|
|
(define (extract-variable pattern)
|
|
(define (non-wildcard-identifier? x)
|
|
(and (identifier? x)
|
|
(not (eq? (syntax-e x) '_))))
|
|
(syntax-case pattern ()
|
|
[(a x ...)
|
|
(if (non-wildcard-identifier? #'a)
|
|
#'a
|
|
(or (extract-variable #'a)
|
|
(extract-variable #'(x ...))))]
|
|
[x (if (non-wildcard-identifier? #'x)
|
|
#'x
|
|
#f)]))
|
|
(syntax-case stx ()
|
|
[(_ pattern expression)
|
|
(with-syntax ([match-pattern (convert-pattern #'pattern)]
|
|
[match-variable (extract-variable #'pattern)])
|
|
#'(match expression
|
|
[match-pattern match-variable]))]))
|
|
|
|
;; local-binding and module-binding check that the identifier is bound at the given phase
|
|
(define-syntax (local-binding stx)
|
|
(syntax-parse stx
|
|
[(_ name)
|
|
(define type (identifier-binding #'name))
|
|
(when (not (eq? type 'lexical))
|
|
(raise-syntax-error 'local-binding "not bound locally" #'name))
|
|
#'#'name]))
|
|
|
|
(define-syntax (module-binding stx)
|
|
(syntax-parse stx
|
|
[(_ name level)
|
|
(define type (identifier-binding #'name (syntax-e #'level)))
|
|
(when (not (and (list? type)
|
|
(= (length type) 7)))
|
|
(raise-syntax-error 'module-binding
|
|
(format "not bound by a module at phase ~a" (syntax-e #'level))
|
|
#'name))
|
|
#'#'name]))
|
|
|
|
(define-syntax-rule (literal-syntax-class literal)
|
|
(let ()
|
|
(define-literal-set set (literal))
|
|
(define-syntax-class class
|
|
;; The problem is that 'literal' is unmarked but 'set' is marked.
|
|
;; The #:literal-sets option is kind of like a binding form: only identifiers
|
|
;; having the same marks are treated as literals.
|
|
;; The fix is
|
|
;; #:literal-sets ([set #:at literal])
|
|
;; which means treat any identifier whose name is listed in 'set' and whose lexical context matches 'literal' as a literal.
|
|
;; - Ryan
|
|
#:literal-sets ([set #:at literal])
|
|
[pattern literal])
|
|
(reify-syntax-class class)))
|
|
|
|
(define-syntax (for/union stx)
|
|
(syntax-case stx ()
|
|
[(_ clauses . body)
|
|
#'(for/fold/derived stx ([accum-set (set)])
|
|
clauses
|
|
(set-union accum-set (let () . body)))]))
|