suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

retabbing and dead code removal only

Browse Source
This commit is contained in:
John Clements 2011-07-09 13:33:59 -07:00
parent 3d03e8f884
commit ba82f46a07
1 changed files with 328 additions and 346 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
collects/stepper/private/macro-unwind.rkt
View File

@ -4,50 +4,39 @@
"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?)))
(define (recur-on-pieces stx settings)
(if (pair? (syntax-e stx)) (if (pair? (syntax-e stx))
(datum->syntax (datum->syntax
stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx) stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx)
stx)) stx))
(define (fall-through stx settings) (define (fall-through stx settings)
(kernel-syntax-case stx #f (kernel-syntax-case stx #f
[id [id
(identifier? stx) (identifier? stx)
@ -102,7 +91,7 @@
#`(set! unwound-var unwound-body))] #`(set! unwound-var unwound-body))]
[else (recur-on-pieces stx settings)])) [else (recur-on-pieces stx settings)]))
(define (unwind stx settings) (define (unwind stx settings)
(transfer-info (transfer-info
(let ([hint (stepper-syntax-property stx 'stepper-hint)]) (let ([hint (stepper-syntax-property stx 'stepper-hint)])
(if (procedure? hint) (if (procedure? hint)
@ -119,17 +108,18 @@
[(comes-from-check-expect) unwind-check-expect] [(comes-from-check-expect) unwind-check-expect]
[(comes-from-check-within) unwind-check-within] [(comes-from-check-within) unwind-check-within]
[(comes-from-check-error) unwind-check-error] [(comes-from-check-error) unwind-check-error]
;; unused: the fake-exp begin takes care of this for us...
;;[(comes-from-begin) unwind-begin] ;;[(comes-from-begin) unwind-begin]
[else fall-through])]) [else fall-through])])
(process stx settings)))) (process stx settings))))
stx)) stx))
(define (transfer-highlight from to) (define (transfer-highlight from to)
(if (stepper-syntax-property from 'stepper-highlight) (if (stepper-syntax-property from 'stepper-highlight)
(stepper-syntax-property to 'stepper-highlight #t) (stepper-syntax-property to 'stepper-highlight #t)
to)) to))
(define (unwind-recur stx settings) (define (unwind-recur stx settings)
;; if you use #%app, it gets captured here ;; if you use #%app, it gets captured here
(with-syntax ([(app-keywd letrec-term argval ...) stx]) (with-syntax ([(app-keywd letrec-term argval ...) stx])
(with-syntax ([(new-argval ...) (with-syntax ([(new-argval ...)
@ -145,7 +135,7 @@
#`(recur loop-name ([argname new-argval] ...) . bodies))] #`(recur loop-name ([argname new-argval] ...) . bodies))]
[else #`(#,unwound new-argval ...)]))))) [else #`(#,unwound new-argval ...)])))))
(define (unwind-define stx settings) (define (unwind-define stx settings)
(kernel-syntax-case stx #f (kernel-syntax-case stx #f
[(define-values (name . others) body) [(define-values (name . others) body)
(if (null? (syntax-e #'others)) (if (null? (syntax-e #'others))
@ -196,7 +186,7 @@
"expression is not a define-values: ~.s" "expression is not a define-values: ~.s"
(syntax->datum stx))])) (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 ...)))]
@ -227,7 +217,7 @@
[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.
@ -241,22 +231,22 @@
"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
@ -282,15 +272,7 @@
(syntax->datum stx))))]) (syntax->datum stx))))])
(syntax (cond . clauses))))) (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)
(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)] (let ([user-source (syntax-property stx 'user-source)]
[user-position (syntax-property stx 'user-position)]) [user-position (syntax-property stx 'user-position)])
(with-syntax (with-syntax
@ -325,7 +307,7 @@
null)))]) null)))])
#`(#,label . clauses)))) #`(#,label . clauses))))
(define (unwind-check-expect stx settings) (define (unwind-check-expect 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-expect a1 a2)] #`(check-expect a1 a2)]
@ -336,7 +318,7 @@
#`(check-expect actual expected))] #`(check-expect actual expected))]
[any #`(c-e any) #;#`(check-expect )])) [any #`(c-e any) #;#`(check-expect )]))
(define (unwind-check-within 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 a5) [(c-e (lambda () a1) a2 a3 a4 a5)
#`(check-within a1 a2 a3)] #`(check-within a1 a2 a3)]
@ -349,7 +331,7 @@
#`(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)]