diff --git a/collects/stepper/private/macro-unwind.rkt b/collects/stepper/private/macro-unwind.rkt index 6c798491ba..8b888cbd29 100644 --- a/collects/stepper/private/macro-unwind.rkt +++ b/collects/stepper/private/macro-unwind.rkt @@ -4,362 +4,344 @@ "model-settings.rkt" "shared.rkt") - (provide/contract [unwind (syntax? render-settings? . -> . syntax?)]) - ; - ; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; - ;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; - ; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; - ; - - - ; unwind takes a syntax object with a single highlight, - ; and returns a list of syntax objects +(provide/contract [unwind (syntax? render-settings? . -> . syntax?)]) +; +; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; +;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; +; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; +; - (define (improper-member elt improper-list) - (cond [(pair? improper-list) - (or (eq? elt (car improper-list)) - (improper-member elt (cdr improper-list)))] - [else - (eq? elt improper-list)])) +; unwind takes a syntax object with a single highlight, +; and returns a list of syntax objects - (define-syntax (noisy-and stx) - (syntax-case stx () - [(_) #`#t] - [(_ a b ...) - (with-syntax ([inner (syntax/loc stx (noisy-and b ...))] - [error (syntax/loc #`a - (error 'noisy-and "and clause failed"))]) - (syntax/loc stx (if a inner error)))] - [else - (error 'noisy-and "bad syntax for noisy-and")])) - ;(->* (syntax? (listof syntax?)) - ; (syntax? (listof syntax?))) +(define (improper-member elt improper-list) + (cond [(pair? improper-list) + (or (eq? elt (car improper-list)) + (improper-member elt (cdr improper-list)))] + [else + (eq? elt improper-list)])) - (define (recur-on-pieces stx settings) - (if (pair? (syntax-e stx)) - (datum->syntax - stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx) - stx)) - - (define (fall-through stx settings) - (kernel-syntax-case stx #f - [id - (identifier? stx) - (or (stepper-syntax-property stx 'stepper-lifted-name) - stx)] - [(define-values dc ...) - (unwind-define stx settings)] - ; STC: app special cases from lazy racket - ; extract-if-lazy-proc - can't hide this in lazy.rkt bc it's needed - ; to distinguish the general lazy application - [(#%plain-app proc-extract p) - (or (eq? (syntax->datum #'proc-extract) 'extract-if-lazy-proc) - (eq? (object-name - (with-handlers ; for print output-style - ([(λ (e) #t) (λ (e) #f)]) - (syntax-e (second (syntax-e #'proc-extract))))) - 'extract-if-lazy-proc)) - (unwind #'p settings)] - ; lazy #%app special case: force and delay - [(#%plain-app f arg) - (let ([fn (syntax->datum #'f)]) - (or (eq? fn 'lazy-proc) - (eq? fn 'force) (eq? fn '!) (eq? fn '!!) - (eq? fn '!list) (eq? fn '!!list) - (equal? fn '(#%plain-app parameter-procedure)))) - (unwind #'arg settings)] - ; general lazy application - [(#%plain-app - (#%plain-lambda args1 (#%plain-app (#%plain-app proc p) . args2)) - . args3) - (and (eq? (syntax->datum #'proc) 'extract-if-lazy-proc) - (equal? (syntax->datum (cdr (syntax-e #'args1))) - (syntax->datum #'args2))) - (recur-on-pieces #'args3 settings)] - [(#%plain-app exp ...) - (recur-on-pieces #'(exp ...) settings)] - [(quote datum) - (if (symbol? #'datum) - stx - #'datum)] - [(let-values . rest) - (unwind-mz-let stx settings)] - [(letrec-values . rest) - (unwind-mz-let stx settings)] - [(#%plain-lambda . rest) - (recur-on-pieces #'(lambda . rest) settings)] - [(set! var rhs) - (with-syntax ([unwound-var (or (stepper-syntax-property - #`var 'stepper-lifted-name) - #`var)] - [unwound-body (unwind #`rhs settings)]) - #`(set! unwound-var unwound-body))] - [else (recur-on-pieces stx settings)])) +;(->* (syntax? (listof syntax?)) +; (syntax? (listof syntax?))) - (define (unwind stx settings) - (transfer-info - (let ([hint (stepper-syntax-property stx 'stepper-hint)]) - (if (procedure? hint) - ; STC: For fn hints, I changed the recur procedure to unwind - ; (was recur-on-pieces). This should not affect the non-lazy - ; stepper since it doesnt seem to use any fn hints. - (hint stx (lambda (stx) (unwind stx settings))) - (let ([process (case hint - [(comes-from-cond) unwind-cond] - [(comes-from-and) (unwind-and/or 'and)] - [(comes-from-or) (unwind-and/or 'or)] - [(comes-from-local) unwind-local] - [(comes-from-recur) unwind-recur] - [(comes-from-check-expect) unwind-check-expect] - [(comes-from-check-within) unwind-check-within] - [(comes-from-check-error) unwind-check-error] - ;;[(comes-from-begin) unwind-begin] - [else fall-through])]) - (process stx settings)))) +(define (recur-on-pieces stx settings) + (if (pair? (syntax-e stx)) + (datum->syntax + stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx) stx)) - - (define (transfer-highlight from to) - (if (stepper-syntax-property from 'stepper-highlight) - (stepper-syntax-property to 'stepper-highlight #t) - to)) - - (define (unwind-recur stx settings) - ;; if you use #%app, it gets captured here - (with-syntax ([(app-keywd letrec-term argval ...) stx]) - (with-syntax ([(new-argval ...) - (map (lambda (argval) (unwind argval settings)) (syntax->list #`(argval ...)))]) - (let ([unwound (unwind #`letrec-term settings)]) - (syntax-case unwound (letrec lambda) - [(letrec ([loop-name (lambda (argname ...) . bodies)]) - loop-name-2) - (unless (free-identifier=? #`loop-name #`loop-name-2) - (error "unexpected syntax for 'recur': ~v" stx)) - (transfer-highlight - unwound - #`(recur loop-name ([argname new-argval] ...) . bodies))] - [else #`(#,unwound new-argval ...)]))))) - - (define (unwind-define stx settings) - (kernel-syntax-case stx #f - [(define-values (name . others) body) - (if (null? (syntax-e #'others)) - ;; this is supported: - (let* ([printed-name - (or (stepper-syntax-property #`name 'stepper-lifted-name) - (stepper-syntax-property #'name 'stepper-orig-name) - #'name)] - [unwound-body (unwind #'body settings)] - ;; see notes in internal-docs.txt - [define-type (stepper-syntax-property - unwound-body 'stepper-define-type)]) - (if define-type - (kernel-syntax-case - unwound-body #f - [(lambda arglist lam-body ...) - (case define-type - [(shortened-proc-define) - (let ([proc-define-name - (stepper-syntax-property - unwound-body - 'stepper-proc-define-name)]) - (if (or (free-identifier=? proc-define-name - #'name) - (and (stepper-syntax-property #'name - 'stepper-orig-name) - (free-identifier=? - proc-define-name - (stepper-syntax-property - #'name 'stepper-orig-name)))) - #`(define (#,printed-name . arglist) - lam-body ...) - #`(define #,printed-name - #,unwound-body)))] - [(lambda-define) - #`(define #,printed-name #,unwound-body)] - [else (error 'unwind-define - "unknown value for syntax property 'stepper-define-type: ~e" - define-type)])] + +(define (fall-through stx settings) + (kernel-syntax-case stx #f + [id + (identifier? stx) + (or (stepper-syntax-property stx 'stepper-lifted-name) + stx)] + [(define-values dc ...) + (unwind-define stx settings)] + ; STC: app special cases from lazy racket + ; extract-if-lazy-proc - can't hide this in lazy.rkt bc it's needed + ; to distinguish the general lazy application + [(#%plain-app proc-extract p) + (or (eq? (syntax->datum #'proc-extract) 'extract-if-lazy-proc) + (eq? (object-name + (with-handlers ; for print output-style + ([(λ (e) #t) (λ (e) #f)]) + (syntax-e (second (syntax-e #'proc-extract))))) + 'extract-if-lazy-proc)) + (unwind #'p settings)] + ; lazy #%app special case: force and delay + [(#%plain-app f arg) + (let ([fn (syntax->datum #'f)]) + (or (eq? fn 'lazy-proc) + (eq? fn 'force) (eq? fn '!) (eq? fn '!!) + (eq? fn '!list) (eq? fn '!!list) + (equal? fn '(#%plain-app parameter-procedure)))) + (unwind #'arg settings)] + ; general lazy application + [(#%plain-app + (#%plain-lambda args1 (#%plain-app (#%plain-app proc p) . args2)) + . args3) + (and (eq? (syntax->datum #'proc) 'extract-if-lazy-proc) + (equal? (syntax->datum (cdr (syntax-e #'args1))) + (syntax->datum #'args2))) + (recur-on-pieces #'args3 settings)] + [(#%plain-app exp ...) + (recur-on-pieces #'(exp ...) settings)] + [(quote datum) + (if (symbol? #'datum) + stx + #'datum)] + [(let-values . rest) + (unwind-mz-let stx settings)] + [(letrec-values . rest) + (unwind-mz-let stx settings)] + [(#%plain-lambda . rest) + (recur-on-pieces #'(lambda . rest) settings)] + [(set! var rhs) + (with-syntax ([unwound-var (or (stepper-syntax-property + #`var 'stepper-lifted-name) + #`var)] + [unwound-body (unwind #`rhs settings)]) + #`(set! unwound-var unwound-body))] + [else (recur-on-pieces stx settings)])) + +(define (unwind stx settings) + (transfer-info + (let ([hint (stepper-syntax-property stx 'stepper-hint)]) + (if (procedure? hint) + ; STC: For fn hints, I changed the recur procedure to unwind + ; (was recur-on-pieces). This should not affect the non-lazy + ; stepper since it doesnt seem to use any fn hints. + (hint stx (lambda (stx) (unwind stx settings))) + (let ([process (case hint + [(comes-from-cond) unwind-cond] + [(comes-from-and) (unwind-and/or 'and)] + [(comes-from-or) (unwind-and/or 'or)] + [(comes-from-local) unwind-local] + [(comes-from-recur) unwind-recur] + [(comes-from-check-expect) unwind-check-expect] + [(comes-from-check-within) unwind-check-within] + [(comes-from-check-error) unwind-check-error] + ;; unused: the fake-exp begin takes care of this for us... + ;;[(comes-from-begin) unwind-begin] + [else fall-through])]) + (process stx settings)))) + stx)) + +(define (transfer-highlight from to) + (if (stepper-syntax-property from 'stepper-highlight) + (stepper-syntax-property to 'stepper-highlight #t) + to)) + +(define (unwind-recur stx settings) + ;; if you use #%app, it gets captured here + (with-syntax ([(app-keywd letrec-term argval ...) stx]) + (with-syntax ([(new-argval ...) + (map (lambda (argval) (unwind argval settings)) (syntax->list #`(argval ...)))]) + (let ([unwound (unwind #`letrec-term settings)]) + (syntax-case unwound (letrec lambda) + [(letrec ([loop-name (lambda (argname ...) . bodies)]) + loop-name-2) + (unless (free-identifier=? #`loop-name #`loop-name-2) + (error "unexpected syntax for 'recur': ~v" stx)) + (transfer-highlight + unwound + #`(recur loop-name ([argname new-argval] ...) . bodies))] + [else #`(#,unwound new-argval ...)]))))) + +(define (unwind-define stx settings) + (kernel-syntax-case stx #f + [(define-values (name . others) body) + (if (null? (syntax-e #'others)) + ;; this is supported: + (let* ([printed-name + (or (stepper-syntax-property #`name 'stepper-lifted-name) + (stepper-syntax-property #'name 'stepper-orig-name) + #'name)] + [unwound-body (unwind #'body settings)] + ;; see notes in internal-docs.txt + [define-type (stepper-syntax-property + unwound-body 'stepper-define-type)]) + (if define-type + (kernel-syntax-case + unwound-body #f + [(lambda arglist lam-body ...) + (case define-type + [(shortened-proc-define) + (let ([proc-define-name + (stepper-syntax-property + unwound-body + 'stepper-proc-define-name)]) + (if (or (free-identifier=? proc-define-name + #'name) + (and (stepper-syntax-property #'name + 'stepper-orig-name) + (free-identifier=? + proc-define-name + (stepper-syntax-property + #'name 'stepper-orig-name)))) + #`(define (#,printed-name . arglist) + lam-body ...) + #`(define #,printed-name + #,unwound-body)))] + [(lambda-define) + #`(define #,printed-name #,unwound-body)] [else (error 'unwind-define - "expr with stepper-define-type is not a lambda: ~.s" - (syntax->datum unwound-body))]) - #`(define #,printed-name #,unwound-body))) - ;; this is there just to see the unsupported stuff go by... - #`(define-values (name . others) #,(unwind #'body settings)) - )] - [else (error 'unwind-define - "expression is not a define-values: ~.s" - (syntax->datum stx))])) - - (define (unwind-mz-let stx settings) - (syntax-case stx () - [(label ([(var) rhs] ...) . bodies) - (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] - [new-label - (if (improper-member 'comes-from-let* - (stepper-syntax-property - stx 'stepper-hint)) - #`let* - (case (syntax-e #'label) - [(let-values) #'let] - [(letrec-values) #'letrec]))] - [new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))]) - ;; is this let and the nested one part of a let*? - (syntax-case #`new-bodies (let*) - [((let* bindings inner-body ...)) - (and - (improper-member 'comes-from-let* - (stepper-syntax-property stx 'stepper-hint)) - (same-source? stx (car (syntax->list #`new-bodies)))) - #`(let* #,(append (syntax->list #`([var rhs2] ...)) - (syntax->list #`bindings)) - inner-body ...)] - [else - #`(new-label ([var rhs2] ...) . new-bodies)]))] - [;; it's not part of the language we support... might as well just blow it on out there - (label ([(var ...) rhs] ...) . bodies) - (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] - [new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))]) - #`(label ([(var ...) rhs2] ...) . new-bodies))])) - - (define (unwind-local stx settings) - (kernel-syntax-case stx #f - ;; at least through intermediate, define-values may not occur in - ;; local. - [(letrec-values ([vars exp] ...) body) - (with-syntax ([defns (map (lambda (def) - (unwind def settings)) - (syntax->list - #`((define-values vars exp) ...)))]) - #`(local defns #,(unwind #'body settings)))] - [else (error 'unwind-local - "expected a letrec-values, given: ~.s" - (syntax->datum stx))])) - - ;(define (unwind-quasiquote-the-cons-application stx settings) - ; (syntax-case (recur-on-pieces stx settings) () - ; [(#%app the-cons . rest) - ; (syntax (cons . rest))] - ; [else - ; (error 'reconstruct - ; "unexpected result for unwinding the-cons application")])) - - (define (unwind-cond-clause stx test-stx result-stx settings) - (with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else) - #`else - (unwind test-stx settings))] - [result (unwind result-stx settings)]) - #`(new-test result))) - - (define (unwind-cond stx settings) - (let ([outer-stx stx]) - (with-syntax - ([clauses - (let loop ([stx stx]) - (if (and (same-source? outer-stx stx)) - (syntax-case stx (if begin let-values) - ;; the else clause disappears when it's a - ;; language-inserted else clause - [(if test result) - (list (unwind-cond-clause stx #`test #`result settings))] - [(if test result else-clause) - (cons (unwind-cond-clause stx #`test #`result settings) - (loop (syntax else-clause)))] - ;; else clause appears momentarily in 'before,' even - ;; though it's a 'skip-completely' - [(let-values () . rest) null] - [else-stx - (error 'unwind-cond - "expected an if, got: ~.s" - (syntax->datum (syntax else-stx)))]) + "unknown value for syntax property 'stepper-define-type: ~e" + define-type)])] + [else (error 'unwind-define + "expr with stepper-define-type is not a lambda: ~.s" + (syntax->datum unwound-body))]) + #`(define #,printed-name #,unwound-body))) + ;; this is there just to see the unsupported stuff go by... + #`(define-values (name . others) #,(unwind #'body settings)) + )] + [else (error 'unwind-define + "expression is not a define-values: ~.s" + (syntax->datum stx))])) + +(define (unwind-mz-let stx settings) + (syntax-case stx () + [(label ([(var) rhs] ...) . bodies) + (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] + [new-label + (if (improper-member 'comes-from-let* + (stepper-syntax-property + stx 'stepper-hint)) + #`let* + (case (syntax-e #'label) + [(let-values) #'let] + [(letrec-values) #'letrec]))] + [new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))]) + ;; is this let and the nested one part of a let*? + (syntax-case #`new-bodies (let*) + [((let* bindings inner-body ...)) + (and + (improper-member 'comes-from-let* + (stepper-syntax-property stx 'stepper-hint)) + (same-source? stx (car (syntax->list #`new-bodies)))) + #`(let* #,(append (syntax->list #`([var rhs2] ...)) + (syntax->list #`bindings)) + inner-body ...)] + [else + #`(new-label ([var rhs2] ...) . new-bodies)]))] + [;; it's not part of the language we support... might as well just blow it on out there + (label ([(var ...) rhs] ...) . bodies) + (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] + [new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))]) + #`(label ([(var ...) rhs2] ...) . new-bodies))])) + +(define (unwind-local stx settings) + (kernel-syntax-case stx #f + ;; at least through intermediate, define-values may not occur in + ;; local. + [(letrec-values ([vars exp] ...) body) + (with-syntax ([defns (map (lambda (def) + (unwind def settings)) + (syntax->list + #`((define-values vars exp) ...)))]) + #`(local defns #,(unwind #'body settings)))] + [else (error 'unwind-local + "expected a letrec-values, given: ~.s" + (syntax->datum stx))])) + +;(define (unwind-quasiquote-the-cons-application stx settings) +; (syntax-case (recur-on-pieces stx settings) () +; [(#%app the-cons . rest) +; (syntax (cons . rest))] +; [else +; (error 'reconstruct +; "unexpected result for unwinding the-cons application")])) + +(define (unwind-cond-clause stx test-stx result-stx settings) + (with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else) + #`else + (unwind test-stx settings))] + [result (unwind result-stx settings)]) + #`(new-test result))) + +(define (unwind-cond stx settings) + (let ([outer-stx stx]) + (with-syntax + ([clauses + (let loop ([stx stx]) + (if (and (same-source? outer-stx stx)) + (syntax-case stx (if begin let-values) + ;; the else clause disappears when it's a + ;; language-inserted else clause + [(if test result) + (list (unwind-cond-clause stx #`test #`result settings))] + [(if test result else-clause) + (cons (unwind-cond-clause stx #`test #`result settings) + (loop (syntax else-clause)))] + ;; else clause appears momentarily in 'before,' even + ;; though it's a 'skip-completely' + [(let-values () . rest) null] + [else-stx (error 'unwind-cond - "expected a cond clause expansion, got: ~.s" - (syntax->datum stx))))]) - (syntax (cond . clauses))))) - - ;; unused: the fake-exp begin takes care of this for us... - #;(define (unwind-begin stx settings) - (syntax-case stx (let-values) - [(let-values () body ...) - (with-syntax ([(new-body ...) - (map (lambda (body) (unwind body settings)) (syntax->list #`(body ...)))]) - #`(begin new-body ...))])) - - (define ((unwind-and/or label) stx settings) - (let ([user-source (syntax-property stx 'user-source)] - [user-position (syntax-property stx 'user-position)]) - (with-syntax - ([clauses - (append - (if (render-settings-show-and/or-clauses-consumed? settings) - (build-list (stepper-syntax-property - stx 'stepper-and/or-clauses-consumed) - (let ([clause-padder - (if (render-settings-true-false-printed? settings) - (case label [(and) #'true] [(or) #'false]) - (case label [(and) #'#t] [(or) #'#f]))]) - (lambda (dc) clause-padder))) - '()) - (let loop ([stx stx]) - (if (and (eq? user-source - (syntax-property stx 'user-source)) - (eq? user-position - (syntax-property stx 'user-position))) - (syntax-case stx (if) - [(if part-1 part-2 part-3) - (cons (unwind (syntax part-1) settings) - (case label - [(and) (loop (syntax part-2))] - [(or) (loop (syntax part-3))] - [else (error 'unwind-and/or - "unknown label ~a" label)]))] - [else - (error 'unwind-and/or - "syntax: ~a does not match and/or patterns" - (syntax->datum stx))]) - null)))]) - #`(#,label . clauses)))) - - (define (unwind-check-expect stx settings) - (kernel-syntax-case (fall-through stx settings) #f - [(c-e (lambda () a1) a2 a3 a4) - #`(check-expect a1 a2)] - [(dots1 actual dots2) - (and (eq? (syntax->datum #'dots1) '...) - (eq? (syntax->datum #'dots2) '...)) - (with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)]) - #`(check-expect actual expected))] - [any #`(c-e any) #;#`(check-expect )])) - - (define (unwind-check-within stx settings) - (kernel-syntax-case (fall-through stx settings) #f - [(c-e (lambda () a1) a2 a3 a4 a5) - #`(check-within a1 a2 a3)] - [(dots1 actual dots2) - (and (eq? (syntax->datum #'dots1) '...) - (eq? (syntax->datum #'dots2) '...)) - (let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)]) - (with-syntax ([expected (unwind (third args-of-call) settings)] - [within (unwind (fourth args-of-call) settings)]) + "expected an if, got: ~.s" + (syntax->datum (syntax else-stx)))]) + (error 'unwind-cond + "expected a cond clause expansion, got: ~.s" + (syntax->datum stx))))]) + (syntax (cond . clauses))))) + +(define ((unwind-and/or label) stx settings) + (let ([user-source (syntax-property stx 'user-source)] + [user-position (syntax-property stx 'user-position)]) + (with-syntax + ([clauses + (append + (if (render-settings-show-and/or-clauses-consumed? settings) + (build-list (stepper-syntax-property + stx 'stepper-and/or-clauses-consumed) + (let ([clause-padder + (if (render-settings-true-false-printed? settings) + (case label [(and) #'true] [(or) #'false]) + (case label [(and) #'#t] [(or) #'#f]))]) + (lambda (dc) clause-padder))) + '()) + (let loop ([stx stx]) + (if (and (eq? user-source + (syntax-property stx 'user-source)) + (eq? user-position + (syntax-property stx 'user-position))) + (syntax-case stx (if) + [(if part-1 part-2 part-3) + (cons (unwind (syntax part-1) settings) + (case label + [(and) (loop (syntax part-2))] + [(or) (loop (syntax part-3))] + [else (error 'unwind-and/or + "unknown label ~a" label)]))] + [else + (error 'unwind-and/or + "syntax: ~a does not match and/or patterns" + (syntax->datum stx))]) + null)))]) + #`(#,label . clauses)))) + +(define (unwind-check-expect stx settings) + (kernel-syntax-case (fall-through stx settings) #f + [(c-e (lambda () a1) a2 a3 a4) + #`(check-expect a1 a2)] + [(dots1 actual dots2) + (and (eq? (syntax->datum #'dots1) '...) + (eq? (syntax->datum #'dots2) '...)) + (with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)]) + #`(check-expect actual expected))] + [any #`(c-e any) #;#`(check-expect )])) + +(define (unwind-check-within stx settings) + (kernel-syntax-case (fall-through stx settings) #f + [(c-e (lambda () a1) a2 a3 a4 a5) + #`(check-within a1 a2 a3)] + [(dots1 actual dots2) + (and (eq? (syntax->datum #'dots1) '...) + (eq? (syntax->datum #'dots2) '...)) + (let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)]) + (with-syntax ([expected (unwind (third args-of-call) settings)] + [within (unwind (fourth args-of-call) settings)]) #`(check-within actual expected within)))] - [any #`(c-e any) #;#`(check-expect )])) - - (define (unwind-check-error stx settings) - (kernel-syntax-case (fall-through stx settings) #f - [(c-e (lambda () a1) a2 a3 a4) - #`(check-error a1 a2)] - [(dots1 actual dots2) - (and (eq? (syntax->datum #'dots1) '...) - (eq? (syntax->datum #'dots2) '...)) - (let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)]) - (with-syntax ([expected (unwind (third args-of-call) settings)]) - #`(check-error actual expected)))] - [any #`(c-e any) #;#`(check-expect )])) + [any #`(c-e any) #;#`(check-expect )])) + +(define (unwind-check-error stx settings) + (kernel-syntax-case (fall-through stx settings) #f + [(c-e (lambda () a1) a2 a3 a4) + #`(check-error a1 a2)] + [(dots1 actual dots2) + (and (eq? (syntax->datum #'dots1) '...) + (eq? (syntax->datum #'dots2) '...)) + (let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)]) + (with-syntax ([expected (unwind (third args-of-call) settings)]) + #`(check-error actual expected)))] + [any #`(c-e any) #;#`(check-expect )])) (define (same-source? stx1 stx2) (and (equal? (syntax-property stx1 'user-source)