From a3d4e9492f602193629b805556a17bf1c24b52cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Jun 2008 15:11:20 +0000 Subject: [PATCH] fix some phase problems in program-processing programs svn: r10503 original commit: 44c5a757390775f2142a9f1dc2874ee41f285dcd --- collects/mzlib/pretty.ss | 224 +++++++++++++++++++++++---------------- 1 file changed, 134 insertions(+), 90 deletions(-) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index b48d95c..e5ca95b 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -793,6 +793,7 @@ (let* ([can-multi (and width (not (size-hook obj display?)) (or (pair? obj) + (mpair? obj) (vector? obj) (and (box? obj) print-box?) (and (custom-write? obj) @@ -831,7 +832,10 @@ (expr-found pport graph-ref)) (pre-print pport obj) (cond - [(pair? obj) (pp-pair obj extra depth)] + [(pair? obj) (pp-pair obj extra depth + pair? car cdr pair-open pair-close)] + [(mpair? obj) (pp-pair obj extra depth + mpair? mcar mcdr mpair-open mpair-close)] [(vector? obj) (out "#") (when print-vec-length? @@ -858,22 +862,25 @@ ;; Not possible to split obj across lines; so just write directly (wr* pport obj depth display?)))) - (define (pp-expr expr extra depth) - (if (and (read-macro? expr pair? car cdr) - (not (and found (hash-table-get found (cdr expr) #f)))) + (define (pp-expr expr extra depth + apair? acar acdr open close) + (if (and (read-macro? expr apair? acar acdr) + (equal? open "(") + (not (and found (hash-table-get found (acdr expr) #f)))) (begin - (out (read-macro-prefix expr car)) - (pr (read-macro-body expr car cdr) + (out (read-macro-prefix expr acar)) + (pr (read-macro-body expr acar acdr) extra pp-expr depth)) - (let ((head (car expr))) + (let ((head (acar expr))) (if (or (and (symbol? head) (not (size-hook head display?))) ((pretty-print-remap-stylable) head)) - (let ((proc (style head expr))) + (let ((proc (style head expr apair? acar acdr))) (if proc - (proc expr extra depth) + (proc expr extra depth + apair? acar acdr open close) (if (and #f ;; Why this special case? Currently disabled. (> (string-length @@ -882,9 +889,12 @@ head ((pretty-print-remap-stylable) head)))) max-call-head-width)) - (pp-general expr extra #f #f #f pp-expr depth) - (pp-list expr extra pp-expr #t depth)))) - (pp-list expr extra pp-expr #t depth))))) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close)))) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close))))) (define (wr obj depth) (wr* pport obj depth display?)) @@ -892,44 +902,53 @@ ;; (head item1 ;; item2 ;; item3) - (define (pp-call expr extra pp-item depth) - (out "(") - (wr (car expr) (dsub1 depth)) + (define (pp-call expr extra pp-item depth + apair? acar acdr open close) + (out open) + (wr (acar expr) (dsub1 depth)) (let ([col (+ (ccol) 1)]) - (pp-down ")" (cdr expr) col col extra pp-item #t #t depth))) + (pp-down close (acdr expr) col col extra pp-item #t #t depth + apair? acar acdr open close))) ;; (head item1 item2 ;; item3 ;; item4) - (define (pp-two-up expr extra pp-item depth) - (out "(") + (define (pp-two-up expr extra pp-item depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (wr (car expr) (dsub1 depth)) + (wr (acar expr) (dsub1 depth)) (out " ") - (wr (cadr expr) (dsub1 depth)) - (pp-down ")" (cddr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) + (wr (acar (acdr expr)) (dsub1 depth)) + (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close))) ;; (head item1 ;; item2 ;; item3) - (define (pp-one-up expr extra pp-item depth) - (out "(") + (define (pp-one-up expr extra pp-item depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (wr (car expr) (dsub1 depth)) - (pp-down ")" (cdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) + (wr (acar expr) (dsub1 depth)) + (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close))) ;; (item1 ;; item2 ;; item3) - (define (pp-list l extra pp-item check? depth) - (out "(") + (define (pp-list l extra pp-item check? depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (pp-down ")" l col col extra pp-item #f check? depth))) + (pp-down close l col col extra pp-item #f check? depth + apair? acar acdr open close))) - (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth) + (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth + apair? acar acdr open close) (let loop ([l l] [icol col1] [check? check-first?]) (check-expr-found - l pport (and check? (pair? l)) + l pport (and check? (apair? l)) (lambda (s) (indent col2) (out ".") @@ -944,11 +963,11 @@ (out closer)) (lambda () (cond - [(pair? l) - (let ([rest (cdr l)]) + [(apair? l) + (let ([rest (acdr l)]) (let ([extra (if (null? rest) (+ extra 1) 0)]) (indent icol) - (pr (car l) extra pp-item (dsub1 depth)) + (pr (acar l) extra pp-item (dsub1 depth)) (loop rest col2 check-rest?)))] [(null? l) (out closer)] @@ -959,12 +978,13 @@ (pr l (+ extra 1) pp-item (dsub1 depth)) (out closer)]))))) - (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth) + (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth + apair? acar acdr open close) (define (tail1 rest col1 col3) - (if (and pp-1 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) + (if (and pp-1 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (indent col3) (pr val1 extra pp-1 depth) @@ -972,9 +992,9 @@ (tail2 rest col1 col3))) (define (tail2 rest col1 col3) - (if (and pp-2 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) + (if (and pp-2 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (indent col3) (pr val1 extra pp-2 depth) @@ -982,55 +1002,78 @@ (tail3 rest col1))) (define (tail3 rest col1) - (pp-down ")" rest col1 col1 extra pp-3 #f #t depth)) + (pp-down close rest col1 col1 extra pp-3 #f #t depth + apair? acar acdr open close)) - (let* ([head (car expr)] - [rest (cdr expr)] + (let* ([head (acar expr)] + [rest (acdr expr)] [col (ccol)]) - (out "(") + (out open) (wr head (dsub1 depth)) - (if (and named? (pair? rest)) - (let* ((name (car rest)) - (rest (cdr rest))) + (if (and named? (apair? rest)) + (let* ((name (acar rest)) + (rest (acdr rest))) (out " ") (wr name (dsub1 depth)) (tail1 rest (+ col indent-general) (+ (ccol) 1))) (tail1 rest (+ col indent-general) (+ (ccol) 1))))) - (define (pp-expr-list l extra depth) - (pp-list l extra pp-expr #t depth)) + (define (pp-expr-list l extra depth + apair? acar acdr open close) + (pp-list l extra pp-expr #t depth + apair? acar acdr open close)) - (define (pp-lambda expr extra depth) - (pp-general expr extra #f pp-expr-list #f pp-expr depth)) + (define (pp-lambda expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr-list #f pp-expr depth + apair? acar acdr open close)) - (define (pp-if expr extra depth) - (pp-general expr extra #f pp-expr #f pp-expr depth)) + (define (pp-if expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr #f pp-expr depth + apair? acar acdr open close)) - (define (pp-cond expr extra depth) - (pp-list expr extra pp-expr-list #t depth)) + (define (pp-cond expr extra depth + apair? acar acdr open close) + (pp-list expr extra pp-expr-list #t depth + apair? acar acdr open close)) - (define (pp-class expr extra depth) - (pp-two-up expr extra pp-expr-list depth)) + (define (pp-syntax-case expr extra depth + apair? acar acdr open close) + (pp-two-up expr extra pp-expr-list depth + apair? acar acdr open close)) - (define (pp-make-object expr extra depth) - (pp-one-up expr extra pp-expr-list depth)) + (define (pp-make-object expr extra depth + apair? acar acdr open close) + (pp-one-up expr extra pp-expr-list depth + apair? acar acdr open close)) - (define (pp-case expr extra depth) - (pp-general expr extra #f pp-expr #f pp-expr-list depth)) + (define (pp-case expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr #f pp-expr-list depth + apair? acar acdr open close)) - (define (pp-and expr extra depth) - (pp-call expr extra pp-expr depth)) + (define (pp-and expr extra depth + apair? acar acdr open close) + (pp-call expr extra pp-expr depth + apair? acar acdr open close)) - (define (pp-let expr extra depth) - (let* ((rest (cdr expr)) - (named? (and (pair? rest) (symbol? (do-remap (car rest)))))) - (pp-general expr extra named? pp-expr-list #f pp-expr depth))) + (define (pp-let expr extra depth + apair? acar acdr open close) + (let* ((rest (acdr expr)) + (named? (and (apair? rest) (symbol? (do-remap (acar rest)))))) + (pp-general expr extra named? pp-expr-list #f pp-expr depth + apair? acar acdr open close))) - (define (pp-begin expr extra depth) - (pp-general expr extra #f #f #f pp-expr depth)) + (define (pp-begin expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close)) - (define (pp-do expr extra depth) - (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth)) + (define (pp-do expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth + apair? acar acdr open close)) ;; define formatting style (change these to suit your style) @@ -1038,57 +1081,58 @@ (define max-call-head-width 5) - (define (no-sharing? expr count) - (if (and found (hash-table-get found (cdr expr) #f)) + (define (no-sharing? expr count acdr) + (if (and found (hash-table-get found (acdr expr) #f)) #f (or (zero? count) - (no-sharing? (cdr expr) (sub1 count))))) + (no-sharing? (acdr expr) (sub1 count) acdr)))) - (define (style head expr) + (define (style head expr apair? acar acdr) (case (look-in-style-table head) ((lambda λ define define-macro define-syntax syntax-rules shared unless when) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-lambda)) ((if set! set!-values) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-if)) ((cond case-lambda) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-cond)) - ((case) - (and (no-sharing? expr 1) + ((case class) + (and (no-sharing? expr 1 acdr) pp-case)) ((and or import export require require-for-syntax require-for-template provide link public private override rename inherit field init) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-and)) ((let letrec let* let-values letrec-values let*-values let-syntax letrec-syntax let-syntaxes letrec-syntaxes) (and (no-sharing? expr - (if (and (pair? (cdr expr)) - (symbol? (cadr expr))) + (if (and (apair? (acdr expr)) + (symbol? (acar (acdr expr)))) 2 - 1)) + 1) + acdr) pp-let)) ((begin begin0) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-begin)) ((do letrec-syntaxes+values) - (and (no-sharing? expr 2) + (and (no-sharing? expr 2 acdr) pp-do)) - ((send class syntax-case instantiate module) - (and (no-sharing? expr 2) - pp-class)) + ((send syntax-case instantiate module) + (and (no-sharing? expr 2 acdr) + pp-syntax-case)) ((make-object) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-make-object)) (else #f)))