call-with-disarmed-syntax.rkt

#lang racket

(define/contract (syntax-armed? stx)
  (-> syntax? boolean?)
  (define (tainted? v)
    (and (syntax? v) (syntax-tainted? v)))
  (or (syntax-tainted? stx)
      (match (syntax-e stx)
        [(list* as ... b)
         (or (ormap tainted? as) (tainted? b))]
        [(vector as ...)
         (ormap tainted? as)]
        [(hash-table [ks vs] ...)
         (ormap tainted? vs)]
        [(? prefab-struct-key (app struct->vector (vector _ as ...)))
         (ormap tainted? as)]
        [(box a)
         (tainted? a)]
        [_ #f])))

(define/contract (call-with-disarmed-syntax stx proc
                                            #:use-mode? [use-mode? #f]
                                            #:failure-proc [failure-proc #f])
  (->* [(and/c syntax? (not/c syntax-tainted?))
        (-> (and/c syntax? (not/c syntax-armed?))
            (and/c syntax? (not/c syntax-tainted?)))]
       [#:use-mode? any/c
        #:failure-proc (-> any)]
       any)
  (let ([disarmed-stx (syntax-disarm stx #f)])
    (if (syntax-armed? disarmed-stx)
        (if failure-proc
            (failure-proc)
            (raise-arguments-error 'call-with-disarmed-syntax "could not disarm syntax object"
                                   "syntax object" stx))
        (syntax-rearm (proc disarmed-stx) stx use-mode?))))