diff options
Diffstat (limited to 'genwrite.scm')
| -rwxr-xr-x[-rw-r--r--] | genwrite.scm | 169 |
1 files changed, 82 insertions, 87 deletions
diff --git a/genwrite.scm b/genwrite.scm index 4f9105f..6d9b569 100644..100755 --- a/genwrite.scm +++ b/genwrite.scm @@ -18,12 +18,11 @@ (cadr l)) (define (read-macro-prefix l) - (let ((head (car l)) (tail (cdr l))) - (case head - ((quote) "'") - ((quasiquote) "`") - ((unquote) ",") - ((unquote-splicing) ",@")))) + (case (car l) + ((quote) "'") + ((quasiquote) "`") + ((unquote) ",") + ((unquote-splicing) ",@"))) (define (out str col) (and col (output str) (+ col (string-length str)))) @@ -32,8 +31,8 @@ (define (wr-expr expr col) (if (read-macro? expr) - (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) - (wr-lst expr col))) + (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) + (wr-lst expr col))) (define (wr-lst l col) (if (pair? l) @@ -54,27 +53,27 @@ ((symbol? obj) (out (symbol->string obj) col)) ((procedure? obj) (out "#[procedure]" col)) ((string? obj) (if display? - (out obj col) - (let loop ((i 0) (j 0) (col (out "\"" col))) - (if (and col (< j (string-length obj))) - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (loop j - (+ j 1) - (out "\\" - (out (substring obj i j) - col))) - (loop i (+ j 1) col))) - (out "\"" - (out (substring obj i j) col)))))) + (out obj col) + (let loop ((i 0) (j 0) (col (out "\"" col))) + (if (and col (< j (string-length obj))) + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (loop j + (+ j 1) + (out "\\" + (out (substring obj i j) + col))) + (loop i (+ j 1) col))) + (out "\"" + (out (substring obj i j) col)))))) ((char? obj) (if display? - (out (make-string 1 obj) col) - (out (case obj - ((#\space) "space") - ((#\newline) "newline") - (else (make-string 1 obj))) - (out "#\\" col)))) + (out (make-string 1 obj) col) + (out (case obj + ((#\space) "space") + ((#\newline) "newline") + (else (make-string 1 obj))) + (out "#\\" col)))) ((input-port? obj) (out "#[input-port]" col)) ((output-port? obj) (out "#[output-port]" col)) ((eof-object? obj) (out "#[eof-object]" col)) @@ -84,61 +83,57 @@ (define (spaces n col) (if (> n 0) - (if (> n 7) - (spaces (- n 8) (out " " col)) - (out (substring " " 0 n) col)) - col)) + (if (> n 7) + (spaces (- n 8) (out " " col)) + (out (substring " " 0 n) col)) + col)) (define (indent to col) (and col (if (< to col) - (and (out genwrite:newline-str col) (spaces to 0)) - (spaces (- to col) col)))) + (and (out genwrite:newline-str col) (spaces to 0)) + (spaces (- to col) col)))) (define (pr obj col extra pp-pair) (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines - (let ((result '()) - (left (min (+ (- (- width col) extra) 1) max-expr-width))) - (generic-write obj display? #f - (lambda (str) - (set! result (cons str result)) - (set! left (- left (string-length str))) - (> left 0))) - (if (> left 0) ; all can be printed on one line - (out (reverse-string-append result) col) - (if (pair? obj) - (pp-pair obj col extra) - (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) - (wr obj col))) + (let ((result '()) + (left (min (+ (- (- width col) extra) 1) max-expr-width))) + (generic-write obj display? #f + (lambda (str) + (set! result (cons str result)) + (set! left (- left (string-length str))) + (> left 0))) + (if (> left 0) ; all can be printed on one line + (out (reverse-string-append result) col) + (if (pair? obj) + (pp-pair obj col extra) + (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) + (wr obj col))) (define (pp-expr expr col extra) (if (read-macro? expr) - (pr (read-macro-body expr) - (out (read-macro-prefix expr) col) - extra - pp-expr) - (let ((head (car expr))) - (if (symbol? head) - (let ((proc (style head))) - (if proc - (proc expr col extra) - (if (> (string-length (symbol->string head)) - max-call-head-width) - (pp-general expr col extra #f #f #f pp-expr) - (pp-call expr col extra pp-expr)))) - (pp-list expr col extra pp-expr))))) - - ; (head item1 - ; item2 - ; item3) + (pr (read-macro-body expr) + (out (read-macro-prefix expr) col) + extra + pp-expr) + (let ((head (car expr))) + (if (symbol? head) + (let ((proc (style head))) + (if proc + (proc expr col extra) + (if (> (string-length (symbol->string head)) + max-call-head-width) + (pp-general expr col extra #f #f #f pp-expr) + (pp-call expr col extra pp-expr)))) + (pp-list expr col extra pp-expr))))) + + ; (head item1 item2 item3) (define (pp-call expr col extra pp-item) (let ((col* (wr (car expr) (out "(" col)))) (and col (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) - ; (item1 - ; item2 - ; item3) + ; (item1 item2 item3) (define (pp-list l col extra pp-item) (let ((col (out "(" col))) (pp-down l col col extra pp-item))) @@ -164,19 +159,19 @@ (define (tail1 rest col1 col2 col3) (if (and pp-1 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) - (tail2 rest col1 col2 col3))) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) + (tail2 rest col1 col2 col3))) (define (tail2 rest col1 col2 col3) (if (and pp-2 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) - (tail3 rest col1 col2))) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) + (tail3 rest col1 col2))) (define (tail3 rest col1 col2) (pp-down rest col2 col1 extra pp-3)) @@ -185,11 +180,11 @@ (rest (cdr expr)) (col* (wr head (out "(" col)))) (if (and named? (pair? rest)) - (let* ((name (car rest)) - (rest (cdr rest)) - (col** (wr name (out " " col*)))) - (tail1 rest (+ col indent-general) col** (+ col** 1))) - (tail1 rest (+ col indent-general) col* (+ col* 1))))) + (let* ((name (car rest)) + (rest (cdr rest)) + (col** (wr name (out " " col*)))) + (tail1 rest (+ col indent-general) col** (+ col** 1))) + (tail1 rest (+ col indent-general) col* (+ col* 1))))) (define (pp-expr-list l col extra) (pp-list l col extra pp-expr)) @@ -220,7 +215,7 @@ (define (pp-DO expr col extra) (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) - ; define formatting style (change these to suit your style) +;;; define formatting style (change these to suit your style) (define indent-general 2) @@ -243,10 +238,10 @@ (pr obj col 0 pp-expr)) (if width - (out genwrite:newline-str (pp obj 0)) - (wr obj 0))) + (out genwrite:newline-str (pp obj 0)) + (wr obj 0))) -; (reverse-string-append l) = (apply string-append (reverse l)) +;;; (reverse-string-append l) = (apply string-append (reverse l)) ;@ (define (reverse-string-append l) |