r7rs.stk 25.4 KB
Newer Older
1
;;;;
2
;;;; r7rs.stk   -- R7RS support (Draft-3)
3
;;;;
4
;;;; Copyright © 2011-2018 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Apr-2011 19:36 (eg)
24
;;;; Last file update:  1-Aug-2018 19:08 (eg)
25 26
;;;;

27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
;;;; ----------------------------------------------------------------------
;;;; 6.3 Booleans
;;;; ----------------------------------------------------------------------

#|
<doc boolean=?
 * (boolean=? boolean1 boolean2  ...)
 *
 * Returns #t if all the arguments are booleans and all are #t or all are #f.
 *
doc>
|#
(define (boolean=? e1 . rest)
  (letrec ((verify (lambda (val lst)
                  (or (null? lst)
                     (and (boolean? (car lst))
                        (eq? (car lst) val)
                        (verify val (cdr lst)))))))
    (verify e1 rest)))

47
;;;; ----------------------------------------------------------------------
48
;;;; 6.4 Pairs and lists
49 50 51
;;;; ----------------------------------------------------------------------

#|
Erick's avatar
Erick committed
52
<doc R7RS make-list
53 54 55 56 57 58 59 60 61 62 63
 * (make-list k)
 * (make-list k fill)
 *
 * Returns a newly allocated list of k elements. If a second
 * argument is given, then each element is initialized to fill .
 * Otherwise the initial contents of each element is unspecified.
doc>
|#
(define (make-list k :optional (fill (void)))
  (vector->list (make-vector k fill)))

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83

;;;; ----------------------------------------------------------------------
;;;; 6.5 Symbols
;;;; ----------------------------------------------------------------------
#|
<doc symbol=?
 * (symbol=? symbol1 symbol2  ...)
 *
 * Returns #t if all the arguments are symbols and all have the same name in
 * the sense of |string=?|.
doc>
|#
(define (symbol=? e1 . rest)
  (letrec ((verify (lambda (val lst)
                  (or (null? lst)
                     (and (symbol? (car lst))
                        (eq? (car lst) val)
                        (verify val (cdr lst)))))))
    (verify e1 rest)))

84
;;;; ----------------------------------------------------------------------
85
;;;; 6.7 Strings
86 87
;;;; ----------------------------------------------------------------------

88 89 90
;;
;; Generalized string comparison functions
;;
91 92
(define-macro (%generalize-string-compare func func2)
  `(begin
93
     ;; Keep the old function since it is twice faster than the general one
94
     (define ,func2 ,func)
95 96 97 98 99 100 101 102 103 104
     ;; define the generalized function
     (set! ,func (lambda (first . l)
                   (letrec ((compare (lambda (first . l)
                                       (or (null? l)
                                          (and (,func2 first (car l))
                                             (apply compare l))))))
                     (unless (string? first) (error "bad string ~W" first))
                     (apply compare first l))))
     ;; Set the name of the new function to the old one for better error messages
     (%set-procedure-name! ,func ',func)))
105

106 107 108 109 110 111 112 113 114 115 116
(%generalize-string-compare string=?     %string2=?)
(%generalize-string-compare string<?     %string2<?)
(%generalize-string-compare string<=?    %string2<=?)
(%generalize-string-compare string>?     %string2>?)
(%generalize-string-compare string>=?    %string2>=?)

(%generalize-string-compare string-ci=?  %string-ci2=?)
(%generalize-string-compare string-ci<?  %string-ci2<?)
(%generalize-string-compare string-ci<=? %string-ci2<=?)
(%generalize-string-compare string-ci>?  %string-ci2>?)
(%generalize-string-compare string-ci>=? %string-ci2>=?)
117

118 119 120 121 122 123
;;
;; Generalized string->list
;;
(let ((s->l string->list)) ;; s->l is the R5RS function
  (set! string->list
        (lambda (str :optional (start 0 start?) (end 0 end?))
Erick's avatar
Erick committed
124
          (if start?
125
              (let ((end (if end? end (string-length str))))
Erick's avatar
Erick committed
126
                (%claim-error 'string->list
127 128 129 130 131
                              (s->l (substring str start end))))
              (s->l str))))
  (%set-procedure-name! string->list 'string->list))


132
#|
133
<doc R7RS string-copy!
134 135 136 137 138 139 140 141 142 143 144
 * (string-copy! to at from)
 * (string-copy! to at from start)
 * (string-copy! to at from start end)
 *
 *  Copies the characters of |string| from between |start| and |end|
 * to string |to|, starting at |at|. The order in which characters are copied
 * is unspecified, except that if the source and destination overlap,
 * copying takes place as if the source is first copied into a temporary
 * string and then into the destination. This can be achieved without
 * allocating storage by making sure to copy in the correct direction in
 * such circumstances.
145
 *
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
 * It is an error if |at| is less than zero or greater than the length
 * of |to|. It is also an error if |(- (string-length to) at)| is less
 * than |(- end start)|.
doc>
|#
(define (string-copy! to at from :optional (start 0 start?) (end 0 end?))
  (define (err . l)
    (apply error 'string-copy! l))

  (define (%string-copy! to tstart from fstart fend)
    (if (> fstart tstart)
        (do ((i fstart (+ i 1))
             (j tstart (+ j 1)))
            ((>= i fend))
          (string-set! to j (string-ref from i)))

        (do ((i (- fend 1)                    (- i 1))
             (j (+ -1 tstart (- fend fstart)) (- j 1)))
            ((< i fstart))
          (string-set! to j (string-ref from i)))))

  ;; body starts here
  (unless (string? to)   (err "bad string ~S" to))
  (unless (string? from) (err "bad string ~S" from))
  (let ((length-from (string-length from))
        (length-to   (string-length to)))
    (unless (and (integer? at) (>= at 0) (< at length-to))
      (err "bad destination index ~S" at))
    (when start?
      (unless (and (integer? start) (>= start 0) (<= start length-from))
        (err "bad integer for start index ~S" start)))
    (if end?
        (unless (and (integer? end) (>= end 0) (<= end length-from))
          (err "bad integer for end index ~S" end))
        (set! end (string-length from)))
    (when (< (- length-to at) (- end start))
      (err "not enough room in destination string ~S" to))

    ;; do the copy
Erick's avatar
Erick committed
185
    (%claim-error 'string-copy!
186 187
                  (%string-copy! to at from start end))))

188 189 190 191 192 193 194 195
;;
;; R7RS string-fill!
;;

; Keep the R5RS version available
(define %string-fill2! string-fill!)
;; Implement the one with 2 to 4 parameters
(let ((fill (lambda (str char :optional (start 0 start?) (end 0 end?))
Erick's avatar
Erick committed
196 197 198 199 200 201 202 203 204 205 206 207 208
              (%claim-error
                 'string-fill!
                 (if start?
                     ;; R7RS string-fill!
                     (begin
                       (unless end?
                         (set! end (string-length str)))
                       (let Loop ((i start))
                         (when (< i end)
                           (string-set! str i char)
                           (Loop (+ i 1)))))
                     ;; R5RS string-fill!
                     (%string-fill2! str char))))))
209 210 211 212
  (set! string-fill! fill)
  (%set-procedure-name! string-fill! 'string-fill!))


213 214 215
;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234

;;
;; Generalized string->list
;;
(let ((v->l vector->list)) ;; v->l is the R5RS function
  (set! vector->list
        (lambda (v :optional (start 0 start?) (end 0 end?))
          (if start?
              (let ((end (if end? end (vector-length v))))
                (%claim-error
                 'vector->list
                 (do ((i (- end 1) (- i 1))
                      (result '() (cons (vector-ref v i) result)))
                     ((< i start) result))))
              ;; R5RS function (without start or endà
              (v->l v))))
  (%set-procedure-name! vector->list 'vector->list))


235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282

#|
<doc R7RS vector-copy!
 * (vector-copy! to at from)
 * (vector-copy! to at from start)
 * (vector-copy! to at from start end)
 *
doc>
|#
(define (vector-copy! to at from :optional (start 0 start?) (end 0 end?))
  (define (err . l)
    (apply error 'vector-copy! l))

  (define (%vector-copy! to tstart from fstart fend)
    (if (> fstart tstart)
        (do ((i fstart (+ i 1))
             (j tstart (+ j 1)))
            ((>= i fend))
          (vector-set! to j (vector-ref from i)))

        (do ((i (- fend 1)                    (- i 1))
             (j (+ -1 tstart (- fend fstart)) (- j 1)))
            ((< i fstart))
          (vector-set! to j (vector-ref from i)))))

  ;; body starts here
  (unless (vector? to)   (err "bad vector ~S" to))
  (unless (vector? from) (err "bad vector ~S" from))
  (let ((length-from (vector-length from))
        (length-to   (vector-length to)))
    (unless (and (integer? at) (>= at 0) (< at length-to))
      (err "bad destination index ~S" at))
    (when start?
      (unless (and (integer? start) (>= start 0) (<= start length-from))
        (err "bad integer for start index ~S" start)))
    (if end?
        (unless (and (integer? end) (>= end 0) (<= end length-from))
          (err "bad integer for end index ~S" end))
        (set! end (vector-length from)))
    (when (< (- length-to at) (- end start))
      (err "not enough room in destination vector ~S" to))

    ;; do the copy
    (%claim-error 'vector-copy!
                  (%vector-copy! to at from start end))))



283 284 285
#|
<doc R7RS vector->string string->vector
 * (vector->string string)
286 287
 * (vector->string string start)
 * (vector->string string start end)
288
 * (string->vector vector)
289 290 291 292 293 294 295 296 297 298 299 300
 * (string->vector vector start)
 * (string->vector vector start end)
 *
 * The |vector->string| procedure returns a newly allocated
 * string of the objects contained in the elements of |vector|
 * between |start| and |end|. It is an error if any element of |vector|
 * between |start| and |end| is not a character.
 *
 * The |string->vector| procedure returns a newly created vector
 * initialized to the elements of |string| between |start| and |end|.
 *
 * In both procedures, order is preserved.
301
 *
Erick's avatar
Erick committed
302 303 304 305
 * @lisp
 * (string->vector "ABC")           => #(#\A #\B #\C)
 * (vector->string #(#\1 #\2 #\3))  => "123"
 * @end lisp
306 307
doc>
|#
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
(define (vector->string vect :optional (start 0) (end 0 end?))
  (unless (vector? vect)    (error "bad vector ~S" vect))
  (unless end?              (set! end (vector-length vect)))
  (%claim-error
     'vector->string
     (let loop ((res   (make-string (- end start)))
                (i     0)
                (start start))
       (if (< start end)
           (let ((c (vector-ref vect start)))
             (unless (char? c)
               (error "element at index ~S of ~S must be a character" start vect))
             (string-set! res i c)
             (loop res (+ i 1) (+ start 1)))
           res))))

(define (string->vector str :optional (start 0) (end 0 end?))
  (unless (string? str)    (error "bad string ~S" str))
  (unless end?             (set! end (string-length str)))
  (%claim-error
     'string->vector
     (let loop ((res   (make-vector (- end start)))
                (i     0)
                (start start))
       (if (< start end)
           (begin
             (vector-set! res i (string-ref str start))
             (loop res (+ i 1) (+ start 1)))
           res))))
337 338 339 340 341 342

;;;; ----------------------------------------------------------------------
;;;; 6.9 Bytevectors
;;;; ----------------------------------------------------------------------
#|
<doc R7RS make-bytevector
Erick's avatar
Erick committed
343 344
 * (make-bytevector k)
 * (make-bytevector k byte)
345
 *
Erick's avatar
Erick committed
346 347 348 349 350 351 352
 * Returns a newly allocated bytevector of k bytes. If If |byte| is given,
 * then all elements of the bytevector are initialized to |byte|, otherwise
 * the contents of each element is 0.
 * @lisp
 * (make-bytevector 2 12) => #u8(12 12)
 * (make-bytevector 3)    => #u8(0 0 0)
 * @end lisp
353 354 355
doc>
|#
(define (make-bytevector size :optional (default 0))
356
  (%claim-error 'make-bytevector
Erick's avatar
Erick committed
357
                (%make-uvector 1 size default)))
358 359 360 361 362 363 364 365 366 367 368

#|
<doc R7RS bytevector?
 * (bytevector? obj)
 *
 * Returns |!t| if |obj| is a bytevector and returns |!f| otherwise.
doc>
|#
(define (bytevector? obj)
  (%uvector? 1 obj))

Erick's avatar
Erick committed
369 370 371 372 373 374 375 376 377 378 379 380 381 382
#|
<doc R7RS bytevector
 * (bytevector byte ...)
 *
 * Returns a newly allocated bytevector containing its arguments.
 * @lisp
 * (bytevector 1 3 5 1 3 5)   => #u8(1 3 5 1 3 5)
 * (bytevector)               => #u8()
 * @end lisp
doc>
|#
(define (bytevector . lst)
  (%claim-error 'bytevector (%uvector 1 lst)))

383 384 385 386

#|
<doc R7RS bytevector-length
 * (bytevector-length bytevector)
387
 *
388 389 390 391 392 393 394
 * Returns the length of |bytevector| in bytes as an exact integer.
doc>
|#
(define (bytevector-length bv)
  (%claim-error 'bytevector-length (%uvector-length 1 bv)))


395 396 397 398 399
#|
<doc R7RS bytevector-u8-ref
 * (bytevector-u8-ref bytevector k)
 *
 * Returns the byte at index |k| of |bytevector| as an exact integer in the
400 401 402 403
 * range [0..255]. It is an error if |k| is not a valid index of |bytevector|.
 *
 * @lisp
 * (bytevector-u8-ref ’#u8(1 1 2 3 5 8 13 21) 5    => 8
404
 * @end lisp
405 406 407
doc>
|#
(define (bytevector-u8-ref bv idx)
408
  (%claim-error 'bytevector-u8-ref (%uvector-ref 1 bv idx)))
409

410

411 412
#|
<doc EXT bytevector-u8-set!
413
 * (bytevector-u8-ref bytevector k byte)
414
 *
415 416 417 418 419 420 421 422
 * Stores byte as the k th byte of bytevector. It is an error if |k|
 * is not a valid index of |bytevector|.
 *
 * @lisp
 * (let ((bv (bytevector 1 2 3 4)))
 *   (bytevector-u8-set! bv 1 3)
 *   bv)                             => #u8(1 3 3 4)
 * @end lisp
423 424 425
doc>
|#
(define (bytevector-u8-set! bv idx val)
426
  (%claim-error 'bytevector-u8-set! (%uvector-set! 1 bv idx val)))
427 428 429 430


#|
<doc R7RS bytevector-copy!
431 432 433
 * (bytevector-copy! to at from)
 * (bytevector-copy! to at from start)
 * (bytevector-copy! to at from start end)
434
 *
435 436 437 438 439 440 441
 * Copies the bytes of bytevector |from| between |start| and |end|
 * to bytevector |to|, starting at |at|. The order in which bytes
 * are copied is unspecified, except that if the source and
 * destination overlap, copying takes place as if the source is first
 * copied into a temporary bytevector and then into the destination.
 * This can be achieved without allocating storage by making sure
 * to copy in the correct direction in such circumstances.
442
 *
443 444 445 446 447 448 449 450 451 452
 * It is an error if |at| is less than zero or greater than the length
 * of |to|. It is also an error if |(- (bytevector-length to) at)| is
 * less than |(- end start)|.
 *
 * @lisp
 * (define a (bytevector 1 2 3 4 5))
 * (define b (bytevector 10 20 30 40 50))
 * (bytevector-copy! b 1 a 0 2)
 * b                                  =>  #u8(10 1 2 40 50
 * @end lisp
453 454
doc>
|#
455 456 457
(define (bytevector-copy! to at from :optional (start 0 start?) (end 0 end?))
  (define (err . l)
    (apply error 'bytevector-copy! l))
458

459 460 461 462 463 464
  (define (%bytevector-copy! to tstart from fstart fend)
    (if (> fstart tstart)
        (do ((i fstart (+ i 1))
             (j tstart (+ j 1)))
            ((>= i fend))
          (bytevector-u8-set! to j (bytevector-u8-ref from i)))
465

466 467 468 469
        (do ((i (- fend 1)                    (- i 1))
             (j (+ -1 tstart (- fend fstart)) (- j 1)))
            ((< i fstart))
          (bytevector-u8-set! to j (bytevector-u8-ref from i)))))
470

471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
  ;; body starts here
  (unless (bytevector? to)   (err "bad bytevector ~S" to))
  (unless (bytevector? from) (err "bad bytevector ~S" from))
  (let ((length-from (bytevector-length from))
        (length-to   (bytevector-length to)))
    (unless (and (integer? at) (>= at 0) (< at length-to))
      (err "bad destination index ~S" at))
    (when start?
      (unless (and (integer? start) (>= start 0) (<= start length-from))
        (err "bad integer for start index ~S" start)))
    (if end?
        (unless (and (integer? end) (>= end 0) (<= end length-from))
          (err "bad integer for end index ~S" end))
        (set! end (bytevector-length from)))
    (when (< (- length-to at) (- end start))
      (err "not enough room in destination bytevector ~S" to))
487

488 489 490
    ;; do the copy
    (%claim-error 'bytevector-copy!
                  (%bytevector-copy! to at from start end))))
491

492
;;;; ----------------------------------------------------------------------
493
;;;; 6.10 Control features
494 495 496
;;;; ----------------------------------------------------------------------

#|
Erick's avatar
Erick committed
497
<doc R7RS string-map
498 499 500 501 502 503 504 505 506 507 508
 * (string-map proc string1 string2 ...)
 *
 * The |strings| must be strings, and |proc| must be a procedure taking as
 * many arguments as there are strings and returning a single
 * value. If more than one string is given and not all strings have the
 * same length, |string-map| terminates when the shortest list runs
 * out. |String-map| applies |proc| element-wise to the elements of the
 * strings and returns a string of the results, in order. The dynamic
 * order in which proc is applied to the elements of the |strings| is
 * unspecified.
 * @lisp
Erick's avatar
Erick committed
509
 * (string-map char-downcase "AbdEgH")
510 511 512 513 514 515 516 517 518
 *          => "abdegh"
 *
 * (string-map
 *   (lambda (c)
 *     (integer->char (+ 1 (char->integer c))))
 *   "HAL")
 *          => "IBM"
 *
 * (string-map (lambda (c k)
519 520 521 522 523 524
 *            (if (eqv? k #\u)
 *                (char-upcase c)
 *                (char-downcase c)))
 *          "studlycaps"
 *          "ululululul")
 *       => "StUdLyCaPs"
Erick's avatar
Erick committed
525 526
 * @end lisp

527 528 529 530
doc>
|#
(define (string-map proc . strings)
  (let* ((strs (map (lambda (x)
531 532 533 534 535
                      (unless (string? x)
                        (error 'string-map "bad string ~S" x))
                      (string->list x))
                    strings))
         (res (apply map proc strs)))
536 537 538 539 540 541 542
    ;; Verify that every compnent of the result is a character
    (unless (every char? res)
      (error 'string-map "bad character in ~S" res))
    ;; Return result
    (list->string res)))

#|
Erick's avatar
Erick committed
543
<doc R7RS vector-map
544 545 546 547 548 549 550 551 552 553 554 555 556 557 558
 * (vector-map proc vector1 vector2 ...)
 *
 * The |vectors| must be vectors, and |proc| must be a procedure
 * taking as many arguments as there are vectors and returning a single
 * value. If more than one vector is given and not all vectors have the
 * same length, |vector-map| terminates when the shortest list runs
 * out. |Vector-map| applies |proc| element-wise to the elements of the
 * vectors and returns a vector of the results, in order. The dynamic
 * order in which proc is applied to the elements of the |vectors| is
 * unspecified.
 * @lisp
 * (vector-map cadr '#((a b) (d e) (g h)))
 *     =>  #(b e h)
 *
 * (vector-map (lambda (n) (expt n n))
559
 *          '#(1 2 3 4 5))
560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
 *     => #(1 4 27 256 3125)
 *
 * (vector-map + '#(1 2 3) '#(4 5 6))
 *     => #(5 7 9)
 *
 * (let ((count 0))
 *   (vector-map
 *     (lambda (ignored)
 *       (set! count (+ count 1))
 *       count)
 *     '#(a b)))
 *     => #(1 2) or #(2 1)
 * @end lisp
doc>
|#
(define (vector-map proc . vectors)
  (unless (every vector? vectors)
    (error 'vector-map "bad list of vectors ~S" vectors))
  (list->vector (apply map proc (map vector->list vectors))))

#|
Erick's avatar
Erick committed
581
<doc R7RS string-for-each
582 583 584 585 586 587 588 589 590 591 592 593 594
 * (string-for-each proc string1 string2 ...)
 *
 * The arguments to |string-for-each| are like the arguments to
 * |string-map|, but |string-for-each| calls |proc| for its side effects
 * rather than for its values. Unlike |string-map|, |string-for-each| is
 * guaranteed to call |proc| on the elements of the lists in order from
 * the first element(s) to the last, and the value returned by
 * |string-for-each| is unspecified. If more than one string is given and
 * not all strings have the same length, |string-for-each| terminates when
 * the shortest string runs out.
 * @lisp
 * (let ((v (list)))
 *   (string-for-each (lambda (c) (set! v (cons (char->integer c) v)))
595
 *                    "abcde")
596 597 598 599 600 601 602
 *    v)
 *        => (101 100 99 98 97)
 * @end lisp
doc>
|#
(define (string-for-each proc . strings)
  (let ((strs (map (lambda (x)
603 604 605 606
                     (unless (string? x)
                       (error 'string-for-each "bad string ~S" x))
                     (string->list x))
                   strings)))
607 608 609 610 611
    (apply map proc strs)
    (void)))


#|
Erick's avatar
Erick committed
612
<doc R7RS vector-for-each
613
 * (vector-for-each proc vector1 vector2 ...)
614 615 616 617 618 619 620 621 622 623 624 625
 *
 * The arguments to |vector-for-each| are like the arguments to
 * |vector-map|, but |vector-for-each| calls |proc| for its side effects
 * rather than for its values. Unlike |vector-map|, |vector-for-each| is
 * guaranteed to call |proc| on the elements of the lists in order from
 * the first element(s) to the last, and the value returned by
 * |vector-for-each| is unspecified. If more than one vector is given and
 * not all vectors have the same length, |vector-for-each| terminates when
 * the shortest vector runs out.
 * @lisp
 * (let ((v (make-vector 5)))
 *   (vector-for-each (lambda (i) (vector-set! v i (* i i)))
626
 *                 '#(0 1 2 3 4))
627 628 629 630 631 632 633 634 635 636
 *   v)
 *        => #(0 1 4 9 16)
 * @end lisp
doc>
|#
(define (vector-for-each proc . vectors)
  (unless (every vector? vectors)
    (error 'vector-for-each "bad list of vectors ~S" vectors))
  (apply map proc (map vector->list vectors))
  (void))
637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664

;;;; ----------------------------------------------------------------------
;;;; 6.13 Input and Output
;;;; ----------------------------------------------------------------------

;;;
;;; 6.13.1 Ports
;;;

#|
<doc R7RS call-with-port
 * (call-with-port port proc)
 *
 * The |call-with-port| procedure calls |proc| with |port| as an
 * argument. If |proc| returns, then the |port| is closed automatically
 * and the values yielded by the |proc| are returned.
 * If |proc| does not return, then the |port| must not be closed
 * automatically unless it is possible to prove that the port
 * will never again be used for a read or write operation.
 *
 * It is an error if proc does not accept one argument.
|#
(define (call-with-port port proc)
  #;(unless (port? port)
    (error 'call-with-port  "bad port ~S" port))
  #;(unless (and (procedure? proc) (memq (%procedure-arity proc) '(-2 -1 1)))
    (error 'call-with-port "bad procedure ~S" proc))
  (%claim-error 'call-with-port
665 666 667
                (let ((res (call-with-values
                               (lambda () (proc port))
                             list)))
668
                  (close-port port)
669
                  (apply values res))))
670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690


#|
<doc R7RS input-port-open? output-port-open?
 * (input-port-open? port)
 * (output-port-open? port)
 *
 * Returns #t if port is still open and capable of performing
 * input or output, respectively, and #f otherwise.
doc>
|#
(define (input-port-open? port)
  (unless (input-port? port)
    (error "bad input port ~S" port))
  (not (port-closed? port)))

(define (output-port-open? port)
  (unless (output-port? port)
    (error "bad output port ~S" port))
  (not (port-closed? port)))

691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722

#|
<doc R7RS read-string
 * (read-string k)
 * (read-string k port)
 *
 * Reads the next |k| characters, or as many as are available
 * before the end of file, from the textual input |port| into a
 * newly allocated string in left-to-right order and returns the
 * string. If no characters are available before the end of file,
 * an end-of-file object is returned.
doc>
|#
(define (read-string k :optional (port (current-input-port)))
  (%claim-error
    'read-string
    (unless (positive? k)
      (error "parameter must be a positive integer. It was: ~S" k))
    (unless (and (input-port? port) (textual-port? port))
      (error "bad textual input port ~S" port))

    (let ((buffer (make-string k)))
      (let Loop ((i 0)
                 (c (read-char port)))
        (cond
          ((eof-object? c) (if (zero? i)
                               (eof-object)
                               (substring buffer 0 i)))
          ((= i (- k 1))   (string-set! buffer i c)
                           buffer)
          (else            (string-set! buffer i c)
                           (Loop (+ i 1) (read-char port))))))))
723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786

#|
<doc R7RS read-u8
 * (read-u8)
 * (read-u8 port)
 *
 * Returns the next byte available from the binary input |port|,
 * updating the |port| to point to the following byte. If no more
 * bytes are available, an end-of-file object is returned.
 *
 * @l
 * ,(bold "Note"): This function is similar to the |read-byte|
 * function, excepted that it can be used only on  a binary port.
doc>
|#

(define (read-u8 :optional (port (current-input-port)))
  (%claim-error
    'read-u8
    (unless (binary-port? port)
      (error "bad binary port ~S" port))
    (read-byte port)))

#|
<doc R7RS peek-u8
 * (peek-u8)
 * (peek-u8 port)
 *
 * Returns the next byte available from the binary input |port|,
 * but without updating the |port| to point to the following
 * byte. If no more bytes are available, an end-of-file object
 * is returned.
 *
 * @l
 * ,(bold "Note"): This function is similar to the |peek-byte|
 * function, excepted that it can be used only on  a binary port.
doc>
|#
(define (peek-u8 :optional (port (current-input-port)))
  (%claim-error
    'peek-u8
    (unless (binary-port? port)
      (error "bad binary port ~S" port))
    (peek-byte port)))

#|
<doc R7RS u8-ready?
 * (u8-ready?)
 * (u8-ready? port)
 *
 * Returns #t if a byte is ready on the binary input |port| and
 * returns #f otherwise. If |u8-ready?| returns #t then the
 * next read-u8 operation on the given port is guaranteed
 * not to hang. If the |port| is at end of file then |u8-ready?|
 * returns #t.
doc>
|#
(define (u8-ready? :optional (port (current-input-port)))
  (%claim-error
    'u8-ready?
    (unless (binary-port? port)
      (error "bad binary port ~S" port))
    (char-ready? port)))