Changeset 12107 in project
- Timestamp:
- 10/03/08 08:44:40 (12 years ago)
- Location:
- release/3/fmt
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/fmt/fmt-pretty.scm
r10190 r12107 40 40 (let ((sep (dsp (if (pair? o) (car o) " ")))) 41 41 (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)))))))))))) 55 57 56 58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; … … 59 61 (define (non-app? x) 60 62 (if (pair? x) 61 (non-app? (car x)) 63 (or (not (or (null? (cdr x)) (pair? (cdr x)))) 64 (non-app? (car x))) 62 65 (not (symbol? x)))) 63 66 … … 95 98 (let ((indent 96 99 (cond 97 98 99 100 101 102 103 104 105 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)))) 106 109 (if (and (number? indent) (negative? indent)) 107 110 (max 0 (- (+ (length+ form) indent) 1)) … … 121 124 (let ((sep (make-nl-space (+ col1 1)))) 122 125 (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)))))) 150 159 151 160 (define (pp-app ls) … … 178 187 (cat "(" (fmt-join/shares pp-flat x " ") ")"))))) 179 188 ((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))))) 182 194 183 195 (define (pp-pair ls) … … 185 197 ls 186 198 (cond 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 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)))))))) 203 215 204 216 (define (pp-data-list ls) -
release/3/fmt/fmt.setup
r11803 r12107 9 9 'fmt 10 10 '("fmt.so") 11 `((version 0.51 6)11 `((version 0.517) 12 12 (documentation "fmt.html") 13 13 ,@(if has-exports? `((exports "fmt.exports")) '())) ) … … 21 21 'fmt-c 22 22 '("fmt-c.so") 23 `((version 0.51 6)23 `((version 0.517) 24 24 (documentation "fmt.html") 25 25 ,@(if has-exports? `((exports "fmt-c.exports")) '())) ) … … 33 33 'fmt-color 34 34 '("fmt-color.so") 35 `((version 0.51 6)35 `((version 0.517) 36 36 (documentation "fmt.html") 37 37 ,@(if has-exports? `((exports "fmt-color.exports")) '())) ) … … 45 45 'fmt-unicode 46 46 '("fmt-unicode.so") 47 `((version 0.51 6)47 `((version 0.517) 48 48 (documentation "fmt.html") 49 49 ,@(if has-exports? `((exports "fmt-unicode.exports")) '())) ) -
release/3/fmt/test-fmt.scm
r11803 r12107 66 66 (test-error (fmt #f (num 1e-17 0))) 67 67 68 (test "11.75" (fmt #f (num 47/410 2)))69 (test "-11.75" (fmt #f (num -47/410 2)))68 (test "11.75" (fmt #f (num (/ 47 4) 10 2))) 69 (test "-11.75" (fmt #f (num (/ -47 4) 10 2))) 70 70 71 71 (test "(#x11 #x22 #x33)" (fmt #f (radix 16 '(#x11 #x22 #x33)))) … … 192 192 193 193 (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 ") 194 200 195 201 (test-pretty
Note: See TracChangeset
for help on using the changeset viewer.