Issue #380 - Support optional args to write-string

CHANGELOG.md

@@ -14,6 +14,7 @@ Bug Fixes
 - Fix `list-copy` to return a non-list object instead of raising an error, per R7RS.
 - Fixed `eqv?` to use R7RS semantics to ensure equality of different instances of the same numeric value. The function was previously just an alias of `eq?`.
 - Support two-argument version of `atan`.
+- Support `start` and `end` arguments to `write-string`.
 
 ## 0.17 - April 6, 2020
 

scheme/base.sld

@@ -135,6 +135,8 @@
     newline
     write-char
     write-string
+    write-string-1
+    write-string-2
     flush-output-port
     peek-char
     read-char
@@ -716,10 +718,22 @@
       (if (null? port)
         (Cyc-flush-output-port (current-output-port))
         (Cyc-flush-output-port (car port))))
-    (define (write-string str . port)
-      (if (null? port)
-        (Cyc-display str (current-output-port))
-        (Cyc-display str (car port))))
+    (define (write-string-1 str)
+      (Cyc-display str (current-output-port)))
+    (define (write-string-2 str port)
+      (Cyc-display str port))
+    (define (write-string str . opts)
+      (cond
+       ((null? opts)
+        (Cyc-display str (current-output-port)))
+       ((null? (cdr opts))
+        (Cyc-display str (car opts)))
+       (else 
+        (let ((start (cadr opts))
+              (end (if (> (length opts) 2) (caddr opts) (string-length str))))
+          (Cyc-display
+            (substring str start end)
+            (car opts))))))
     (define (read-bytevector k . _port)
       (letrec ((port (if (null? port)
                          (current-input-port)

scheme/cyclone/transforms.sld

@@ -1129,6 +1129,10 @@ if (acc) {
            (cons 'Cyc-map-loop-1 (map (lambda (a) (convert a renamed)) (cdr ast))))
           ((and (eq? (car ast) 'map) (= (length ast) 4))
            (cons 'Cyc-map-loop-2 (map (lambda (a) (convert a renamed)) (cdr ast))))
+          ((and (eq? (car ast) 'write-string) (= (length ast) 2))
+           (cons 'write-string-1 (map (lambda (a) (convert a renamed)) (cdr ast))))
+          ((and (eq? (car ast) 'write-string) (= (length ast) 3))
+           (cons 'write-string-2 (map (lambda (a) (convert a renamed)) (cdr ast))))
           ;; Regular case, alpha convert everything
           (else
            (regular-case)))))