Changeset 12107 in project


Ignore:
Timestamp:
10/03/08 08:44:40 (11 years ago)
Author:
ashinn
Message:

Copying changes from upstream.

Location:
release/3/fmt
Files:
3 edited

Legend:

Unmodified
Added
Removed

  • release/3/fmt/fmt-pretty.scm

    r10190 r12107  
    4040  (let ((sep (dsp (if (pair? o) (car o) " "))))
    4141    (lambda (st)
    42       (let* ((shares (fmt-shares st))
    43              (tab (car shares))
    44              (output (fmt-writer st)))
    45         (let lp ((ls ls) (st st))
    46           (let ((st ((fmt (car ls)) st))
    47                 (rest (cdr ls)))
    48             (cond
    49               ((null? rest) st)
    50               ((pair? rest)
    51                (call-with-shared-ref/cdr rest st shares
    52                    (lambda (st) (lp rest st))
    53                  sep))
    54               (else ((fmt rest) (output ". " (sep st)))))))))))
     42      (if (null? ls)
     43          st
     44          (let* ((shares (fmt-shares st))
     45                 (tab (car shares))
     46                 (output (fmt-writer st)))
     47            (let lp ((ls ls) (st st))
     48              (let ((st ((fmt (car ls)) st))
     49                    (rest (cdr ls)))
     50                (cond
     51                 ((null? rest) st)
     52                 ((pair? rest)
     53                  (call-with-shared-ref/cdr rest st shares
     54                      (lambda (st) (lp rest st))
     55                    sep))
     56                 (else ((fmt rest) (output ". " (sep st))))))))))))
    5557
    5658;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    5961(define (non-app? x)
    6062  (if (pair? x)
    61       (non-app? (car x))
     63      (or (not (or (null? (cdr x)) (pair? (cdr x))))
     64          (non-app? (car x)))
    6265      (not (symbol? x))))
    6366
    … …  
    9598  (let ((indent
    9699         (cond
    97            ((assq (car form) indent-rules) => cdr)
    98            ((and (symbol? (car form))
    99                  (let ((str (symbol->string (car form))))
    100                    (or (find (lambda (rx) (string-prefix? (car rx) str))
    101                              indent-prefix-rules)
    102                        (find (lambda (rx) (string-suffix? (car rx) str))
    103                              indent-suffix-rules))))
    104             => cdr)
    105            (else #f))))
     100          ((assq (car form) indent-rules) => cdr)
     101          ((and (symbol? (car form))
     102                (let ((str (symbol->string (car form))))
     103                  (or (find (lambda (rx) (string-prefix? (car rx) str))
     104                            indent-prefix-rules)
     105                      (find (lambda (rx) (string-suffix? (car rx) str))
     106                            indent-suffix-rules))))
     107           => cdr)
     108          (else #f))))
    106109    (if (and (number? indent) (negative? indent))
    107110        (max 0 (- (+ (length+ form) indent) 1))
    … …  
    121124             (let ((sep (make-nl-space (+ col1 1))))
    122125               (cat sep (fmt-join/shares pp-object (cdr ls) sep) ")"))))
    123       (if (< (+ col2 (string-length first-line)) (fmt-width st2))
    124           ;; fixed values on first line
    125           (let ((sep (make-nl-space
    126                       (if indent-rule (+ col1 2) (+ col2 1)))))
    127             ((cat first-line
    128                   (if (> (length+ (cdr ls)) (or indent-rule 1))
    129                       (cat sep (fmt-join/shares pp-object tail sep))
    130                       "")
    131                   ")")
    132              st2))
    133           (if indent-rule ;;(and indent-rule (not (pair? (car ls))))
    134               ;; fixed values lined up, body indented two spaces
    135               ((fmt-try-fit
    136                 (lambda (st)
    137                   ((cat
    138                     " "
    139                     (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1)))
    140                     (if (pair? tail)
    141                         (let ((sep (make-nl-space (+ col1 2))))
    142                           (cat sep (fmt-join/shares pp-object tail sep)))
    143                         "")
    144                     ")")
    145                    (fmt-copy-shares st)))
    146                 default)
    147                st)
    148               ;; all on separate lines
    149               (default st))))))
     126      (cond
     127       ((< (+ col2 (string-length first-line)) (fmt-width st2))
     128        ;; fixed values on first line
     129        (let ((sep (make-nl-space
     130                    (if indent-rule (+ col1 2) (+ col2 1)))))
     131          ((cat first-line
     132                (cond
     133                 ((not (or (null? tail) (pair? tail)))
     134                  (cat ". " (pp-object tail)))
     135                 ((> (length+ (cdr ls)) (or indent-rule 1))
     136                  (cat sep (fmt-join/shares pp-object tail sep)))
     137                 (else
     138                  fmt-null))
     139                ")")
     140           st2)))
     141       (indent-rule ;;(and indent-rule (not (pair? (car ls))))
     142        ;; fixed values lined up, body indented two spaces
     143        ((fmt-try-fit
     144          (lambda (st)
     145            ((cat
     146              " "
     147              (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1)))
     148              (if (pair? tail)
     149                  (let ((sep (make-nl-space (+ col1 2))))
     150                    (cat sep (fmt-join/shares pp-object tail sep)))
     151                  "")
     152              ")")
     153             (fmt-copy-shares st)))
     154          default)
     155         st))
     156       (else
     157        ;; all on separate lines
     158        (default st))))))
    150159
    151160(define (pp-app ls)
    … …  
    178187         (cat "(" (fmt-join/shares pp-flat x " ") ")")))))
    179188    ((vector? x)
    180      (fmt-shared-write x (cat "#(" (fmt-join pp-flat (vector->list x) " ") ")")))
    181     (else (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))
     189     (fmt-shared-write
     190      x
     191      (cat "#(" (fmt-join/shares pp-flat (vector->list x) " ") ")")))
     192    (else
     193     (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))
    182194
    183195(define (pp-pair ls)
    … …  
    185197   ls
    186198   (cond
    187      ;; one element list, no lines to break
    188      ((null? (cdr ls))
    189       (cat "(" (pp-object (car ls)) ")"))
    190      ;; quote or other abbrev
    191      ((and (pair? (cdr ls)) (null? (cddr ls))
    192            (assq (car ls) syntax-abbrevs))
    193       => (lambda (abbrev)
    194            (cat (cdr abbrev) (pp-object (cadr ls)))))
    195      (else
    196       (fmt-try-fit
    197        (lambda (st) ((pp-flat ls) (fmt-copy-shares st)))
    198        (lambda (st)
    199          (if (and (non-app? ls)
    200                   (proper-non-shared-list? ls (fmt-shares st)))
    201              ((pp-data-list ls) st)
    202              ((pp-app ls) st))))))))
     199    ;; one element list, no lines to break
     200    ((null? (cdr ls))
     201     (cat "(" (pp-object (car ls)) ")"))
     202    ;; quote or other abbrev
     203    ((and (pair? (cdr ls)) (null? (cddr ls))
     204          (assq (car ls) syntax-abbrevs))
     205     => (lambda (abbrev)
     206          (cat (cdr abbrev) (pp-object (cadr ls)))))
     207    (else
     208     (fmt-try-fit
     209      (lambda (st) ((pp-flat ls) (fmt-copy-shares st)))
     210      (lambda (st)
     211        (if (and (non-app? ls)
     212                 (proper-non-shared-list? ls (fmt-shares st)))
     213            ((pp-data-list ls) st)
     214            ((pp-app ls) st))))))))
    203215
    204216(define (pp-data-list ls)

  • release/3/fmt/fmt.setup

    r11803 r12107  
    99 'fmt
    1010 '("fmt.so")
    11  `((version 0.516)
     11 `((version 0.517)
    1212   (documentation "fmt.html")
    1313         ,@(if has-exports? `((exports "fmt.exports")) '())) )
    … …  
    2121 'fmt-c
    2222 '("fmt-c.so")
    23  `((version 0.516)
     23 `((version 0.517)
    2424   (documentation "fmt.html")
    2525         ,@(if has-exports? `((exports "fmt-c.exports")) '())) )
    … …  
    3333 'fmt-color
    3434 '("fmt-color.so")
    35  `((version 0.516)
     35 `((version 0.517)
    3636   (documentation "fmt.html")
    3737         ,@(if has-exports? `((exports "fmt-color.exports")) '())) )
    … …  
    4545 'fmt-unicode
    4646 '("fmt-unicode.so")
    47  `((version 0.516)
     47 `((version 0.517)
    4848   (documentation "fmt.html")
    4949         ,@(if has-exports? `((exports "fmt-unicode.exports")) '())) )

  • release/3/fmt/test-fmt.scm

    r11803 r12107  
    6666(test-error (fmt #f (num 1e-17 0)))
    6767
    68 (test "11.75" (fmt #f (num 47/4 10 2)))
    69 (test "-11.75" (fmt #f (num -47/4 10 2)))
     68(test "11.75" (fmt #f (num (/ 47 4) 10 2)))
     69(test "-11.75" (fmt #f (num (/ -47 4) 10 2)))
    7070
    7171(test "(#x11 #x22 #x33)" (fmt #f (radix 16 '(#x11 #x22 #x33))))
    … …  
    192192
    193193(test-pretty "(foo bar)\n")
     194
     195(test-pretty
     196"((self . aquanet-paper-1991)
     197 (type . paper)
     198 (title . \"Aquanet: a hypertext tool to hold your\"))
     199")
    194200
    195201(test-pretty
Note: See TracChangeset for help on using the changeset viewer.