summaryrefslogtreecommitdiffstats
path: root/genwrite.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /genwrite.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'genwrite.scm')
-rw-r--r--genwrite.scm32
1 files changed, 17 insertions, 15 deletions
diff --git a/genwrite.scm b/genwrite.scm
index 0bb4e56..2e4bf60 100644
--- a/genwrite.scm
+++ b/genwrite.scm
@@ -3,13 +3,15 @@
;; Author: Marc Feeley (feeley@iro.umontreal.ca)
;; Distribution restrictions: none
+(define genwrite:newline-str (make-string 1 #\newline))
+
(define (generic-write obj display? width output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(let ((head (car l)) (tail (cdr l)))
(case head
- ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail))
+ ((quote quasiquote unquote unquote-splicing) (length1? tail))
(else #f))))
(define (read-macro-body l)
@@ -18,10 +20,10 @@
(define (read-macro-prefix l)
(let ((head (car l)) (tail (cdr l)))
(case head
- ((QUOTE) "'")
- ((QUASIQUOTE) "`")
- ((UNQUOTE) ",")
- ((UNQUOTE-SPLICING) ",@"))))
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@"))))
(define (out str col)
(and col (output str) (+ col (string-length str))))
@@ -90,7 +92,7 @@
(define (indent to col)
(and col
(if (< to col)
- (and (out (make-string 1 #\newline) col) (spaces to 0))
+ (and (out genwrite:newline-str col) (spaces to 0))
(spaces (- to col) col))))
(define (pr obj col extra pp-pair)
@@ -228,20 +230,20 @@
(define (style head)
(case head
- ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA)
- ((IF SET!) pp-IF)
- ((COND) pp-COND)
- ((CASE) pp-CASE)
- ((AND OR) pp-AND)
- ((LET) pp-LET)
- ((BEGIN) pp-BEGIN)
- ((DO) pp-DO)
+ ((lambda let* letrec define) pp-LAMBDA)
+ ((if set!) pp-IF)
+ ((cond) pp-COND)
+ ((case) pp-CASE)
+ ((and or) pp-AND)
+ ((let) pp-LET)
+ ((begin) pp-BEGIN)
+ ((do) pp-DO)
(else #f)))
(pr obj col 0 pp-expr))
(if width
- (out (make-string 1 #\newline) (pp obj 0))
+ (out genwrite:newline-str (pp obj 0))
(wr obj 0)))
; (reverse-string-append l) = (apply string-append (reverse l))