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"
"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,
; and returns a list of syntax objects
; unwind takes a syntax object with a single highlight,
; and returns a list of syntax objects
(define (improper-member elt improper-list)
(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-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?)))
;(->* (syntax? (listof syntax?))
; (syntax? (listof syntax?)))
(define (recur-on-pieces 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 (fall-through stx settings)
(define (fall-through stx settings)
(kernel-syntax-case stx #f
[id
(identifier? stx)
@ -102,7 +91,7 @@
#`(set! unwound-var unwound-body))]
[else (recur-on-pieces stx settings)]))
(define (unwind stx settings)
(define (unwind stx settings)
(transfer-info
(let ([hint (stepper-syntax-property stx 'stepper-hint)])
(if (procedure? hint)
@ -119,17 +108,18 @@
[(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)
(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)
(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 ...)
@ -145,7 +135,7 @@
#`(recur loop-name ([argname new-argval] ...) . bodies))]
[else #`(#,unwound new-argval ...)])))))
(define (unwind-define stx settings)
(define (unwind-define stx settings)
(kernel-syntax-case stx #f
[(define-values (name . others) body)
(if (null? (syntax-e #'others))
@ -196,7 +186,7 @@
"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 ()
[(label ([(var) rhs] ...) . bodies)
(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))])
#`(label ([(var ...) rhs2] ...) . new-bodies))]))
(define (unwind-local stx settings)
(define (unwind-local stx settings)
(kernel-syntax-case stx #f
;; at least through intermediate, define-values may not occur in
;; local.
@ -241,22 +231,22 @@
"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-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)
(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)
(define (unwind-cond stx settings)
(let ([outer-stx stx])
(with-syntax
([clauses
@ -282,15 +272,7 @@
(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)
(define ((unwind-and/or label) stx settings)
(let ([user-source (syntax-property stx 'user-source)]
[user-position (syntax-property stx 'user-position)])
(with-syntax
@ -325,7 +307,7 @@
null)))])
#`(#,label . clauses))))
(define (unwind-check-expect stx settings)
(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)]
@ -336,7 +318,7 @@
#`(check-expect actual expected))]
[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
[(c-e (lambda () a1) a2 a3 a4 a5)
#`(check-within a1 a2 a3)]
@ -349,7 +331,7 @@
#`(check-within actual expected within)))]
[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
[(c-e (lambda () a1) a2 a3 a4)
#`(check-error a1 a2)]