retabbing and dead code removal only
This commit is contained in:
John Clements
parent
3d03e8f884
commit
ba82f46a07
|
|
@ -4,362 +4,344 @@
|
||||||
"model-settings.rkt"
|
"model-settings.rkt"
|
||||||
"shared.rkt")
|
"shared.rkt")
|
||||||
|
|
||||||
(provide/contract [unwind (syntax? render-settings? . -> . syntax?)])
|
(provide/contract [unwind (syntax? render-settings? . -> . syntax?)])
|
||||||
;
|
;
|
||||||
; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ;
|
; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ;
|
||||||
;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;;
|
;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;
|
||||||
; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ;
|
; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ;
|
||||||
;
|
;
|
||||||
|
|
||||||
|
|
||||||
; unwind takes a syntax object with a single highlight,
|
; unwind takes a syntax object with a single highlight,
|
||||||
; and returns a list of syntax objects
|
; and returns a list of syntax objects
|
||||||
|
|
||||||
|
|
||||||
(define (improper-member elt improper-list)
|
(define (improper-member elt improper-list)
|
||||||
(cond [(pair? improper-list)
|
(cond [(pair? improper-list)
|
||||||
(or (eq? elt (car improper-list))
|
(or (eq? elt (car improper-list))
|
||||||
(improper-member elt (cdr improper-list)))]
|
(improper-member elt (cdr improper-list)))]
|
||||||
[else
|
[else
|
||||||
(eq? elt improper-list)]))
|
(eq? elt improper-list)]))
|
||||||
|
|
||||||
(define-syntax (noisy-and stx)
|
;(->* (syntax? (listof syntax?))
|
||||||
(syntax-case stx ()
|
; (syntax? (listof syntax?)))
|
||||||
[(_) #`#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?))
|
(define (recur-on-pieces stx settings)
|
||||||
; (syntax? (listof syntax?)))
|
(if (pair? (syntax-e stx))
|
||||||
|
(datum->syntax
|
||||||
(define (recur-on-pieces stx settings)
|
stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx)
|
||||||
(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)]))
|
|
||||||
|
|
||||||
(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))))
|
|
||||||
stx))
|
stx))
|
||||||
|
|
||||||
(define (transfer-highlight from to)
|
(define (fall-through stx settings)
|
||||||
(if (stepper-syntax-property from 'stepper-highlight)
|
(kernel-syntax-case stx #f
|
||||||
(stepper-syntax-property to 'stepper-highlight #t)
|
[id
|
||||||
to))
|
(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-recur stx settings)
|
(define (unwind stx settings)
|
||||||
;; if you use #%app, it gets captured here
|
(transfer-info
|
||||||
(with-syntax ([(app-keywd letrec-term argval ...) stx])
|
(let ([hint (stepper-syntax-property stx 'stepper-hint)])
|
||||||
(with-syntax ([(new-argval ...)
|
(if (procedure? hint)
|
||||||
(map (lambda (argval) (unwind argval settings)) (syntax->list #`(argval ...)))])
|
; STC: For fn hints, I changed the recur procedure to unwind
|
||||||
(let ([unwound (unwind #`letrec-term settings)])
|
; (was recur-on-pieces). This should not affect the non-lazy
|
||||||
(syntax-case unwound (letrec lambda)
|
; stepper since it doesnt seem to use any fn hints.
|
||||||
[(letrec ([loop-name (lambda (argname ...) . bodies)])
|
(hint stx (lambda (stx) (unwind stx settings)))
|
||||||
loop-name-2)
|
(let ([process (case hint
|
||||||
(unless (free-identifier=? #`loop-name #`loop-name-2)
|
[(comes-from-cond) unwind-cond]
|
||||||
(error "unexpected syntax for 'recur': ~v" stx))
|
[(comes-from-and) (unwind-and/or 'and)]
|
||||||
(transfer-highlight
|
[(comes-from-or) (unwind-and/or 'or)]
|
||||||
unwound
|
[(comes-from-local) unwind-local]
|
||||||
#`(recur loop-name ([argname new-argval] ...) . bodies))]
|
[(comes-from-recur) unwind-recur]
|
||||||
[else #`(#,unwound new-argval ...)])))))
|
[(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 (unwind-define stx settings)
|
(define (transfer-highlight from to)
|
||||||
(kernel-syntax-case stx #f
|
(if (stepper-syntax-property from 'stepper-highlight)
|
||||||
[(define-values (name . others) body)
|
(stepper-syntax-property to 'stepper-highlight #t)
|
||||||
(if (null? (syntax-e #'others))
|
to))
|
||||||
;; this is supported:
|
|
||||||
(let* ([printed-name
|
(define (unwind-recur stx settings)
|
||||||
(or (stepper-syntax-property #`name 'stepper-lifted-name)
|
;; if you use #%app, it gets captured here
|
||||||
(stepper-syntax-property #'name 'stepper-orig-name)
|
(with-syntax ([(app-keywd letrec-term argval ...) stx])
|
||||||
#'name)]
|
(with-syntax ([(new-argval ...)
|
||||||
[unwound-body (unwind #'body settings)]
|
(map (lambda (argval) (unwind argval settings)) (syntax->list #`(argval ...)))])
|
||||||
;; see notes in internal-docs.txt
|
(let ([unwound (unwind #`letrec-term settings)])
|
||||||
[define-type (stepper-syntax-property
|
(syntax-case unwound (letrec lambda)
|
||||||
unwound-body 'stepper-define-type)])
|
[(letrec ([loop-name (lambda (argname ...) . bodies)])
|
||||||
(if define-type
|
loop-name-2)
|
||||||
(kernel-syntax-case
|
(unless (free-identifier=? #`loop-name #`loop-name-2)
|
||||||
unwound-body #f
|
(error "unexpected syntax for 'recur': ~v" stx))
|
||||||
[(lambda arglist lam-body ...)
|
(transfer-highlight
|
||||||
(case define-type
|
unwound
|
||||||
[(shortened-proc-define)
|
#`(recur loop-name ([argname new-argval] ...) . bodies))]
|
||||||
(let ([proc-define-name
|
[else #`(#,unwound new-argval ...)])))))
|
||||||
(stepper-syntax-property
|
|
||||||
unwound-body
|
(define (unwind-define stx settings)
|
||||||
'stepper-proc-define-name)])
|
(kernel-syntax-case stx #f
|
||||||
(if (or (free-identifier=? proc-define-name
|
[(define-values (name . others) body)
|
||||||
#'name)
|
(if (null? (syntax-e #'others))
|
||||||
(and (stepper-syntax-property #'name
|
;; this is supported:
|
||||||
'stepper-orig-name)
|
(let* ([printed-name
|
||||||
(free-identifier=?
|
(or (stepper-syntax-property #`name 'stepper-lifted-name)
|
||||||
proc-define-name
|
(stepper-syntax-property #'name 'stepper-orig-name)
|
||||||
(stepper-syntax-property
|
#'name)]
|
||||||
#'name 'stepper-orig-name))))
|
[unwound-body (unwind #'body settings)]
|
||||||
#`(define (#,printed-name . arglist)
|
;; see notes in internal-docs.txt
|
||||||
lam-body ...)
|
[define-type (stepper-syntax-property
|
||||||
#`(define #,printed-name
|
unwound-body 'stepper-define-type)])
|
||||||
#,unwound-body)))]
|
(if define-type
|
||||||
[(lambda-define)
|
(kernel-syntax-case
|
||||||
#`(define #,printed-name #,unwound-body)]
|
unwound-body #f
|
||||||
[else (error 'unwind-define
|
[(lambda arglist lam-body ...)
|
||||||
"unknown value for syntax property 'stepper-define-type: ~e"
|
(case define-type
|
||||||
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
|
[else (error 'unwind-define
|
||||||
"expr with stepper-define-type is not a lambda: ~.s"
|
"unknown value for syntax property 'stepper-define-type: ~e"
|
||||||
(syntax->datum unwound-body))])
|
define-type)])]
|
||||||
#`(define #,printed-name #,unwound-body)))
|
[else (error 'unwind-define
|
||||||
;; this is there just to see the unsupported stuff go by...
|
"expr with stepper-define-type is not a lambda: ~.s"
|
||||||
#`(define-values (name . others) #,(unwind #'body settings))
|
(syntax->datum unwound-body))])
|
||||||
)]
|
#`(define #,printed-name #,unwound-body)))
|
||||||
[else (error 'unwind-define
|
;; this is there just to see the unsupported stuff go by...
|
||||||
"expression is not a define-values: ~.s"
|
#`(define-values (name . others) #,(unwind #'body settings))
|
||||||
(syntax->datum stx))]))
|
)]
|
||||||
|
[else (error 'unwind-define
|
||||||
|
"expression is not a define-values: ~.s"
|
||||||
|
(syntax->datum stx))]))
|
||||||
|
|
||||||
(define (unwind-mz-let stx settings)
|
(define (unwind-mz-let stx settings)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(label ([(var) rhs] ...) . bodies)
|
[(label ([(var) rhs] ...) . bodies)
|
||||||
(with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))]
|
(with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))]
|
||||||
[new-label
|
[new-label
|
||||||
(if (improper-member 'comes-from-let*
|
(if (improper-member 'comes-from-let*
|
||||||
(stepper-syntax-property
|
(stepper-syntax-property
|
||||||
stx 'stepper-hint))
|
stx 'stepper-hint))
|
||||||
#`let*
|
#`let*
|
||||||
(case (syntax-e #'label)
|
(case (syntax-e #'label)
|
||||||
[(let-values) #'let]
|
[(let-values) #'let]
|
||||||
[(letrec-values) #'letrec]))]
|
[(letrec-values) #'letrec]))]
|
||||||
[new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))])
|
[new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))])
|
||||||
;; is this let and the nested one part of a let*?
|
;; is this let and the nested one part of a let*?
|
||||||
(syntax-case #`new-bodies (let*)
|
(syntax-case #`new-bodies (let*)
|
||||||
[((let* bindings inner-body ...))
|
[((let* bindings inner-body ...))
|
||||||
(and
|
(and
|
||||||
(improper-member 'comes-from-let*
|
(improper-member 'comes-from-let*
|
||||||
(stepper-syntax-property stx 'stepper-hint))
|
(stepper-syntax-property stx 'stepper-hint))
|
||||||
(same-source? stx (car (syntax->list #`new-bodies))))
|
(same-source? stx (car (syntax->list #`new-bodies))))
|
||||||
#`(let* #,(append (syntax->list #`([var rhs2] ...))
|
#`(let* #,(append (syntax->list #`([var rhs2] ...))
|
||||||
(syntax->list #`bindings))
|
(syntax->list #`bindings))
|
||||||
inner-body ...)]
|
inner-body ...)]
|
||||||
[else
|
[else
|
||||||
#`(new-label ([var rhs2] ...) . new-bodies)]))]
|
#`(new-label ([var rhs2] ...) . new-bodies)]))]
|
||||||
[;; it's not part of the language we support... might as well just blow it on out there
|
[;; it's not part of the language we support... might as well just blow it on out there
|
||||||
(label ([(var ...) rhs] ...) . bodies)
|
(label ([(var ...) rhs] ...) . bodies)
|
||||||
(with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))]
|
(with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))]
|
||||||
[new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))])
|
[new-bodies (map (lambda (body) (unwind body settings)) (syntax->list #'bodies))])
|
||||||
#`(label ([(var ...) rhs2] ...) . new-bodies))]))
|
#`(label ([(var ...) rhs2] ...) . new-bodies))]))
|
||||||
|
|
||||||
(define (unwind-local stx settings)
|
(define (unwind-local stx settings)
|
||||||
(kernel-syntax-case stx #f
|
(kernel-syntax-case stx #f
|
||||||
;; at least through intermediate, define-values may not occur in
|
;; at least through intermediate, define-values may not occur in
|
||||||
;; local.
|
;; local.
|
||||||
[(letrec-values ([vars exp] ...) body)
|
[(letrec-values ([vars exp] ...) body)
|
||||||
(with-syntax ([defns (map (lambda (def)
|
(with-syntax ([defns (map (lambda (def)
|
||||||
(unwind def settings))
|
(unwind def settings))
|
||||||
(syntax->list
|
(syntax->list
|
||||||
#`((define-values vars exp) ...)))])
|
#`((define-values vars exp) ...)))])
|
||||||
#`(local defns #,(unwind #'body settings)))]
|
#`(local defns #,(unwind #'body settings)))]
|
||||||
[else (error 'unwind-local
|
[else (error 'unwind-local
|
||||||
"expected a letrec-values, given: ~.s"
|
"expected a letrec-values, given: ~.s"
|
||||||
(syntax->datum stx))]))
|
(syntax->datum stx))]))
|
||||||
|
|
||||||
;(define (unwind-quasiquote-the-cons-application stx settings)
|
;(define (unwind-quasiquote-the-cons-application stx settings)
|
||||||
; (syntax-case (recur-on-pieces stx settings) ()
|
; (syntax-case (recur-on-pieces stx settings) ()
|
||||||
; [(#%app the-cons . rest)
|
; [(#%app the-cons . rest)
|
||||||
; (syntax (cons . rest))]
|
; (syntax (cons . rest))]
|
||||||
; [else
|
; [else
|
||||||
; (error 'reconstruct
|
; (error 'reconstruct
|
||||||
; "unexpected result for unwinding the-cons application")]))
|
; "unexpected result for unwinding the-cons application")]))
|
||||||
|
|
||||||
(define (unwind-cond-clause stx test-stx result-stx settings)
|
(define (unwind-cond-clause stx test-stx result-stx settings)
|
||||||
(with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else)
|
(with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else)
|
||||||
#`else
|
#`else
|
||||||
(unwind test-stx settings))]
|
(unwind test-stx settings))]
|
||||||
[result (unwind result-stx settings)])
|
[result (unwind result-stx settings)])
|
||||||
#`(new-test result)))
|
#`(new-test result)))
|
||||||
|
|
||||||
(define (unwind-cond stx settings)
|
(define (unwind-cond stx settings)
|
||||||
(let ([outer-stx stx])
|
(let ([outer-stx stx])
|
||||||
(with-syntax
|
(with-syntax
|
||||||
([clauses
|
([clauses
|
||||||
(let loop ([stx stx])
|
(let loop ([stx stx])
|
||||||
(if (and (same-source? outer-stx stx))
|
(if (and (same-source? outer-stx stx))
|
||||||
(syntax-case stx (if begin let-values)
|
(syntax-case stx (if begin let-values)
|
||||||
;; the else clause disappears when it's a
|
;; the else clause disappears when it's a
|
||||||
;; language-inserted else clause
|
;; language-inserted else clause
|
||||||
[(if test result)
|
[(if test result)
|
||||||
(list (unwind-cond-clause stx #`test #`result settings))]
|
(list (unwind-cond-clause stx #`test #`result settings))]
|
||||||
[(if test result else-clause)
|
[(if test result else-clause)
|
||||||
(cons (unwind-cond-clause stx #`test #`result settings)
|
(cons (unwind-cond-clause stx #`test #`result settings)
|
||||||
(loop (syntax else-clause)))]
|
(loop (syntax else-clause)))]
|
||||||
;; else clause appears momentarily in 'before,' even
|
;; else clause appears momentarily in 'before,' even
|
||||||
;; though it's a 'skip-completely'
|
;; though it's a 'skip-completely'
|
||||||
[(let-values () . rest) null]
|
[(let-values () . rest) null]
|
||||||
[else-stx
|
[else-stx
|
||||||
(error 'unwind-cond
|
|
||||||
"expected an if, got: ~.s"
|
|
||||||
(syntax->datum (syntax else-stx)))])
|
|
||||||
(error 'unwind-cond
|
(error 'unwind-cond
|
||||||
"expected a cond clause expansion, got: ~.s"
|
"expected an if, got: ~.s"
|
||||||
(syntax->datum stx))))])
|
(syntax->datum (syntax else-stx)))])
|
||||||
(syntax (cond . clauses)))))
|
(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-and/or label) stx settings)
|
||||||
#;(define (unwind-begin stx settings)
|
(let ([user-source (syntax-property stx 'user-source)]
|
||||||
(syntax-case stx (let-values)
|
[user-position (syntax-property stx 'user-position)])
|
||||||
[(let-values () body ...)
|
(with-syntax
|
||||||
(with-syntax ([(new-body ...)
|
([clauses
|
||||||
(map (lambda (body) (unwind body settings)) (syntax->list #`(body ...)))])
|
(append
|
||||||
#`(begin new-body ...))]))
|
(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-and/or label) stx settings)
|
(define (unwind-check-expect stx settings)
|
||||||
(let ([user-source (syntax-property stx 'user-source)]
|
(kernel-syntax-case (fall-through stx settings) #f
|
||||||
[user-position (syntax-property stx 'user-position)])
|
[(c-e (lambda () a1) a2 a3 a4)
|
||||||
(with-syntax
|
#`(check-expect a1 a2)]
|
||||||
([clauses
|
[(dots1 actual dots2)
|
||||||
(append
|
(and (eq? (syntax->datum #'dots1) '...)
|
||||||
(if (render-settings-show-and/or-clauses-consumed? settings)
|
(eq? (syntax->datum #'dots2) '...))
|
||||||
(build-list (stepper-syntax-property
|
(with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)])
|
||||||
stx 'stepper-and/or-clauses-consumed)
|
#`(check-expect actual expected))]
|
||||||
(let ([clause-padder
|
[any #`(c-e any) #;#`(check-expect )]))
|
||||||
(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)
|
(define (unwind-check-within stx settings)
|
||||||
(kernel-syntax-case (fall-through stx settings) #f
|
(kernel-syntax-case (fall-through stx settings) #f
|
||||||
[(c-e (lambda () a1) a2 a3 a4)
|
[(c-e (lambda () a1) a2 a3 a4 a5)
|
||||||
#`(check-expect a1 a2)]
|
#`(check-within a1 a2 a3)]
|
||||||
[(dots1 actual dots2)
|
[(dots1 actual dots2)
|
||||||
(and (eq? (syntax->datum #'dots1) '...)
|
(and (eq? (syntax->datum #'dots1) '...)
|
||||||
(eq? (syntax->datum #'dots2) '...))
|
(eq? (syntax->datum #'dots2) '...))
|
||||||
(with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)])
|
(let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)])
|
||||||
#`(check-expect actual expected))]
|
(with-syntax ([expected (unwind (third args-of-call) settings)]
|
||||||
[any #`(c-e any) #;#`(check-expect )]))
|
[within (unwind (fourth args-of-call) settings)])
|
||||||
|
|
||||||
(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)))]
|
#`(check-within actual expected within)))]
|
||||||
[any #`(c-e any) #;#`(check-expect )]))
|
[any #`(c-e any) #;#`(check-expect )]))
|
||||||
|
|
||||||
(define (unwind-check-error stx settings)
|
(define (unwind-check-error stx settings)
|
||||||
(kernel-syntax-case (fall-through stx settings) #f
|
(kernel-syntax-case (fall-through stx settings) #f
|
||||||
[(c-e (lambda () a1) a2 a3 a4)
|
[(c-e (lambda () a1) a2 a3 a4)
|
||||||
#`(check-error a1 a2)]
|
#`(check-error a1 a2)]
|
||||||
[(dots1 actual dots2)
|
[(dots1 actual dots2)
|
||||||
(and (eq? (syntax->datum #'dots1) '...)
|
(and (eq? (syntax->datum #'dots1) '...)
|
||||||
(eq? (syntax->datum #'dots2) '...))
|
(eq? (syntax->datum #'dots2) '...))
|
||||||
(let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)])
|
(let ([args-of-call (stepper-syntax-property stx 'stepper-args-of-call)])
|
||||||
(with-syntax ([expected (unwind (third args-of-call) settings)])
|
(with-syntax ([expected (unwind (third args-of-call) settings)])
|
||||||
#`(check-error actual expected)))]
|
#`(check-error actual expected)))]
|
||||||
[any #`(c-e any) #;#`(check-expect )]))
|
[any #`(c-e any) #;#`(check-expect )]))
|
||||||
|
|
||||||
(define (same-source? stx1 stx2)
|
(define (same-source? stx1 stx2)
|
||||||
(and (equal? (syntax-property stx1 'user-source)
|
(and (equal? (syntax-property stx1 'user-source)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user