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

changed macro-debugger to use v4 syntax (mostly)

Browse Source 
svn: r8544

original commit: 13a3c31ad5f63115427cfd34df285c0e981a8107
This commit is contained in:
Ryan Culpepper 2008-02-05 21:56:49 +00:00
parent e56b4cdb71
commit dae9aa6eee
46 changed files with 7062 additions and 7118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/macro-debugger/expand.ss
View File

@ -1,5 +1,4 @@
(module expand mzscheme
#lang scheme/base
(require "model/trace.ss"
"model/hide.ss")
(provide expand-only
@ -7,13 +6,13 @@
(define (expand-only stx show-list)
(define (show? id)
(ormap (lambda (x) (module-identifier=? id x))
(ormap (lambda (x) (free-identifier=? id x))
show-list))
(expand/hiding stx show?))
(define (expand/hide stx hide-list)
(define (show? id)
(andmap (lambda (x) (not (module-identifier=? id x)))
(andmap (lambda (x) (not (free-identifier=? id x)))
hide-list))
(expand/hiding stx show?))
@ -23,5 +22,3 @@
(raise result))
(let-values ([(_d estx) (hide/policy deriv show?)])
estx)))
)

23
collects/macro-debugger/model/context.ss
View File

@ -1,8 +1,8 @@
#lang scheme/base
(module context mzscheme
(require (lib "stx.ss" "syntax"))
(provide (struct ref (n))
(struct tail (n))
(require syntax/stx)
(provide (struct-out ref)
(struct-out tail)
path-get
pathseg-get
path-replace
@ -17,9 +17,9 @@
;; - (make-ref number)
;; - (make-tail number)
(define-struct pathseg () #f)
(define-struct (ref pathseg) (n) #f)
(define-struct (tail pathseg) (n) #f)
(define-struct pathseg () #:transparent)
(define-struct (ref pathseg) (n) #:transparent)
(define-struct (tail pathseg) (n) #:transparent)
;; path:ref->splicing-tail : PathSeg -> ???
;; ????
@ -48,7 +48,7 @@
(unless (stx-pair? stx)
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
n0
(syntax-object->datum stx0)))
(syntax->datum stx0)))
(if (zero? n)
(stx-car stx)
(loop (sub1 n) (stx-cdr stx)))))
@ -104,7 +104,7 @@
(cond [(pair? stx)
(cons x (cdr stx))]
[(syntax? stx)
(datum->syntax-object stx (cons x (cdr (syntax-e stx))) stx stx)]
(datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)]
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
;; stx-replcdr : syntax syntax -> syntax
@ -112,11 +112,11 @@
(cond [(pair? stx)
(cons (car stx) x)]
[(and (syntax? stx) (pair? (syntax-e stx)))
(datum->syntax-object stx (cons (car (syntax-e stx)) x) stx stx)]
(datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)]
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
(define (sd x)
(syntax-object->datum (datum->syntax-object #f x)))
(syntax->datum (datum->syntax #f x)))
;;=======
@ -139,4 +139,3 @@
(outer-loop term)))))]
;; FIXME: more structured cases here: box, vector, ...
[else null])))
)

26
collects/macro-debugger/model/debug.ss
View File

@ -1,7 +1,8 @@
(module debug mzscheme
(require (lib "plt-match.ss"))
(require "trace.ss"
#lang scheme/base
(require scheme/match
"trace.ss"
"reductions.ss"
"deriv-util.ss"
"deriv-find.ss"
@ -10,13 +11,12 @@
"deriv.ss"
"steps.ss")
(provide (all-from "trace.ss")
(all-from "reductions.ss")
(all-from "deriv.ss")
(all-from "deriv-util.ss")
(all-from "deriv-find.ss")
(all-from "hiding-policies.ss")
(all-from "hide.ss")
(all-from "steps.ss")
(all-from (lib "plt-match.ss")))
)
(provide (all-from-out "trace.ss")
(all-from-out "reductions.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 "hide.ss")
(all-from-out "steps.ss")
(all-from-out scheme/match))

139
collects/macro-debugger/model/deriv-c.ss
View File

@ -1,10 +1,10 @@
(module deriv-c mzscheme
(provide (all-defined))
#lang scheme/base
(provide (all-defined-out))
;; A Node(a) is:
;; (make-node a ?a)
(define-struct node (z1 z2) #f)
(define-struct node (z1 z2) #:transparent)
;; A TopDeriv is one of
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
@ -13,18 +13,18 @@
;; A Deriv is one of
;; (make-mrule <Node(Stx)> Transformation Deriv)
;; PrimDeriv
(define-struct (deriv node) () #f)
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
(define-struct (mrule deriv) (transformation next) #f)
(define-struct (deriv node) () #:transparent)
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
(define-struct (mrule deriv) (transformation next) #:transparent)
;; A DerivLL is one of
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
;; Deriv
(define-struct (lift/let-deriv deriv) (first lift-stx second) #f)
(define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent)
;; A Transformation is
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #f)
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent)
;; A LocalAction is one of
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
@ -32,57 +32,57 @@
;; (make-local-lift Stx Identifier)
;; (make-local-lift-end Stx)
;; (make-local-bind BindSyntaxes)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #f)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f)
(define-struct local-lift (expr id) #f)
(define-struct local-lift-end (decl) #f)
(define-struct local-bind (bindrhs) #f)
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent)
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent)
(define-struct local-lift (expr id) #:transparent)
(define-struct local-lift-end (decl) #:transparent)
(define-struct local-bind (bindrhs) #:transparent)
;; Base = << Node(Stx) Rs ?exn >>
(define-struct (base deriv) (resolves ?1) #f)
(define-struct (base deriv) (resolves ?1) #:transparent)
;; A PrimDeriv is one of
(define-struct (prule base) () #f)
(define-struct (p:variable prule) () #f)
(define-struct (prule base) () #:transparent)
(define-struct (p:variable prule) () #:transparent)
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #f)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f)
(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent)
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent)
;; (make-p:define-syntaxes <Base> DerivLL)
;; (make-p:define-values <Base> Deriv)
(define-struct (p:define-syntaxes prule) (rhs ?2) #f)
(define-struct (p:define-values prule) (rhs) #f)
(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
(define-struct (p:define-values prule) (rhs) #:transparent)
;; (make-p:#%expression <Base> Deriv)
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
;; (make-p:wcm <Base> Deriv Deriv Deriv)
;; (make-p:set! <Base> Rs Deriv)
;; (make-p:set!-macro <Base> Rs Deriv)
(define-struct (p:#%expression prule) (inner) #f)
(define-struct (p:if prule) (full? test then else) #f)
(define-struct (p:wcm prule) (key mark body) #f)
(define-struct (p:set! prule) (id-resolves rhs) #f)
(define-struct (p:set!-macro prule) (deriv) #f)
(define-struct (p:#%expression prule) (inner) #:transparent)
(define-struct (p:if prule) (full? test then else) #:transparent)
(define-struct (p:wcm prule) (key mark body) #:transparent)
(define-struct (p:set! prule) (id-resolves rhs) #:transparent)
(define-struct (p:set!-macro prule) (deriv) #:transparent)
;; (make-p:#%app <Base> Stx LDeriv)
;; (make-p:begin <Base> LDeriv)
;; (make-p:begin0 <Base> Deriv LDeriv)
(define-struct (p:#%app prule) (tagged-stx lderiv) #f)
(define-struct (p:begin prule) (lderiv) #f)
(define-struct (p:begin0 prule) (first lderiv) #f)
(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent)
(define-struct (p:begin prule) (lderiv) #:transparent)
(define-struct (p:begin0 prule) (first lderiv) #:transparent)
;; (make-p:lambda <Base> LambdaRenames BDeriv)
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
(define-struct (p:lambda prule) (renames body) #f)
(define-struct (p:case-lambda prule) (renames+bodies) #f)
(define-struct (p:let-values prule) (renames rhss body) #f)
(define-struct (p:letrec-values prule) (renames rhss body) #f)
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f)
(define-struct (p:lambda prule) (renames body) #:transparent)
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
(define-struct (p:let-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent)
;; (make-p:stop <Base>)
;; (make-p:unknown <Base>)
@ -94,32 +94,32 @@
;; (make-p:require-for-syntax <Base>)
;; (make-p:require-for-template <Base>)
;; (make-p:provide <Base>)
(define-struct (p::STOP prule) () #f)
(define-struct (p:stop p::STOP) () #f)
(define-struct (p:unknown p::STOP) () #f)
(define-struct (p:#%top p::STOP) (tagged-stx) #f)
(define-struct (p:#%datum p::STOP) (tagged-stx) #f)
(define-struct (p:quote p::STOP) () #f)
(define-struct (p:quote-syntax p::STOP) () #f)
(define-struct (p:require p::STOP) () #f)
(define-struct (p:require-for-syntax p::STOP) () #f)
(define-struct (p:require-for-template p::STOP) () #f)
(define-struct (p:provide p::STOP) () #f)
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
(define-struct (p:unknown p::STOP) () #:transparent)
(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent)
(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent)
(define-struct (p:quote p::STOP) () #:transparent)
(define-struct (p:quote-syntax p::STOP) () #:transparent)
(define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #:transparent)
(define-struct (p:provide p::STOP) () #:transparent)
;;+ (make-p:rename <Base> Renames Deriv)
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
(define-struct (p:rename prule) (renames inner) #f)
(define-struct (p:synth prule) (subterms ?2) #f)
(define-struct (p:rename prule) (renames inner) #:transparent)
(define-struct (p:synth prule) (subterms ?2) #:transparent)
;; A LDeriv is
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
(define-struct (lderiv node) (?1 derivs) #f)
(define-struct (lderiv node) (?1 derivs) #:transparent)
;; A BDeriv is
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
(define-struct (bderiv node) (pass1 trans pass2) #f)
(define-struct (bderiv node) (pass1 trans pass2) #:transparent)
;; A BRule is one of
;; (make-b:error exn)
@ -128,22 +128,22 @@
;; (make-b:defvals BlockRenames Deriv ?exn)
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
(define-struct b:error (?1) #f)
(define-struct brule (renames) #f)
(define-struct (b:expr brule) (head) #f)
(define-struct (b:splice brule) (head ?1 tail ?2) #f)
(define-struct (b:defvals brule) (head ?1) #f)
(define-struct (b:defstx brule) (head ?1 bindrhs) #f)
;;(define-struct (b:begin brule) (head inner) #f)
(define-struct b:error (?1) #:transparent)
(define-struct brule (renames) #:transparent)
(define-struct (b:expr brule) (head) #:transparent)
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
(define-struct (b:defvals brule) (head ?1) #:transparent)
(define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent)
;;(define-struct (b:begin brule) (head inner) #:transparent)
;; A BindSyntaxes is
;; (make-bind-syntaxes DerivLL ?exn)
(define-struct bind-syntaxes (rhs ?1) #f)
(define-struct bind-syntaxes (rhs ?1) #:transparent)
;; A CaseLambdaClause is
;; (make-clc ?exn CaseLambdaRename BDeriv)
(define-struct clc (?1 renames body) #f)
(define-struct clc (?1 renames body) #:transparent)
;; A BlockRename is (cons Stx Stx)
@ -159,16 +159,16 @@
;; (make-mod:skip)
;; (make-mod:cons Deriv)
;; (make-mod:lift Deriv Stxs)
(define-struct modrule () #f)
(define-struct (mod:cons modrule) (head) #f)
(define-struct (mod:prim modrule) (head prim) #f)
(define-struct (mod:skip modrule) () #f)
(define-struct (mod:splice modrule) (head ?1 tail) #f)
(define-struct (mod:lift modrule) (head tail) #f)
(define-struct (mod:lift-end modrule) (tail) #f)
(define-struct modrule () #:transparent)
(define-struct (mod:cons modrule) (head) #:transparent)
(define-struct (mod:prim modrule) (head prim) #:transparent)
(define-struct (mod:skip modrule) () #:transparent)
(define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
(define-struct (mod:lift modrule) (head tail) #:transparent)
(define-struct (mod:lift-end modrule) (tail) #:transparent)
;; A ModPrim is a PRule in:
;; (make-p:define-values <Base> #f)
;; (make-p:define-values <Base> #:transparent)
;; (make-p:define-syntaxes <Base> Deriv)
;; (make-p:require <Base>)
;; (make-p:require-for-syntax <Base>)
@ -179,9 +179,6 @@
;; A SynthItem is one of
;; - (make-s:subterm Path Deriv)
;; - (make-s:rename Path Stx Stx)
(define-struct subitem () #f)
(define-struct (s:subterm subitem) (path deriv) #f)
(define-struct (s:rename subitem) (path before after) #f)
)
(define-struct subitem () #:transparent)
(define-struct (s:subterm subitem) (path deriv) #:transparent)
(define-struct (s:rename subitem) (path before after) #:transparent)

7
collects/macro-debugger/model/deriv-parser.ss
View File

@ -1,6 +1,7 @@
(module deriv-parser mzscheme
(require "yacc-ext.ss"
#lang scheme/base
(require (for-syntax scheme/base)
"yacc-ext.ss"
"yacc-interrupted.ss"
"deriv.ss"
"deriv-util.ss"
@ -576,5 +577,3 @@
[(next (? EE) (? EL*)) (cons $2 $3)])
)))
)

8
collects/macro-debugger/model/deriv-tokens.ss
View File

@ -1,8 +1,8 @@
(module deriv-tokens mzscheme
(require (lib "lex.ss" "parser-tools")
#lang scheme/base
(require parser-tools/lex
"deriv.ss")
(provide (all-defined))
(provide (all-defined-out))
(define-tokens basic-tokens
(start ; .
@ -156,5 +156,3 @@
(define (signal->symbol sig-n)
(cdr (assv sig-n signal-mapping)))
)

12
collects/macro-debugger/model/deriv-util.ss
View File

@ -1,9 +1,10 @@
(module deriv-util mzscheme
(require "deriv.ss"
(lib "list.ss")
(lib "plt-match.ss"))
(require-for-syntax (lib "scheme/private/struct-info.ss"))
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax scheme/private/struct-info)
scheme/list
scheme/match
"deriv.ss")
(provide make
@ -97,4 +98,3 @@
stx)))
(with-syntax ([constructor constructor])
#'(constructor expr ...)))]))
)

16
collects/macro-debugger/model/deriv.ss
View File

@ -1,14 +1,12 @@
(module deriv mzscheme
(require (lib "contract.ss")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/contract
syntax/stx
"deriv-c.ss")
;; NO CONTRACTS
(provide (all-from-out "deriv-c.ss"))
#;(provide (all-from "deriv-c.ss"))
;; CONTRACTS
#|
(define (?? c) (or/c c false/c))
@ -366,5 +364,5 @@
(struct (s:rename subitem)
([path any/c]
[before syntax?]
[after syntax?]))
))
[after syntax?])))
|#

13
collects/macro-debugger/model/hiding-policies.ss
View File

@ -1,11 +1,13 @@
(module hiding-policies mzscheme
(require (lib "plt-match.ss")
(lib "boundmap.ss" "syntax"))
(provide (all-defined))
#lang scheme/base
(require (for-syntax scheme/base)
scheme/match
syntax/boundmap)
(provide (all-defined-out))
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)
#:mutable)
(define (policy-hide-module p m)
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
@ -97,4 +99,3 @@
(cond [(pair? path) (memq (car path) '(lib planet))]
[(string? path) (lib-module? rel)]
[else #f]))))
)

29
collects/macro-debugger/model/reductions-engine.ss
View File

@ -1,16 +1,14 @@
;; FIXME: Steps are pairs of Configurations
;; Configurations contain contexts, definites, etc.
#lang scheme/base
(module reductions-engine mzscheme
(require (lib "list.ss")
(require (for-syntax scheme/base)
scheme/list
scheme/contract
"deriv.ss"
"stx-util.ss"
"steps.ss")
(require (lib "contract.ss"))
(provide (all-from "steps.ss"))
(provide context
(provide (all-from-out "steps.ss")
context
big-context
current-derivation
current-definites
@ -33,13 +31,17 @@
CC
R
revappend)
(provide walk
revappend
walk
walk/foci
walk/mono
stumble
stumble/E)
;; FIXME: Steps are pairs of Configurations
;; Configurations contain contexts, definites, etc.
;; context: parameter of Context
(define context (make-parameter null))
@ -313,7 +315,7 @@
;; Implementation of subterm handling for (hole ...) sequences
[(Run* f form-var pattern (hole :::) fills k)
(and (identifier? #':::)
(module-identifier=? #'::: (quote-syntax ...)))
(free-identifier=? #'::: (quote-syntax ...)))
#'(let ([ctx (CC (hole :::) form-var pattern)])
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
(run-multiple f ctx fills e1s k)))]
@ -367,9 +369,9 @@
[(pair? from)
#;(unless (pair? to)
(fprintf (current-error-port)
"from:\n~s\n\n" (syntax-object->datum from0))
"from:\n~s\n\n" (syntax->datum from0))
(fprintf (current-error-port)
"to:\n~s\n\n" (syntax-object->datum to0))
"to:\n~s\n\n" (syntax->datum to0))
(error 'frontier-renaming))
(loop (car from) (car to))
(loop (cdr from) (cdr to))]
@ -441,4 +443,3 @@
(if (list? x)
x
(list x)))
)

6
collects/macro-debugger/model/reductions.ss
View File

@ -1,6 +1,6 @@
(module reductions mzscheme
(require (lib "plt-match.ss")
#lang scheme/base
(require scheme/match
"stx-util.ss"
"deriv-util.ss"
"context.ss"
@ -560,5 +560,3 @@
stxs
'splice-module-lifts]]
[(ModulePass #'?forms) ?forms rest])]))
)

13
collects/macro-debugger/model/steps.ss
View File

@ -1,9 +1,9 @@
(module steps mzscheme
#lang scheme/base
(require "deriv.ss"
"deriv-util.ss"
"deriv-find.ss")
(provide (all-defined))
(provide (all-defined-out))
;; A ReductionSequence is a (list-of Reduction)
@ -27,11 +27,11 @@
;; - (make-mono ... Syntaxes Syntax)
;; - (make-misstep ... Syntax Syntax Exception)
(define-struct protostep (deriv lctx type ctx definites frontier) #f)
(define-struct protostep (deriv lctx type ctx definites frontier) #:transparent)
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
(define-struct (mono protostep) (foci1 e1) #f)
(define-struct (misstep protostep) (foci1 e1 exn) #f)
(define-struct (step protostep) (foci1 foci2 e1 e2) #:transparent)
(define-struct (mono protostep) (foci1 e1) #:transparent)
(define-struct (misstep protostep) (foci1 e1 exn) #:transparent)
;; context-fill : Context Syntax -> Syntax
(define (context-fill ctx stx)
@ -113,4 +113,3 @@
(define (rewrite-step? x)
(and (step? x) (not (rename-step? x))))
)

21
collects/macro-debugger/model/stx-util.ss
View File

@ -1,13 +1,14 @@
(module stx-util mzscheme
(require (lib "stx.ss" "syntax"))
#lang scheme/base
(require (for-syntax scheme/base)
syntax/stx)
(provide (all-defined)
(all-from (lib "stx.ss" "syntax")))
(provide (all-defined-out)
(all-from-out syntax/stx))
(define (d->so template datum)
(if (syntax? template)
(datum->syntax-object template datum template template)
(datum->syntax template datum template template)
datum))
(define-syntax (syntax-copier stx)
@ -34,9 +35,9 @@
;; FIXME
(unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax-object->datum old-parts))
(printf "new parts: ~s~n" (map syntax-object->datum new-parts)))
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
(printf "old parts: ~s~n" (map syntax->datum old-parts))
(printf "new parts: ~s~n" (map syntax->datum new-parts)))
(d->so
old-expr
(map (lambda (new old) (syntax/restamp pa new old))
@ -47,7 +48,7 @@
#'(begin
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb))))
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb))))
(printf "old parts: ~s~n" old-expr)
(printf "new parts: ~s~n" new-expr))
(let ([na (stx-car new-expr)]
@ -96,5 +97,3 @@
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))
)

15
collects/macro-debugger/model/trace-raw.ss
View File

@ -1,11 +1,11 @@
(module trace-raw mzscheme
(require "../syntax-browser.ss"
(lib "class.ss")
(lib "lex.ss" "parser-tools")
#lang scheme/base
(require scheme/class
parser-tools/lex
"deriv-tokens.ss"
"deriv-parser.ss")
(provide (all-defined))
"deriv-parser.ss"
"../syntax-browser.ss")
(provide (all-defined-out))
(define current-expand-observe
(dynamic-require ''#%expobs 'current-expand-observe))
@ -24,7 +24,7 @@
(token-name (position-token-token t))))
(when val
(send browser add-syntax
(datum->syntax-object #f val)))
(datum->syntax #f val)))
(set! pos (add1 pos)))
(parameterize ((current-expand-observe
(lambda (sig val)
@ -34,4 +34,3 @@
(expand sexpr)
(for-each show (reverse events))))
)

8
collects/macro-debugger/model/trace.ss
View File

@ -1,7 +1,8 @@
(module trace mzscheme
(require (lib "lex.ss" "parser-tools"))
(require "deriv.ss"
#lang scheme/base
(require scheme/promise
parser-tools/lex
"deriv.ss"
"deriv-parser.ss"
"deriv-tokens.ss")
@ -70,4 +71,3 @@
(add! (cons 'EOF #f))
(values result
(reverse events))))))
)

7
collects/macro-debugger/model/yacc-ext.ss
View File

@ -1,7 +1,7 @@
(module yacc-ext mzscheme
(require (prefix yacc: (lib "yacc.ss" "parser-tools")))
#lang scheme/base
(require (prefix-in yacc: parser-tools/yacc)
(for-syntax scheme/base))
(provide parser
options
productions
@ -47,4 +47,3 @@
#'(let ()
def ...
(#%expression (yacc:parser opt ... (grammar prod ...))))))]))
)

32
collects/macro-debugger/model/yacc-interrupted.ss
View File

@ -1,7 +1,8 @@
(module yacc-interrupted mzscheme
(require-for-syntax (lib "etc.ss"))
(require "yacc-ext.ss")
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax mzlib/etc)
"yacc-ext.ss")
(provide ! ? !!
define-production-splitter
skipped-token-values
@ -33,13 +34,13 @@
(if (pair? forms)
(syntax-case (car forms) ()
[(#:args . args)
(loop (cdr forms) (cons (cons #:args #'args) options) alts)]
(loop (cdr forms) (cons (cons '#:args #'args) options) alts)]
[(#:skipped expr)
(loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)]
(loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)]
[(#:wrap)
(loop (cdr forms) (cons (cons #:wrap #t) options) alts)]
(loop (cdr forms) (cons (cons '#:wrap #t) options) alts)]
[(#:no-wrap)
(loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)]
(loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)]
[(kw . args)
(keyword? (syntax-e #'kw))
(raise-syntax-error 'split "bad keyword" (car forms))]
@ -59,7 +60,7 @@
(define-for-syntax (I symbol)
(syntax-local-introduce
(syntax-local-get-shadower (datum->syntax-object #f symbol))))
(syntax-local-get-shadower (datum->syntax #f symbol))))
(define-for-syntax ($name n)
(I (symbol+ '$ n)))
@ -112,7 +113,7 @@
(loop #'parts-rest (cons #'NT rpattern)
(add1 position) (cons ($name position) args))])))
(map (lambda (new-pattern)
(cons (datum->syntax-object #f new-pattern pattern)
(cons (datum->syntax #f new-pattern pattern)
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
new-patterns))
@ -162,7 +163,7 @@
(define-for-syntax (generate-action-name nt pos)
(syntax-local-get-shadower
(datum->syntax-object #f (symbol+ 'action-for- nt '/ pos))))
(datum->syntax #f (symbol+ 'action-for- nt '/ pos))))
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
(define pattern (car alt))
@ -231,15 +232,15 @@
(define-values (options alternates0)
(partition-options/alternates (syntax->list #'(form ...))))
(define wrap?
(let ([wrap? (assq #:wrap options)]
[no-wrap? (assq #:no-wrap options)])
(let ([wrap? (assq '#:wrap options)]
[no-wrap? (assq '#:no-wrap options)])
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
(raise-syntax-error 'split
"must specify exactly one of #:wrap, #:no-wrap"
stx))
(and wrap? #t)))
(define args-spec
(let ([p (assq #:args options)]) (and p (cdr p))))
(let ([p (assq '#:args options)]) (and p (cdr p))))
(define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
(define alternates+definitions
(map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
@ -257,8 +258,8 @@
successful-alternates]
[((interrupted-pattern . interrupted-action) ...)
interrupted-alternates]
[skip-spec (assq #:skipped options)]
[args-spec (assq #:args options)]
[skip-spec (assq '#:skipped options)]
[args-spec (assq '#:args options)]
[name/Skipped (I (symbol+ #'name '/Skipped))]
[name/Interrupted (I (symbol+ #'name '/Interrupted))]
[%action ((syntax-local-certifier) #'%action)])
@ -299,4 +300,3 @@
#'(lambda args action)]
[(%action #f action)
#'action]))
)

9
collects/macro-debugger/stepper-text.ss
View File

@ -1,7 +1,7 @@
(module stepper-text mzscheme
(require (lib "list.ss")
(lib "pretty.ss")
#lang scheme/base
(require scheme/list
scheme/pretty
"model/trace.ss"
"model/reductions.ss"
"model/steps.ss"
@ -123,7 +123,7 @@
show]
[(list? show)
(lambda (id)
(ormap (lambda (x) (module-identifier=? x id))
(ormap (lambda (x) (free-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
@ -137,4 +137,3 @@
(define extended-style-list
'((define-values . define)
(define-syntaxes . define-syntax)))
)

3
collects/macro-debugger/stepper.ss
View File

@ -1,8 +1,7 @@
(module stepper mzscheme
#lang scheme/base
(require "view/view.ss")
(provide expand/step)
(define (expand/step stx)
(go stx))
)

3
collects/macro-debugger/syntax-browser.ss
View File

@ -1,7 +1,6 @@
(module syntax-browser mzscheme
#lang scheme/base
(require "syntax-browser/frame.ss")
(provide browse-syntax
browse-syntaxes
make-syntax-browser)
)

5
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -1,6 +1,6 @@
(module controller mzscheme
(require (lib "class.ss")
#lang scheme/base
(require scheme/class
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
@ -73,4 +73,3 @@
(displays-manager-mixin
object%))))
(super-new)))
)

9
collects/macro-debugger/syntax-browser/display.ss
View File

@ -1,8 +1,8 @@
(module display mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "plt-match.ss")
#lang scheme/base
(require scheme/class
scheme/gui
scheme/match
"params.ss"
"pretty-printer.ss"
"interfaces.ss"
@ -248,4 +248,3 @@
(define unhighlight-d (highlight-style-delta "white" #f))
)

12
collects/macro-debugger/syntax-browser/embed.ss
View File

@ -1,13 +1,13 @@
(module embed mzscheme
#lang scheme/base
(require "interfaces.ss"
"widget.ss"
"keymap.ss"
"params.ss"
"partition.ss")
(provide (all-from "interfaces.ss")
(all-from "widget.ss")
(all-from "keymap.ss")
(all-from "params.ss")
identifier=-choices))
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
(all-from-out "params.ss")
identifier=-choices)

12
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,9 +1,9 @@
(module frame mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
#lang scheme/base
(require scheme/class
scheme/gui
framework/framework
scheme/list
"partition.ss"
"prefs.ss"
"widget.ss")
@ -92,5 +92,3 @@
(send -choice set-selection
(or (send -choice find-string (car name+func)) 0))))
))
)

8
collects/macro-debugger/syntax-browser/hrule-snip.ss
View File

@ -1,7 +1,8 @@
(module hrule-snip mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
#lang scheme/base
(require scheme/class
scheme/gui)
(provide hrule-snip%)
;; hrule-snip%
@ -54,4 +55,3 @@
(send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class)
)

8
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,7 +1,7 @@
(module interfaces mzscheme
(require (lib "class.ss"))
(provide (all-defined))
#lang scheme/base
(require scheme/class)
(provide (all-defined-out))
;; displays-manager<%>
(define displays-manager<%>
@ -163,5 +163,3 @@
;; count : -> number
count))
)

10
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -1,7 +1,7 @@
(module keymap mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
#lang scheme/base
(require scheme/class
scheme/gui
"interfaces.ss"
"partition.ss")
(provide syntax-keymap%
@ -38,7 +38,7 @@
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
(format "~s" (syntax->datum stx))
"")
(send event get-time-stamp))))
@ -148,5 +148,3 @@
(add-partition-items)
(after-partition-items)
))
)

26
collects/macro-debugger/syntax-browser/partition.ss
View File

@ -1,8 +1,8 @@
(module partition mzscheme
(require (lib "class.ss")
(lib "boundmap.ss" "syntax")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/class
syntax/boundmap
syntax/stx
"interfaces.ss")
(provide new-bound-partition
partition%
@ -22,7 +22,7 @@
;; Has no marks---used to initialize bound partition so that
;; unmarked syntax always gets colored "black"
(define unmarked-syntax
(datum->syntax-object #f representative-symbol))
(datum->syntax #f representative-symbol))
(define partition%
(class* object% (partition<%>)
@ -89,7 +89,7 @@
(or n
(begin0 next-number
(bound-identifier-mapping-put! numbers r next-number)
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax-object->datum stx))
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx))
(set! next-number (add1 next-number))))))
(define/public (same-partition? a b)
@ -99,7 +99,7 @@
next-number)
(define/private (representative stx)
(datum->syntax-object stx representative-symbol))
(datum->syntax stx representative-symbol))
(get-partition unmarked-syntax)
(super-new)))
@ -108,8 +108,8 @@
(define (lift/rep id=?)
(lambda (A B)
(let ([ra (datum->syntax-object A representative-symbol)]
[rb (datum->syntax-object B representative-symbol)])
(let ([ra (datum->syntax A representative-symbol)]
[rb (datum->syntax B representative-symbol)])
(id=? ra rb))))
(define (lift id=?)
@ -127,7 +127,7 @@
(let ([ba (identifier-binding a)]
[bb (identifier-binding b)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? a b)]
(free-identifier=? a b)]
[(and (not ba) (not bb))
#t]
[(or (not ba) (not bb))
@ -138,7 +138,7 @@
(let ([ba (identifier-binding A)]
[bb (identifier-binding B)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(module-identifier=? A B)]
(free-identifier=? A B)]
[(or (not ba) (not bb))
(and (not ba) (not bb))]
[else (eq? (caddr ba) (caddr bb))])))
@ -150,10 +150,8 @@
(make-parameter
`(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?)
("module-identifier=?" . ,module-identifier=?)
("free-identifier=?" . ,free-identifier=?)
("module-or-top-identifier=?" . ,module-or-top-identifier=?)
("symbolic-identifier=?" . ,symbolic-identifier=?)
("same source module" . ,id:source-module=?)
("same nominal module" . ,id:nominal-module=?))))
)

7
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -1,7 +1,7 @@
(module prefs mzscheme
(require (lib "class.ss")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
framework/framework
"interfaces.ss"
"../util/misc.ss")
(provide syntax-prefs%
@ -29,4 +29,3 @@
(pref:props-shown? pref:props-shown?)))
(define syntax-prefs% (syntax-prefs-mixin object%))
)

12
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,9 +1,9 @@
(module pretty-helper mzscheme
(require (lib "class.ss")
(lib "stx.ss" "syntax")
#lang scheme/base
(require scheme/class
syntax/stx
"partition.ss")
(provide (all-defined))
(provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
@ -126,7 +126,7 @@
[expr (cadr stx-list)])
(and (identifier? kw)
(memq (syntax-e kw) special-expression-keywords)
(bound-identifier=? kw (datum->syntax-object stx (syntax-e kw)))
(bound-identifier=? kw (datum->syntax stx (syntax-e kw)))
(andmap (lambda (f) (equal? (f stx) (f kw)))
(list syntax-source
syntax-line
@ -146,5 +146,3 @@
(define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" sym n)))
)

11
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -1,11 +1,11 @@
;; FIXME: Need to disable printing of structs with custom-write property
(module pretty-printer mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "pretty.ss")
(lib "mred.ss" "mred")
#lang scheme/base
(require scheme/list
scheme/class
scheme/pretty
scheme/gui
"pretty-helper.ss"
"interfaces.ss"
"params.ss"
@ -158,4 +158,3 @@
(>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y))))))))
)

21
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -1,11 +1,9 @@
(module properties mzscheme
(require "interfaces.ss"
"util.ss"
(lib "class.ss")
(lib "mred.ss" "mred")
#;(lib "framework.ss" "framework")
#;(lib "interactive-value-port.ss" "mrlib"))
#lang scheme/base
(require scheme/class
scheme/gui
"interfaces.ss"
"util.ss")
(provide properties-view%
properties-snip%)
@ -151,13 +149,13 @@
(cond
[(identifier? stx)
(display "Binding if used for #%top\n" key-sd)
(display-bindings (datum->syntax-object stx '#%top))]
(display-bindings (datum->syntax stx '#%top))]
[(and (syntax? stx) (pair? (syntax-e stx)))
(display "Binding if used for #%app\n" key-sd)
(display-bindings (datum->syntax-object stx '#%app))]
(display-bindings (datum->syntax stx '#%app))]
[else
(display "Binding if used for #%datum\n" key-sd)
(display-bindings (datum->syntax-object stx '#%datum))]))
(display-bindings (datum->syntax stx '#%datum))]))
;; display-bindings : syntax -> void
(define/private (display-bindings stx)
@ -181,7 +179,7 @@
(display-subkv " as" (list-ref v 1))
(display-subkv " imported from" (mpi->string (list-ref v 2)))
(display-subkv " as" (list-ref v 3))
(if (list-ref v 4)
(when (list-ref v 4)
(display " via define-for-syntax" sub-key-sd))]))
;; display-stxobj-info : syntax -> void
@ -311,4 +309,3 @@
(send s set-delta 'change-toggle-underline)
(send s set-delta-foreground "blue")
s))
)

17
collects/macro-debugger/syntax-browser/text.ss
View File

@ -1,10 +1,10 @@
(module text mzscheme
(require (lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "arrow.ss" "drscheme")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/list
scheme/class
scheme/gui
drscheme/arrow
framework/framework
"../util/notify.ss")
(provide text:hover<%>
@ -29,9 +29,9 @@
(define white (send the-color-database find-color "white"))
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
(define-struct drawing (start end draw visible? tacked?) #f)
(define-struct drawing (start end draw visible? tacked?) #:mutable)
(define-struct idloc (start end id) #f)
(define-struct idloc (start end id))
(define (mean x y)
(/ (+ x y) 2))
@ -321,4 +321,3 @@
(text:arrows-mixin
(text:tacking-mixin
text:mouse-drawings%)))
)

5
collects/macro-debugger/syntax-browser/util.ss
View File

@ -1,6 +1,6 @@
(module util mzscheme
(require (lib "class.ss"))
#lang scheme/base
(require scheme/class)
(provide with-unlock
make-text-port
mpi->string
@ -57,4 +57,3 @@
[(not mpi)
'()]
[else (list mpi)]))
)

17
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -1,12 +1,12 @@
(module widget mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
(lib "plt-match.ss")
(lib "kw.ss")
(lib "boundmap.ss" "syntax")
#lang mzscheme
(require scheme/class
mred/mred
framework/framework
scheme/list
scheme/match
mzlib/kw
syntax/boundmap
"interfaces.ss"
"params.ss"
"controller.ss"
@ -255,4 +255,3 @@
(define/override (default-style-name) "Basic")
(super-new (auto-wrap #t))
(set-autowrap-bitmap #f)))
)

7
collects/macro-debugger/view/cursor.ss
View File

@ -1,5 +1,6 @@
(module cursor mzscheme
#lang scheme/base
(require scheme/promise)
(provide cursor?
cursor:new
cursor:add-to-end!
@ -57,7 +58,7 @@
;; Cursors
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
(define-struct cursor (prefix suffixp))
(define-struct cursor (prefix suffixp) #:mutable)
(define (cursor:new items)
(make-cursor null items))
@ -128,5 +129,3 @@
(define (cursor:suffix->list c)
(stream->list (cursor-suffixp c)))
)

8
collects/macro-debugger/view/debug-format.ss
View File

@ -1,10 +1,9 @@
(module debug-format mzscheme
(require (lib "pretty.ss"))
#lang scheme/base
(require scheme/pretty)
(provide write-debug-file
load-debug-file)
(define (write-debug-file file exn events)
(with-output-to-file file
(lambda ()
@ -25,7 +24,7 @@
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
[(null? d) '()]
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
[(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))]
[(syntax? d) `(datum->syntax #f ',(syntax->datum d))]
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
[else (error 'serialize-datum "got ~s" d)]))
@ -52,4 +51,3 @@
[ctx (read)])
(let ([events (eval events-expr)])
(values events exnmsg ctx)))))))
)

7
collects/macro-debugger/view/debug.ss
View File

@ -1,7 +1,7 @@
(module debug mzscheme
(require (lib "pretty.ss")
(lib "class.ss")
#lang scheme/base
(require scheme/pretty
scheme/class
"debug-format.ss"
"prefs.ss"
"view.ss")
@ -32,4 +32,3 @@
(let* ([w (make-stepper)])
(send w add-trace events)
w)))
)

21
collects/macro-debugger/view/extensions.ss
View File

@ -1,24 +1,24 @@
(module extensions mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/widget.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
"../util/notify.ss")
(provide stepper-keymap%
stepper-context-menu%
stepper-syntax-widget%)
@ -109,4 +109,3 @@
(case-lambda [() (send config get-props-percentage)]
[(v) (send config set-props-percentage v)]))
(super-new)))
)

26
collects/macro-debugger/view/frame.ss
View File

@ -1,27 +1,27 @@
(module frame mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/file
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"stepper.ss"
"prefs.ss"
"warning.ss"
"hiding-panel.ss"
(prefix sb: "../syntax-browser/embed.ss")
(prefix sb: "../syntax-browser/params.ss")
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
"../util/notify.ss")
(provide macro-stepper-frame-mixin)
(define (macro-stepper-frame-mixin base-frame%)
@ -232,5 +232,3 @@
(min-width (+ 2 (inexact->exact (ceiling tw))))
(min-height (+ 2 (inexact->exact (ceiling th)))))
(stretchable-height #f)))
)

17
collects/macro-debugger/view/hiding-panel.ss
View File

@ -1,12 +1,12 @@
(module hiding-panel mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "boundmap.ss" "syntax")
"util.ss"
#lang scheme/base
(require scheme/class
scheme/gui
scheme/list
syntax/boundmap
"../model/synth-engine.ss"
"../syntax-browser/util.ss"
"../util/notify.ss"
"../util/hiding.ss")
(provide macro-hiding-prefs-widget%)
@ -241,7 +241,7 @@
(return show?)))]
[else
(lambda (id binding return)
(when (module-identifier=? id key)
(when (free-identifier=? id key)
(return show?)))]))
identifier-policies))
@ -302,7 +302,7 @@
(define (key=? key1 key2)
(cond [(and (identifier? key1) (identifier? key2))
(module-identifier=? key1 key2)]
(free-identifier=? key1 key2)]
[(and (pair? key1) (pair? key2))
(and (equal? (car key1) (car key2))
(equal? (cadr key1) (cadr key2)))]
@ -317,4 +317,3 @@
(mpi->string mod)))]
[else (symbol->string (syntax-e key))]))
)

8
collects/macro-debugger/view/interfaces.ss
View File

@ -1,7 +1,7 @@
(module interfaces mzscheme
(require (lib "unit.ss"))
(provide (all-defined))
#lang scheme/base
(require scheme/unit)
(provide (all-defined-out))
;; Signatures
@ -44,5 +44,3 @@
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?
)

8
collects/macro-debugger/view/prefs.ss
View File

@ -1,7 +1,7 @@
(module prefs mzscheme
(require (lib "class.ss")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
framework/framework
"../util/notify.ss"
"../util/misc.ss")
(provide macro-stepper-config-base%
@ -96,5 +96,3 @@
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
(super-new)))
)

25
collects/macro-debugger/view/stepper.ss
View File

@ -1,20 +1,20 @@
(module stepper mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss")
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -23,7 +23,7 @@
"../model/hide.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
"../util/notify.ss")
(provide macro-stepper-widget%
macro-stepper-widget/process-mixin)
@ -427,7 +427,6 @@
[else #f])))
(define/public (top-interaction-kw? x)
(module-identifier=? x #'#%top-interaction))
(free-identifier=? x #'#%top-interaction))
))
)

48
collects/macro-debugger/view/term-record.ss
View File

@ -1,19 +1,19 @@
(module term-record mzscheme
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
#lang scheme/base
(require scheme/class
scheme/unit
scheme/list
scheme/match
scheme/gui
framework/framework
syntax/boundmap
"interfaces.ss"
"prefs.ss"
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
(prefix s: "../syntax-browser/widget.ss")
(prefix s: "../syntax-browser/params.ss")
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -24,7 +24,7 @@
"../model/steps.ss"
"debug-format.ss"
"cursor.ss"
"util.ss")
"../util/notify.ss")
(provide term-record%)
@ -389,15 +389,15 @@
(define/public (add-syntax stx binders definites)
(send sbview add-syntax stx
#:alpha-table binders
#:definites definites))
'#:alpha-table binders
'#:definites definites))
(define/private (add-final stx error binders definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
#:alpha-table binders
#:definites (or definites null)))
'#:alpha-table binders
'#:definites (or definites null)))
(when error
(add-error error)))
@ -484,8 +484,8 @@
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e
#:alpha-table binders
#:definites (protostep-definites step)))
'#:alpha-table binders
'#:definites (protostep-definites step)))
(exn:fail:syntax-exprs (misstep-exn step))))
(show-lctx step binders))
@ -493,12 +493,12 @@
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
(define/private (insert-syntax/color stx foci binders definites frontier hi-color)
(send sbview add-syntax stx
#:definites definites
#:alpha-table binders
#:hi-color hi-color
#:hi-stxs (if (send config get-highlight-foci?) foci null)
#:hi2-color "WhiteSmoke"
#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
'#:definites definites
'#:alpha-table binders
'#:hi-color hi-color
'#:hi-stxs (if (send config get-highlight-foci?) foci null)
'#:hi2-color "WhiteSmoke"
'#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
(define/private (insert-syntax/redex stx foci binders definites frontier)
@ -538,5 +538,3 @@
))
)

14
collects/macro-debugger/view/view.ss
View File

@ -1,14 +1,14 @@
(module view mzscheme
(require (lib "class.ss")
(lib "pretty.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/class
scheme/pretty
scheme/gui
framework/framework
"interfaces.ss"
"frame.ss"
"prefs.ss"
"../model/trace.ss")
(provide (all-defined))
(provide (all-defined-out))
(define macro-stepper-frame%
(macro-stepper-frame-mixin
@ -39,5 +39,3 @@
(let* ([w (make-macro-stepper)])
(send w add-trace events)
w))
)