home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / stream.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  307 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: stream.scm,v 14.12 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Basic Stream Operations
  23. ;;; package: (runtime stream)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (stream-pair? stream)
  28.   (and (pair? stream)
  29.        (promise? (cdr stream))))
  30.  
  31. (define (stream-car stream)
  32.   (if (not (stream-pair? stream))
  33.       (error:wrong-type-argument stream "stream" 'STREAM-CAR))
  34.   (car stream))
  35.  
  36. (define (stream-cdr stream)
  37.   (if (not (stream-pair? stream))
  38.       (error:wrong-type-argument stream "stream" 'STREAM-CDR))
  39.   (force (cdr stream)))
  40.  
  41. (define the-empty-stream '())
  42. (define stream-null? null?)
  43. (define empty-stream? stream-null?)
  44. (define stream-first stream-car)
  45. (define stream-rest stream-cdr)
  46. (define head stream-car)
  47. (define tail stream-cdr)
  48.  
  49. (define (stream . list)
  50.   (list->stream list))
  51.  
  52. (define stream-length
  53.   (letrec
  54.       ((loop
  55.     (lambda (stream length)
  56.       (if (stream-pair? stream)
  57.           (loop (force (cdr stream)) (+ length 1))
  58.           (begin
  59.         (if (not (null? stream))
  60.             (error:illegal-stream-element stream 'STREAM-LENGTH 0))
  61.         length)))))
  62.     (lambda (stream)
  63.       (loop stream 0))))
  64.  
  65. (define (stream-ref stream index)
  66.   (let ((tail (stream-tail stream index)))
  67.     (if (not (stream-pair? tail))
  68.     (error:bad-range-argument index 'STREAM-REF))
  69.     (car tail)))
  70.  
  71. (define stream-head
  72.   (letrec
  73.       ((loop
  74.     (lambda (stream index)
  75.       (if (= 0 index)
  76.           '()
  77.           (begin
  78.         (if (not (stream-pair? stream))
  79.             (error:bad-range-argument index 'STREAM-HEAD))
  80.         (cons (car stream)
  81.               (loop (force (cdr stream)) (- index 1))))))))
  82.     (lambda (stream index)
  83.       (if (not (exact-nonnegative-integer? index))
  84.       (error:wrong-type-argument index
  85.                      "exact nonnegative integer"
  86.                      'STREAM-HEAD))
  87.       (loop stream index))))
  88.  
  89. (define stream-tail
  90.   (letrec
  91.       ((loop
  92.     (lambda (stream index)
  93.       (if (= 0 index)
  94.           stream
  95.           (begin
  96.         (if (not (stream-pair? stream))
  97.             (error:bad-range-argument index 'STREAM-TAIL))
  98.         (loop (force (cdr stream)) (- index 1)))))))
  99.     (lambda (stream index)
  100.       (if (not (exact-nonnegative-integer? index))
  101.       (error:wrong-type-argument index
  102.                      "exact nonnegative integer"
  103.                      'STREAM-TAIL))
  104.       (loop stream index))))
  105.  
  106. (define stream-map
  107.   (letrec
  108.       ((do-1
  109.     (lambda (procedure stream)
  110.       (if (stream-pair? stream)
  111.           (cons-stream (procedure (car stream))
  112.                (do-1 procedure (force (cdr stream))))
  113.           (begin
  114.         (if (not (null? stream))
  115.             (error:illegal-stream-element stream 'STREAM-MAP 1))
  116.         '()))))
  117.        (do-n
  118.     (lambda (procedure streams)
  119.       (call-with-values (lambda () (split-streams streams 'STREAM-MAP))
  120.         (lambda (cars cdrs)
  121.           (if (null? cars)
  122.           '()
  123.           (cons (apply procedure cars)
  124.             (delay (do-n procedure (map force cdrs))))))))))
  125.     (lambda (procedure stream . streams)
  126.       (if (null? streams)
  127.       ;; Kludge: accept arguments in old order.
  128.       (if (or (null? procedure) (stream-pair? procedure))
  129.           (do-1 stream procedure)
  130.           (do-1 procedure stream))
  131.       (do-n procedure (cons stream streams))))))
  132.  
  133. (define stream-for-each
  134.   (letrec
  135.       ((do-1
  136.     (lambda (procedure stream)
  137.       (cond ((stream-pair? stream)
  138.          (procedure (car stream))
  139.          (do-1 procedure (force (cdr stream))))
  140.         ((not (null? stream))
  141.          (error:illegal-stream-element stream 'STREAM-FOR-EACH 1)))))
  142.        (do-n
  143.     (lambda (procedure streams)
  144.       (call-with-values
  145.           (lambda () (split-streams streams 'STREAM-FOR-EACH))
  146.         (lambda (cars cdrs)
  147.           (if (not (null? cars))
  148.           (begin
  149.             (apply procedure cars)
  150.             (do-n procedure (map force cdrs)))))))))
  151.     (lambda (procedure stream . streams)
  152.       (if (null? streams)
  153.       (do-1 procedure stream)
  154.       (do-n procedure (cons stream streams))))))
  155.  
  156. (define (split-streams streams operator)
  157.   (let ((cars (list 'CARS))
  158.     (cdrs (list 'CDRS)))
  159.     (let loop ((streams streams) (cars-tail cars) (cdrs-tail cdrs) (n 0))
  160.       (if (null? streams)
  161.       (values (cdr cars) (cdr cdrs))
  162.       (let ((stream (car streams)))
  163.         (if (stream-pair? stream)
  164.         (let ((cars-tail* (list (car stream)))
  165.               (cdrs-tail* (list (cdr stream))))
  166.           (set-cdr! cars-tail cars-tail*)
  167.           (set-cdr! cdrs-tail cdrs-tail*)
  168.           (loop (cdr streams) cars-tail* cdrs-tail* (fix:+ n 1)))
  169.         (begin
  170.           (if (not (null? stream))
  171.               (error:illegal-stream-element stream operator n))
  172.           (values '() '()))))))))
  173.  
  174. (define stream-append
  175.   (letrec
  176.       ((outer-loop
  177.     (lambda (streams n)
  178.       (if (null? (cdr streams))
  179.           (car streams)
  180.           (inner-loop (car streams) (cdr streams) n))))
  181.        (inner-loop
  182.     (lambda (stream streams n)
  183.       (if (stream-pair? stream)
  184.           (cons-stream (car stream)
  185.                (inner-loop (force (cdr stream)) streams n))
  186.           (begin
  187.         (if (not (null? stream))
  188.             (error:illegal-stream-element stream 'STREAM-APPEND n))
  189.         (outer-loop streams (fix:+ n 1)))))))
  190.     (lambda streams
  191.       (if (null? streams)
  192.       '()
  193.       (outer-loop streams 0)))))
  194.  
  195. (define (stream-accumulate procedure initial stream)
  196.   (if (stream-pair? stream)
  197.       (procedure (car stream)
  198.          (stream-accumulate procedure initial (force (cdr stream))))
  199.       (begin
  200.     (if (not (null? stream))
  201.         (error:illegal-stream-element stream 'STREAM-ACCUMULATE 2))
  202.     initial)))
  203.  
  204. (define (stream-filter predicate stream)
  205.   (if (stream-pair? stream)
  206.       (if (predicate (car stream))
  207.       (cons-stream (car stream)
  208.                (stream-filter predicate (force (cdr stream))))
  209.       (stream-filter predicate (force (cdr stream))))
  210.       (begin
  211.     (if (not (null? stream))
  212.         (error:illegal-stream-element stream 'STREAM-FILTER 1))
  213.     '())))
  214.  
  215. (define stream-write
  216.   (letrec
  217.       ((loop
  218.     (lambda (stream leader port)
  219.       (if (stream-pair? stream)
  220.           (begin
  221.         (write-char leader port)
  222.         (write (car stream) port)
  223.         (loop (force (cdr stream)) #\space port))
  224.           (begin
  225.         (if (not (null? stream))
  226.             (error:illegal-stream-element stream 'STREAM-WRITE 0))
  227.         (write-char #\} port))))))
  228.     (lambda (stream #!optional port)
  229.       (loop stream
  230.         #\{
  231.         (if (default-object? port)
  232.         (current-output-port)
  233.         (guarantee-output-port port))))))
  234.  
  235. (define (list->stream list)
  236.   (if (pair? list)
  237.       (cons-stream (car list) (list->stream (cdr list)))
  238.       (begin
  239.     (if (not (null? list))
  240.         (error:wrong-type-argument list "list" 'LIST->STREAM))
  241.     '())))
  242.  
  243. (define (stream->list stream)
  244.   (if (stream-pair? stream)
  245.       (cons (car stream)
  246.         (stream->list (force (cdr stream))))
  247.       (begin
  248.     (if (not (null? stream))
  249.         (error:illegal-stream-element stream 'STREAM->LIST 0))
  250.     '())))
  251.  
  252. (define prime-numbers-stream)
  253.  
  254. (define (make-prime-numbers-stream)
  255.   (cons-stream
  256.    2
  257.    (letrec
  258.        ((primes
  259.      (cons-stream
  260.       (cons 3 9)
  261.       (let filter ((integer 5))
  262.         (let loop ((primes primes))
  263.           (let ((prime (car primes)))
  264.         (cond ((< integer (cdr prime))
  265.                (cons-stream (cons integer (* integer integer))
  266.                     (filter (+ integer 2))))
  267.               ((= 0 (remainder integer (car prime)))
  268.                (filter (+ integer 2)))
  269.               (else
  270.                (loop (force (cdr primes)))))))))))
  271.      (let loop ((primes primes))
  272.        (cons-stream (car (car primes))
  273.             (loop (force (cdr primes))))))))
  274.  
  275. (define (initialize-package!)
  276.   (let ((reset-primes!
  277.      (lambda ()
  278.        (set! prime-numbers-stream (make-prime-numbers-stream))
  279.        unspecific)))
  280.     (reset-primes!)
  281.     (add-secondary-gc-daemon! reset-primes!)))
  282.  
  283. (define (error:illegal-stream-element stream operator operand)
  284.   (error (make-illegal-stream-element "stream" stream operator operand)))
  285.  
  286. (define make-illegal-stream-element)
  287. (define condition-type:illegal-stream-element)
  288.  
  289. (define (initialize-conditions!)
  290.   (set! condition-type:illegal-stream-element
  291.     (make-condition-type 'ILLEGAL-STREAM-ELEMENT
  292.         condition-type:wrong-type-argument
  293.         '()
  294.       (lambda (condition port)
  295.         (write-string "The object " port)
  296.         (write (access-condition condition 'DATUM) port)
  297.         (write-string ", occurring in the " port)
  298.         (write-string (ordinal-number-string
  299.                (+ (access-condition condition 'OPERAND) 1))
  300.               port)
  301.         (write-string " argument to " port)
  302.         (write-operator (access-condition condition 'OPERATOR) port)
  303.         (write-string ", is not a stream." port))))
  304.   (set! make-illegal-stream-element
  305.     (condition-constructor condition-type:illegal-stream-element
  306.                    '(TYPE DATUM OPERATOR OPERAND)))
  307.   unspecific)