From f042eb1e4df9a5b790adeaf09b4eab61f28fc008 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 15 Nov 2009 07:37:56 +0000 Subject: [PATCH] macro-debugger: eliminated deriv-find, use unstable/find svn: r16775 --- collects/macro-debugger/model/debug.ss | 2 - collects/macro-debugger/model/deriv-find.ss | 238 ------------------- collects/macro-debugger/model/deriv-util.ss | 31 +-- collects/macro-debugger/model/steps.ss | 3 +- collects/macro-debugger/view/step-display.ss | 1 - collects/macro-debugger/view/stepper.ss | 1 - collects/macro-debugger/view/term-record.ss | 38 ++- 7 files changed, 32 insertions(+), 282 deletions(-) delete mode 100644 collects/macro-debugger/model/deriv-find.ss diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index cfdc5a93a9..3ba4ad0b98 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -5,7 +5,6 @@ "reductions.ss" "reductions-config.ss" "deriv-util.ss" - "deriv-find.ss" "hiding-policies.ss" "deriv.ss" "steps.ss") @@ -15,7 +14,6 @@ (all-from-out "reductions-config.ss") (all-from-out "deriv.ss") (all-from-out "deriv-util.ss") - (all-from-out "deriv-find.ss") (all-from-out "hiding-policies.ss") (all-from-out "steps.ss") (all-from-out scheme/match)) diff --git a/collects/macro-debugger/model/deriv-find.ss b/collects/macro-debugger/model/deriv-find.ss deleted file mode 100644 index 5211c22f98..0000000000 --- a/collects/macro-debugger/model/deriv-find.ss +++ /dev/null @@ -1,238 +0,0 @@ - -#lang scheme/base -(require scheme/match - scheme/list - syntax/stx - "deriv-c.ss" - "deriv-util.ss") -(provide find-derivs - find-deriv - find-derivs/syntax - extract-all-fresh-names - compute-shift-table - flatten-identifiers) - -;; Utilities for finding subderivations - -;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv) -(define (find-derivs pred stop-short d) - (let ([stop (lambda (x) (or (pred x) (stop-short x)))]) - (find-deriv/unit+join+zero pred stop d list append null))) - -;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f -;; Finds the first deriv that matches; throws the rest away -(define (find-deriv pred stop-short d) - (let* ([stop-short (or stop-short (lambda (x) #f))] - [stop (lambda (x) (or (pred x) (stop-short x)))]) - (let/ec return (find-deriv/unit+join+zero pred stop d return (lambda _ #f) #f)))) - -;; find-deriv/unit+join+zero -;; Parameterized over monad operations for combining the results -;; For example, collects the results into a list -(define (find-deriv/unit+join+zero pred stop-short d unit join zero) - (define (loop d) - (if (pred d) - (join (unit d) (loop-inner d)) - (loop-inner d))) - (define (loop-inner d) - (match d - [(? stop-short d) zero] - [(Wrap mrule (_ _ _ _ _ locals _ _ _ next)) - (join (loops locals) (loop next))] - [(Wrap tagrule (_ _ _ next)) - (loop next)] - [(Wrap lift-deriv (_ _ first lift second)) - (join (loop first) (loop second))] - [(struct local-expansion (_ _ _ _ deriv _ _ _)) - (loop deriv)] - [(struct local-bind (_ _ _ bindrhs)) - (loop bindrhs)] - [(Wrap p:define-syntaxes (_ _ _ _ rhs _)) - (loop rhs)] - [(Wrap p:define-values (_ _ _ _ rhs)) - (loop rhs)] - [(Wrap p:#%expression (_ _ _ _ inner _)) - (loop inner)] - [(Wrap p:if (_ _ _ _ test then else)) - (join (loop test) (loop then) (loop else))] - [(Wrap p:wcm (_ _ _ _ key value body)) - (join (loop key) (loop value) (loop body))] - [(Wrap p:set! (_ _ _ _ _ rhs)) - (loop rhs)] - [(Wrap p:set!-macro (_ _ _ _ deriv)) - (loop deriv)] - [(Wrap p:begin (_ _ _ _ lderiv)) - (loop lderiv)] - [(Wrap p:begin0 (_ _ _ _ first lderiv)) - (join (loop first) (loop lderiv))] - [(Wrap p:#%app (_ _ _ _ lderiv)) - (loop lderiv)] - [(Wrap p:lambda (_ _ _ _ _ body)) - (loop body)] - [(Wrap p:case-lambda (_ _ _ _ rbs)) - (apply join (map loop (or rbs null)))] - [(Wrap p:let-values (_ _ _ _ _ rhss body)) - (join (loops rhss) (loop body))] - [(Wrap p:letrec-values (_ _ _ _ _ rhss body)) - (join (loops rhss) (loop body))] - [(Wrap p:letrec-syntaxes+values (_ _ _ _ _ srhss _ vrhss body _)) - (join (loops srhss) (loops vrhss) (loop body))] - [(Wrap p:provide (_ _ _ _ inners _)) - (loops inners)] - [(Wrap p:module (_ _ _ _ _ _ _ check _ _ body _)) - (join (loop check) (loop body))] - [(Wrap p:#%module-begin (_ _ _ _ _ pass1 pass2 _)) - (join (loops pass1) (loops pass2))] - [(Wrap lderiv (_ _ _ derivs)) - (loops derivs)] - [(Wrap bderiv (_ _ pass1 _ pass2)) - (join (loops pass1) (loop pass2))] - [(Wrap b:defvals (_ head _ _ _)) - (loop head)] - [(Wrap b:defstx (_ deriv _ _ _ rhs)) - (join (loop deriv) (loop rhs))] - [(Wrap b:splice (_ head _ _ _)) - (loop head)] - [(Wrap b:expr (_ head)) - (loop head)] - ;;[(Wrap b:begin (_ head inner)) - ;; (join (loop head) (loop inner))] - [(Wrap mod:cons (head)) - (loop head)] - [(Wrap mod:prim (head _ prim)) - (join (loop head) (loop prim))] - [(Wrap mod:splice (head _ _ _)) - (loop head)] - [(Wrap mod:lift (head _ tail)) - (join (loop head) (loop tail))] - [(Wrap mod:lift-end (tail)) - (loop tail)] - [(Wrap clc (_ _ body)) - (loop body)] - [(Wrap bind-syntaxes (rhs _)) - (loop rhs)] - - [else zero])) - - (define (loops ds) - (if (list? ds) - (apply join (map loop ds)) - zero)) - (loop d)) - -(define (find-derivs/syntax pred d) - (find-derivs (match-lambda - [(Wrap deriv (e1 e2)) - (pred e1)] - [_ #f]) - (lambda _ #f) - d)) - -;; extract-all-fresh-names : Derivation -> (listof identifier) -(define (extract-all-fresh-names d) - (define ht (make-hasheq)) - (define (add stxish) - (for-each (lambda (id) (hash-set! ht id #t)) - (flatten-identifiers stxish))) - (define (renaming-node? x) - (or (p:lambda? x) - ;;(p:case-lambda? x) - (clc? x) - (p:let-values? x) - (p:letrec-values? x) - (p:letrec-syntaxes+values? x) - (b:defvals? x) - (b:defstx? x) - (p:define-values? x) - (p:define-syntaxes? x))) - (define (extract-fresh-names d) - (match d - [(Wrap p:lambda (e1 e2 rs ?1 renames body)) - (when renames - (with-syntax ([(?formals . ?body) renames]) - (add #'?formals)))] - [(Wrap clc (_ renames _)) - (when renames - (with-syntax ([(?formals . ?body) renames]) - (add #'?formals)))] - [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) - (when renames - (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) - (add #'(?vars ...))))] - [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) - (when renames - (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) - (add #'(?vars ...))))] - [(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames _ _ _)) - (when srenames - (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) - srenames]) - (add #'(?svars ... ?vvars ...)))) - (when vrenames - (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames]) - (add #'(?vvars ...))))] - [(Wrap b:defvals (rename head ?1 rename2 ?2)) - (let ([head-e2 (wderiv-e2 head)]) - (when head-e2 - (with-syntax ([(?dv ?vars ?rhs) head-e2]) - (add #'?vars))))] - [(Wrap b:defstx (rename head ?1 rename2 ?2 rhs)) - (let ([head-e2 (wderiv-e2 head)]) - (when head-e2 - (with-syntax ([(?ds ?svars ?rhs) head-e2]) - (add #'?svars))))] - [(Wrap p:define-values (e1 e2 rs ?1 rhs)) - (when rhs - (with-syntax ([(?dv ?vars ?rhs) e1]) - (add #'?vars)))] - [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs _)) - (when rhs - (with-syntax ([(?ds ?svars ?srhs) e1]) - (add #'?svars)))] - [_ (void)])) - (define renaming-forms - (find-deriv/unit+join+zero renaming-node? - (lambda (d) #f) - d - list - append - null)) - (for ([rf renaming-forms]) - (extract-fresh-names rf)) - (hash-map ht (lambda (k v) k))) - -;; compute-shift-table : deriv -> hash[id => (listof id)] -(define (compute-shift-table d) - (define ht (make-hasheq)) - (define module-forms - (find-derivs p:module? (lambda _ #f) d)) - (define module-shift-renamers - (for/list ([mf module-forms]) - (let ([shift (p:module-shift mf)] - [body (p:module-body mf)]) - (and shift body - (with-syntax ([(_module _name _lang shifted-body) shift]) - (add-rename-mapping ht (wderiv-e2 body) #'shifted-body)))))) - ht) - -(define (add-rename-mapping ht from to) - (define (loop from to) - (cond [(and (stx-pair? from) (stx-pair? to)) - (loop (stx-car from) (stx-car to)) - (loop (stx-cdr from) (stx-cdr to))] - [(and (identifier? from) (identifier? to)) - (hash-set! ht from (cons to (hash-ref ht from null)))] - [else (void)])) - (loop from to) - (void)) - -;; flatten-identifiers : syntaxlike -> (list-of identifier) -(define (flatten-identifiers stx) - (syntax-case stx () - [id (identifier? #'id) (list #'id)] - [() null] - [(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))] - [else (error 'flatten-identifers "neither syntax list nor identifier: ~s" - (if (syntax? stx) - (syntax->datum stx) - stx))])) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 951dd2c841..ee8afd2c60 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -4,6 +4,7 @@ (for-syntax scheme/private/struct-info) scheme/list scheme/match + unstable/struct "deriv.ss") (provide make @@ -68,33 +69,3 @@ (define (wderivlist-es2 xs) (let ([es2 (map wderiv-e2 xs)]) (and (andmap syntax? es2) es2))) - -;; ---- - -(define-syntax (make stx) - (syntax-case stx () - [(make S expr ...) - (unless (identifier? #'S) - (raise-syntax-error #f "not an identifier" stx #'S)) - (let () - (define (no-info) (raise-syntax-error #f "not a struct" stx #'S)) - (define info - (extract-struct-info - (syntax-local-value #'S no-info))) - (define constructor (list-ref info 1)) - (define accessors (list-ref info 3)) - (unless (identifier? #'constructor) - (raise-syntax-error #f "constructor not available for struct" stx #'S)) - (unless (andmap identifier? accessors) - (raise-syntax-error #f "incomplete info for struct type" stx #'S)) - (let ([num-slots (length accessors)] - [num-provided (length (syntax->list #'(expr ...)))]) - (unless (= num-provided num-slots) - (raise-syntax-error - #f - (format "wrong number of arguments for struct ~s (expected ~s)" - (syntax-e #'S) - num-slots) - stx))) - (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index a1fe495801..b75d7b4943 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "deriv.ss" - "deriv-util.ss" - "deriv-find.ss") + "deriv-util.ss") (provide (struct-out protostep) (struct-out step) (struct-out misstep) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index 355a940b35..5a9196a942 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -15,7 +15,6 @@ "hiding-panel.ss" "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/deriv-parser.ss" "../model/trace.ss" "../model/reductions-config.ss" diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 41b44b8ac3..ccc89924c3 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -18,7 +18,6 @@ (prefix-in sb: "../syntax-browser/interfaces.ss") "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/trace.ss" "../model/reductions.ss" "../model/steps.ss" diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index e13daf5cad..2fc563725e 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -7,6 +7,8 @@ scheme/gui framework/framework syntax/boundmap + syntax/stx + unstable/find "interfaces.ss" "prefs.ss" "extensions.ss" @@ -15,7 +17,6 @@ "step-display.ss" "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/deriv-parser.ss" "../model/trace.ss" "../model/reductions-config.ss" @@ -135,13 +136,8 @@ (when (not d) (set! deriv-hidden? #t)) (when d - (let ([alpha-table (make-module-identifier-mapping)] - [binder-ids (extract-all-fresh-names d)]) - (for-each (lambda (id) - (module-identifier-mapping-put! alpha-table id id)) - binder-ids) - (set! deriv d) - (set! shift-table (compute-shift-table d))))))))) + (set! deriv d) + (set! shift-table (compute-shift-table d)))))))) ;; recache-synth! : -> void (define/private (recache-synth!) @@ -317,3 +313,29 @@ [else (error 'term-record::display-oops "internal error")])) )) + + +;; compute-shift-table : deriv -> hash[id => (listof id)] +(define (compute-shift-table d) + (define ht (make-hasheq)) + (define module-forms + (find p:module? d #:stop-on-found? #t)) + (define module-shift-renamers + (for/list ([mf module-forms]) + (let ([shift (p:module-shift mf)] + [body (p:module-body mf)]) + (and shift body + (with-syntax ([(_module _name _lang shifted-body) shift]) + (add-rename-mapping ht (wderiv-e2 body) #'shifted-body)))))) + ht) + +(define (add-rename-mapping ht from to) + (define (loop from to) + (cond [(and (stx-pair? from) (stx-pair? to)) + (loop (stx-car from) (stx-car to)) + (loop (stx-cdr from) (stx-cdr to))] + [(and (identifier? from) (identifier? to)) + (hash-set! ht from (cons to (hash-ref ht from null)))] + [else (void)])) + (loop from to) + (void))