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

finish decompiler on syntax objects

Browse Source 
svn: r12077

original commit: e2d4bc0d2bd46db59dbb5cbf0eda94f47c491719
This commit is contained in:
Matthew Flatt 2008-10-21 00:10:47 +00:00
parent 52dd376826
commit 3f4a4b08a9
1 changed files with 15 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/mzlib/pretty.ss
View File

@ -1088,11 +1088,13 @@
(define max-call-head-width 5) (define max-call-head-width 5)
(define (no-sharing? expr count acdr) (define (no-sharing? expr count apair? acdr)
(if (and found (hash-table-get found (acdr expr) #f)) (if (and found
(apair? expr)
(hash-table-get found (acdr expr) #f))
#f #f
(or (zero? count) (or (zero? count)
(no-sharing? (acdr expr) (sub1 count) acdr)))) (no-sharing? (acdr expr) (sub1 count) apair? acdr))))
(define (style head expr apair? acar acdr) (define (style head expr apair? acar acdr)
(case (look-in-style-table head) (case (look-in-style-table head)
@ -1100,22 +1102,22 @@
syntax-rules syntax-rules
shared shared
unless when) unless when)
(and (no-sharing? expr 1 acdr) (and (no-sharing? expr 1 apair? acdr)
pp-lambda)) pp-lambda))
((if set! set!-values) ((if set! set!-values)
(and (no-sharing? expr 1 acdr) (and (no-sharing? expr 1 apair? acdr)
pp-if)) pp-if))
((cond case-lambda) ((cond case-lambda)
(and (no-sharing? expr 0 acdr) (and (no-sharing? expr 0 apair? acdr)
pp-cond)) pp-cond))
((case class) ((case class)
(and (no-sharing? expr 1 acdr) (and (no-sharing? expr 1 apair? acdr)
pp-case)) pp-case))
((and or import export ((and or import export
require require-for-syntax require-for-template require require-for-syntax require-for-template
provide link provide link
public private override rename inherit field init) public private override rename inherit field init)
(and (no-sharing? expr 0 acdr) (and (no-sharing? expr 0 apair? acdr)
pp-and)) pp-and))
((let letrec let* ((let letrec let*
let-values letrec-values let*-values let-values letrec-values let*-values
@ -1126,20 +1128,21 @@
(symbol? (acar (acdr expr)))) (symbol? (acar (acdr expr))))
2 2
1) 1)
apair?
acdr) acdr)
pp-let)) pp-let))
((begin begin0) ((begin begin0)
(and (no-sharing? expr 0 acdr) (and (no-sharing? expr 0 apair? acdr)
pp-begin)) pp-begin))
((do letrec-syntaxes+values) ((do letrec-syntaxes+values)
(and (no-sharing? expr 2 acdr) (and (no-sharing? expr 2 apair? acdr)
pp-do)) pp-do))
((send syntax-case instantiate module) ((send syntax-case instantiate module)
(and (no-sharing? expr 2 acdr) (and (no-sharing? expr 2 apair? acdr)
pp-syntax-case)) pp-syntax-case))
((make-object) ((make-object)
(and (no-sharing? expr 1 acdr) (and (no-sharing? expr 1 apair? acdr)
pp-make-object)) pp-make-object))
(else #f))) (else #f)))