add srfi 41 implementation and update Chinese string constants
svn: r9483
This commit is contained in:
Matthew Flatt
parent
53b0ed4401
commit
7a4c379b8f
4
collects/srfi/41.ss
Normal file
4
collects/srfi/41.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
;; module loader for SRFI-40
|
||||
(module |41| mzscheme
|
||||
(require (lib "streams.ss" "srfi" "41"))
|
||||
(provide (all-from (lib "streams.ss" "srfi" "41"))))
|
||||
377
collects/srfi/41/derived.ss
Normal file
377
collects/srfi/41/derived.ss
Normal file
|
|
@ -0,0 +1,377 @@
|
|||
; Library streams/derived
|
||||
; Adapted for PLT Scheme by Jacob J. A. Koot
|
||||
; from original version of Philip L. Bewig.
|
||||
|
||||
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
|
||||
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
; this software and associated documentation files (the "Software"), to deal in the Software
|
||||
; without restriction, including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
|
||||
; whom the Software is furnished to do so, subject to the following conditions: The above
|
||||
; copyright notice and this permission notice shall be included in all copies or substantial
|
||||
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
||||
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
|
||||
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
|
||||
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#lang scheme
|
||||
|
||||
(provide define-stream list->stream port->stream stream stream->list
|
||||
stream-append stream-concat stream-constant stream-drop
|
||||
stream-drop-while stream-filter stream-fold stream-for-each stream-from
|
||||
stream-iterate stream-length stream-let stream-map stream-match _
|
||||
stream-of stream-range stream-ref stream-reverse stream-scan stream-take
|
||||
stream-take-while stream-unfold stream-unfolds stream-zip)
|
||||
|
||||
(require "primitive.ss")
|
||||
|
||||
(define-syntax define-stream
|
||||
(syntax-rules ()
|
||||
((define-stream (name . formal) body0 body1 ...)
|
||||
(define name (stream-lambda formal body0 body1 ...)))))
|
||||
|
||||
(define (list->stream objs)
|
||||
(define list->stream
|
||||
(stream-lambda (objs)
|
||||
(if (null? objs)
|
||||
stream-null
|
||||
(stream-cons (car objs) (list->stream (cdr objs))))))
|
||||
(if (not (list? objs))
|
||||
(error 'list->stream "non-list argument")
|
||||
(list->stream objs)))
|
||||
|
||||
(define (port->stream . port)
|
||||
(define port->stream
|
||||
(stream-lambda (p)
|
||||
(let ((c (read-char p)))
|
||||
(if (eof-object? c)
|
||||
stream-null
|
||||
(stream-cons c (port->stream p))))))
|
||||
(let ((p (if (null? port) (current-input-port) (car port))))
|
||||
(if (not (input-port? p))
|
||||
(error 'port->stream "non-input-port argument")
|
||||
(port->stream p))))
|
||||
|
||||
(define-syntax stream
|
||||
(syntax-rules ()
|
||||
((stream) stream-null)
|
||||
((stream x y ...) (stream-cons x (stream y ...)))))
|
||||
|
||||
(define (stream->list . args)
|
||||
(let ((n (if (= 1 (length args)) #f (car args)))
|
||||
(strm (if (= 1 (length args)) (car args) (cadr args))))
|
||||
(cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
|
||||
((and n (not (integer? n))) (error 'stream->list "non-integer count"))
|
||||
((and n (negative? n)) (error 'stream->list "negative count"))
|
||||
(else (let loop ((n (if n n -1)) (strm strm))
|
||||
(if (or (zero? n) (stream-null? strm))
|
||||
'()
|
||||
(cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
|
||||
|
||||
(define (stream-append . strms)
|
||||
(define stream-append
|
||||
(stream-lambda (strms)
|
||||
(cond ((null? (cdr strms)) (car strms))
|
||||
((stream-null? (car strms)) (stream-append (cdr strms)))
|
||||
(else (stream-cons (stream-car (car strms))
|
||||
(stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
|
||||
(cond ((null? strms) stream-null)
|
||||
((ormap (lambda (x) (not (stream? x))) strms)
|
||||
(error 'stream-append "non-stream argument"))
|
||||
(else (stream-append strms))))
|
||||
|
||||
(define (stream-concat strms)
|
||||
(define stream-concat
|
||||
(stream-lambda (strms)
|
||||
(cond ((stream-null? strms) stream-null)
|
||||
((not (stream? (stream-car strms)))
|
||||
(error 'stream-concat "non-stream object in input stream"))
|
||||
((stream-null? (stream-car strms))
|
||||
(stream-concat (stream-cdr strms)))
|
||||
(else (stream-cons
|
||||
(stream-car (stream-car strms))
|
||||
(stream-concat
|
||||
(stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
|
||||
(if (not (stream? strms))
|
||||
(error 'stream-concat "non-stream argument")
|
||||
(stream-concat strms)))
|
||||
|
||||
(define stream-constant
|
||||
(stream-lambda objs
|
||||
(cond ((null? objs) stream-null)
|
||||
((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
|
||||
(else (stream-cons (car objs)
|
||||
(apply stream-constant (append (cdr objs) (list (car objs)))))))))
|
||||
|
||||
(define (stream-drop n strm)
|
||||
(define stream-drop
|
||||
(stream-lambda (n strm)
|
||||
(if (or (zero? n) (stream-null? strm))
|
||||
strm
|
||||
(stream-drop (- n 1) (stream-cdr strm)))))
|
||||
(cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
|
||||
((negative? n) (error 'stream-drop "negative argument"))
|
||||
((not (stream? strm)) (error 'stream-drop "non-stream argument"))
|
||||
(else (stream-drop n strm))))
|
||||
|
||||
(define (stream-drop-while pred? strm)
|
||||
(define stream-drop-while
|
||||
(stream-lambda (strm)
|
||||
(if (and (stream-pair? strm) (pred? (stream-car strm)))
|
||||
(stream-drop-while (stream-cdr strm))
|
||||
strm)))
|
||||
(cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
|
||||
((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
|
||||
(else (stream-drop-while strm))))
|
||||
|
||||
(define (stream-filter pred? strm)
|
||||
(define stream-filter
|
||||
(stream-lambda (strm)
|
||||
(cond ((stream-null? strm) stream-null)
|
||||
((pred? (stream-car strm))
|
||||
(stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
|
||||
(else (stream-filter (stream-cdr strm))))))
|
||||
(cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
|
||||
((not (stream? strm)) (error 'stream-filter "non-stream argument"))
|
||||
(else (stream-filter strm))))
|
||||
|
||||
(define (stream-fold proc base strm)
|
||||
(cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
|
||||
((not (stream? strm)) (error 'stream-fold "non-stream argument"))
|
||||
(else (let loop ((base base) (strm strm))
|
||||
(if (stream-null? strm)
|
||||
base
|
||||
(loop (proc base (stream-car strm)) (stream-cdr strm)))))))
|
||||
|
||||
(define (stream-for-each proc . strms)
|
||||
(define (stream-for-each strms)
|
||||
(when (not (ormap stream-null? strms))
|
||||
(begin (apply proc (map stream-car strms))
|
||||
(stream-for-each (map stream-cdr strms)))))
|
||||
(cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
|
||||
((null? strms) (error 'stream-for-each "no stream arguments"))
|
||||
((ormap (lambda (x) (not (stream? x))) strms)
|
||||
(error 'stream-for-each "non-stream argument"))
|
||||
(else (stream-for-each strms))))
|
||||
|
||||
(define (stream-from first . step)
|
||||
(define stream-from
|
||||
(stream-lambda (first delta)
|
||||
(stream-cons first (stream-from (+ first delta) delta))))
|
||||
(let ((delta (if (null? step) 1 (car step))))
|
||||
(cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
|
||||
((not (number? delta)) (error 'stream-from "non-numeric step size"))
|
||||
(else (stream-from first delta)))))
|
||||
|
||||
(define (stream-iterate proc base)
|
||||
(define stream-iterate
|
||||
(stream-lambda (base)
|
||||
(stream-cons base (stream-iterate (proc base)))))
|
||||
(if (not (procedure? proc))
|
||||
(error 'stream-iterate "non-procedural argument")
|
||||
(stream-iterate base)))
|
||||
|
||||
(define (stream-length strm)
|
||||
(if (not (stream? strm))
|
||||
(error 'stream-length "non-stream argument")
|
||||
(let loop ((len 0) (strm strm))
|
||||
(if (stream-null? strm)
|
||||
len
|
||||
(loop (+ len 1) (stream-cdr strm))))))
|
||||
|
||||
(define-syntax stream-let
|
||||
(syntax-rules ()
|
||||
((stream-let tag ((name val) ...) body1 body2 ...)
|
||||
((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
|
||||
|
||||
(define (stream-map proc . strms)
|
||||
(define stream-map
|
||||
(stream-lambda (strms)
|
||||
(if (ormap stream-null? strms)
|
||||
stream-null
|
||||
(stream-cons (apply proc (map stream-car strms))
|
||||
(stream-map (map stream-cdr strms))))))
|
||||
(cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
|
||||
((null? strms) (error 'stream-map "no stream arguments"))
|
||||
((ormap (lambda (x) (not (stream? x))) strms)
|
||||
(error 'stream-map "non-stream argument"))
|
||||
(else (stream-map strms))))
|
||||
|
||||
(define-syntax stream-match
|
||||
(syntax-rules ()
|
||||
((stream-match strm-expr clause ...)
|
||||
(let ((strm strm-expr))
|
||||
(cond
|
||||
((not (stream? strm)) (error 'stream-match "non-stream argument"))
|
||||
((stream-match-test strm clause) => car) ...
|
||||
(else (error 'stream-match "pattern failure")))))))
|
||||
|
||||
(define-syntax stream-match-test
|
||||
(syntax-rules ()
|
||||
((stream-match-test strm (pattern fender expr))
|
||||
(stream-match-pattern strm pattern () (and fender (list expr))))
|
||||
((stream-match-test strm (pattern expr))
|
||||
(stream-match-pattern strm pattern () (list expr)))))
|
||||
|
||||
(define-syntax stream-match-pattern
|
||||
(lambda (x)
|
||||
(define (wildcard? x)
|
||||
(and (identifier? x)
|
||||
(free-identifier=? x (syntax _))))
|
||||
(syntax-case x ()
|
||||
((stream-match-pattern strm () (binding ...) body)
|
||||
(syntax (and (stream-null? strm) (let (binding ...) body))))
|
||||
((stream-match-pattern strm (w? . rest) (binding ...) body)
|
||||
(wildcard? #'w?)
|
||||
(syntax (and (stream-pair? strm)
|
||||
(let ((strm (stream-cdr strm)))
|
||||
(stream-match-pattern strm rest (binding ...) body)))))
|
||||
((stream-match-pattern strm (var . rest) (binding ...) body)
|
||||
(syntax (and (stream-pair? strm)
|
||||
(let ((temp (stream-car strm)) (strm (stream-cdr strm)))
|
||||
(stream-match-pattern strm rest ((var temp) binding ...) body)))))
|
||||
((stream-match-pattern strm w? (binding ...) body)
|
||||
(wildcard? #'w?)
|
||||
(syntax (let (binding ...) body)))
|
||||
((stream-match-pattern strm var (binding ...) body)
|
||||
(syntax (let ((var strm) binding ...) body))))))
|
||||
|
||||
(define-syntax stream-of
|
||||
(syntax-rules ()
|
||||
((_ expr rest ...)
|
||||
(stream-of-aux expr stream-null rest ...))))
|
||||
|
||||
(define-syntax stream-of-aux
|
||||
(syntax-rules (in is)
|
||||
((stream-of-aux expr base)
|
||||
(stream-cons expr base))
|
||||
((stream-of-aux expr base (var in stream) rest ...)
|
||||
(stream-let loop ((strm stream))
|
||||
(if (stream-null? strm)
|
||||
base
|
||||
(let ((var (stream-car strm)))
|
||||
(stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
|
||||
((stream-of-aux expr base (var is exp) rest ...)
|
||||
(let ((var exp)) (stream-of-aux expr base rest ...)))
|
||||
((stream-of-aux expr base pred? rest ...)
|
||||
(if pred? (stream-of-aux expr base rest ...) base))))
|
||||
|
||||
(define (stream-range first past . step)
|
||||
(define stream-range
|
||||
(stream-lambda (first past delta lt?)
|
||||
(if (lt? first past)
|
||||
(stream-cons first (stream-range (+ first delta) past delta lt?))
|
||||
stream-null)))
|
||||
(cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
|
||||
((not (number? past)) (error 'stream-range "non-numeric ending number"))
|
||||
(else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
|
||||
(if (not (number? delta))
|
||||
(error 'stream-range "non-numeric step size")
|
||||
(let ((lt? (if (< 0 delta) < >)))
|
||||
(stream-range first past delta lt?)))))))
|
||||
|
||||
(define (stream-ref strm n)
|
||||
(cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
|
||||
((not (integer? n)) (error 'stream-ref "non-integer argument"))
|
||||
((negative? n) (error 'stream-ref "negative argument"))
|
||||
(else (let loop ((strm strm) (n n))
|
||||
(cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
|
||||
((zero? n) (stream-car strm))
|
||||
(else (loop (stream-cdr strm) (- n 1))))))))
|
||||
|
||||
(define (stream-reverse strm)
|
||||
(define stream-reverse
|
||||
(stream-lambda (strm rev)
|
||||
(if (stream-null? strm)
|
||||
rev
|
||||
(stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
|
||||
(if (not (stream? strm))
|
||||
(error 'stream-reverse "non-stream argument")
|
||||
(stream-reverse strm stream-null)))
|
||||
|
||||
(define (stream-scan proc base strm)
|
||||
(define stream-scan
|
||||
(stream-lambda (base strm)
|
||||
(if (stream-null? strm)
|
||||
(stream base)
|
||||
(stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
|
||||
(cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
|
||||
((not (stream? strm)) (error 'stream-scan "non-stream argument"))
|
||||
(else (stream-scan base strm))))
|
||||
|
||||
(define (stream-take n strm)
|
||||
(define stream-take
|
||||
(stream-lambda (n strm)
|
||||
(if (or (stream-null? strm) (zero? n))
|
||||
stream-null
|
||||
(stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
|
||||
(cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
|
||||
((not (integer? n)) (error 'stream-take "non-integer argument"))
|
||||
((negative? n) (error 'stream-take "negative argument"))
|
||||
(else (stream-take n strm))))
|
||||
|
||||
(define (stream-take-while pred? strm)
|
||||
(define stream-take-while
|
||||
(stream-lambda (strm)
|
||||
(cond ((stream-null? strm) stream-null)
|
||||
((pred? (stream-car strm))
|
||||
(stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
|
||||
(else stream-null))))
|
||||
(cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
|
||||
((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
|
||||
(else (stream-take-while strm))))
|
||||
|
||||
(define (stream-unfold mapper pred? generator base)
|
||||
(define stream-unfold
|
||||
(stream-lambda (base)
|
||||
(if (pred? base)
|
||||
(stream-cons (mapper base) (stream-unfold (generator base)))
|
||||
stream-null)))
|
||||
(cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
|
||||
((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
|
||||
((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
|
||||
(else (stream-unfold base))))
|
||||
|
||||
(define (stream-unfolds gen seed)
|
||||
(define (len-values gen seed)
|
||||
(call-with-values
|
||||
(lambda () (gen seed))
|
||||
(lambda vs (- (length vs) 1))))
|
||||
(define unfold-result-stream
|
||||
(stream-lambda (gen seed)
|
||||
(call-with-values
|
||||
(lambda () (gen seed))
|
||||
(lambda (next . results)
|
||||
(stream-cons results (unfold-result-stream gen next))))))
|
||||
(define result-stream->output-stream
|
||||
(stream-lambda (result-stream i)
|
||||
(let ((result (list-ref (stream-car result-stream) (- i 1))))
|
||||
(cond ((pair? result)
|
||||
(stream-cons
|
||||
(car result)
|
||||
(result-stream->output-stream (stream-cdr result-stream) i)))
|
||||
((not result)
|
||||
(result-stream->output-stream (stream-cdr result-stream) i))
|
||||
((null? result) stream-null)
|
||||
(else (error 'stream-unfolds "can't happen"))))))
|
||||
(define (result-stream->output-streams result-stream)
|
||||
(let loop ((i (len-values gen seed)) (outputs '()))
|
||||
(if (zero? i)
|
||||
(apply values outputs)
|
||||
(loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
|
||||
(if (not (procedure? gen))
|
||||
(error 'stream-unfolds "non-procedural argument")
|
||||
(result-stream->output-streams (unfold-result-stream gen seed))))
|
||||
|
||||
(define (stream-zip . strms)
|
||||
(define stream-zip
|
||||
(stream-lambda (strms)
|
||||
(if (ormap stream-null? strms)
|
||||
stream-null
|
||||
(stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
|
||||
(cond ((null? strms) (error 'stream-zip "no stream arguments"))
|
||||
((ormap (lambda (x) (not (stream? x))) strms)
|
||||
(error 'stream-zip "non-stream argument"))
|
||||
(else (stream-zip strms))))
|
||||
83
collects/srfi/41/primitive.ss
Normal file
83
collects/srfi/41/primitive.ss
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
; Library streams/primitive
|
||||
; Adapted for PLT Scheme by Jacob J. A. Koot
|
||||
; from original version of Philip L. Bewig.
|
||||
|
||||
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
|
||||
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
; this software and associated documentation files (the "Software"), to deal in the Software
|
||||
; without restriction, including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
|
||||
; whom the Software is furnished to do so, subject to the following conditions: The above
|
||||
; copyright notice and this permission notice shall be included in all copies or substantial
|
||||
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
||||
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
|
||||
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
|
||||
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#lang scheme
|
||||
|
||||
(provide stream-null stream-cons stream? stream-null? stream-pair?
|
||||
stream-car stream-cdr stream-lambda)
|
||||
|
||||
(define-struct stream (promise) #:mutable)
|
||||
|
||||
(define-syntax stream-lazy
|
||||
(syntax-rules ()
|
||||
((stream-lazy expr)
|
||||
(make-stream
|
||||
(mcons 'lazy (lambda () expr))))))
|
||||
|
||||
(define (stream-eager expr)
|
||||
(make-stream
|
||||
(mcons 'eager expr)))
|
||||
|
||||
(define-syntax stream-delay
|
||||
(syntax-rules ()
|
||||
((stream-delay expr)
|
||||
(stream-lazy (stream-eager expr)))))
|
||||
|
||||
(define (stream-force promise)
|
||||
(let ((content (stream-promise promise)))
|
||||
(case (mcar content)
|
||||
((eager) (mcdr content))
|
||||
((lazy) (let* ((promise* ((mcdr content)))
|
||||
(content (stream-promise promise)))
|
||||
(when (not (eqv? (mcar content) 'eager))
|
||||
(begin (set-mcar! content (mcar (stream-promise promise*)))
|
||||
(set-mcdr! content (mcdr (stream-promise promise*)))
|
||||
(set-stream-promise! promise* content)))
|
||||
(stream-force promise))))))
|
||||
|
||||
(define stream-null (stream-delay (cons 'stream 'null)))
|
||||
|
||||
(define-struct stream-pare (kar kdr))
|
||||
|
||||
(define (stream-pair? obj)
|
||||
(and (stream? obj) (stream-pare? (stream-force obj))))
|
||||
|
||||
(define (stream-null? obj)
|
||||
(and (stream? obj)
|
||||
(eqv? (stream-force obj)
|
||||
(stream-force stream-null))))
|
||||
|
||||
(define-syntax stream-cons
|
||||
(syntax-rules ()
|
||||
((stream-cons obj strm)
|
||||
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
|
||||
|
||||
(define (stream-car strm)
|
||||
(cond ((not (stream? strm)) (error 'stream-car "non-stream"))
|
||||
((stream-null? strm) (error 'stream-car "null stream"))
|
||||
(else (stream-force (stream-pare-kar (stream-force strm))))))
|
||||
|
||||
(define (stream-cdr strm)
|
||||
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
|
||||
((stream-null? strm) (error 'stream-cdr "null stream"))
|
||||
(else (stream-pare-kdr (stream-force strm)))))
|
||||
|
||||
(define-syntax stream-lambda
|
||||
(syntax-rules ()
|
||||
((stream-lambda formals body0 body1 ...)
|
||||
(lambda formals (stream-lazy (let () body0 body1 ...))))))
|
||||
29
collects/srfi/41/streams.ss
Normal file
29
collects/srfi/41/streams.ss
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
; Library streams
|
||||
; Adapted for PLT Scheme by Jacob J. A. Koot
|
||||
; from original version of Philip L. Bewig.
|
||||
|
||||
; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
|
||||
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
; this software and associated documentation files (the "Software"), to deal in the Software
|
||||
; without restriction, including without limitation the rights to use, copy, modify, merge,
|
||||
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
|
||||
; whom the Software is furnished to do so, subject to the following conditions: The above
|
||||
; copyright notice and this permission notice shall be included in all copies or substantial
|
||||
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
||||
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
||||
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
|
||||
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
|
||||
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
#lang scheme
|
||||
|
||||
(provide stream-null stream-cons stream? stream-null? stream-pair? stream-car
|
||||
stream-cdr stream-lambda define-stream list->stream port->stream stream
|
||||
stream->list stream-append stream-concat stream-constant stream-drop
|
||||
stream-drop-while stream-filter stream-fold stream-for-each stream-from
|
||||
stream-iterate stream-length stream-let stream-map stream-match _
|
||||
stream-of stream-range stream-ref stream-reverse stream-scan stream-take
|
||||
stream-take-while stream-unfold stream-unfolds stream-zip)
|
||||
|
||||
(require "primitive.ss" "derived.ss")
|
||||
|
|
@ -700,6 +700,51 @@ This SRFI's syntax is part of PLT Scheme's default reader and printer.
|
|||
(stream-filter #f "stream-filter")
|
||||
)]
|
||||
|
||||
Superceded by @schememodname[srfi/41].
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@srfi[41]{Streams}
|
||||
|
||||
@redirect[41 '(
|
||||
(stream-null #f "stream-null")
|
||||
(stream-cons #t "stream-cons")
|
||||
(stream? #f "stream?")
|
||||
(stream-null? #f "stream-null?")
|
||||
(stream-pair? #f "stream-pair?")
|
||||
(stream-car #f "stream-car")
|
||||
(stream-cdr #f "stream-cdr")
|
||||
(stream-lambda #t "stream-lambda")
|
||||
(define-stream #t "define-stream")
|
||||
(list->stream #f "list-to-stream")
|
||||
(port->stream #f "port-to-stream")
|
||||
(stream #t "stream")
|
||||
(stream->list #f "stream-to-list")
|
||||
(stream-append #f "stream-append")
|
||||
(stream-concat #f "stream-concat")
|
||||
(stream-constant #f "stream-constant")
|
||||
(stream-drop #f "stream-drop")
|
||||
(stream-drop-while #f "stream-drop-while")
|
||||
(stream-filter #f "stream-filter")
|
||||
(stream-fold #f "stream-fold")
|
||||
(stream-for-each #f "stream-for-each")
|
||||
(stream-from #f "stream-from")
|
||||
(stream-iterate #f "stream-iterate")
|
||||
(stream-length #f "stream-length")
|
||||
(stream-let #t "stream-let")
|
||||
(stream-map #f "stream-map")
|
||||
(stream-match #t "stream-match")
|
||||
(stream-of #t "stream-of")
|
||||
(stream-range #f "stream-range")
|
||||
(stream-ref #f "stream-ref")
|
||||
(stream-reverse #f "stream-reverse")
|
||||
(stream-scan #f "stream-scan")
|
||||
(stream-take #f "stream-take")
|
||||
(stream-take-while #f "stream-take-while")
|
||||
(stream-unfold #f "stream-unfold")
|
||||
(stream-zip #f "stream-zip")
|
||||
)]
|
||||
|
||||
@; ----------------------------------------
|
||||
|
||||
@srfi[42]{Eager Comprehensions}
|
||||
|
|
|
|||
|
|
@ -118,6 +118,8 @@
|
|||
(cs-status-expanding-expression "语法检查：扩展表达式")
|
||||
(cs-mouse-over-import "绑定~s由~s导入")
|
||||
|
||||
(cs-view-docs "察看~a的文档")
|
||||
|
||||
(cs-lexical-variable "词汇变量")
|
||||
(cs-imported-variable "导入变量")
|
||||
|
||||
|
|
@ -156,6 +158,7 @@
|
|||
|
||||
(save "保存")
|
||||
(close-anyway "强制关闭")
|
||||
(dont-save "不保存")
|
||||
(clear-anyway "强制清空")
|
||||
|
||||
;; menu item title
|
||||
|
|
@ -917,7 +920,7 @@
|
|||
(how-to-design-programs "程序设计方法/How to Design Programs") ;; should agree with MIT Press on this one...
|
||||
(pretty-big-scheme "相当大（包括MrEd和HtDP高级）")
|
||||
(pretty-big-scheme-one-line-summary "增加了HtDP(程序设计方法)语言的语法和函数")
|
||||
(r5rs-language-name "R5RS")
|
||||
(r5rs-lang-name "R5RS")
|
||||
(r5rs-one-line-summary "Scheme语言标准第5修改稿")
|
||||
(expander "Expander")
|
||||
(expander-one-line-summary "展开表达式，而不是求值")
|
||||
|
|
@ -1038,8 +1041,8 @@
|
|||
;; This is used in this context: "PLT Scheme vNNN <<<*>>> http://download..."
|
||||
(version:now-available-at "可以从这里获取：")
|
||||
|
||||
;; special menu
|
||||
(special-menu "特殊符号(&P)")
|
||||
;; insert menu
|
||||
(insert-menu "插入(&I)")
|
||||
|
||||
;; large semi colon letters
|
||||
(insert-large-letters... "插入大字...")
|
||||
|
|
|
|||
|
|
@ -117,6 +117,8 @@
|
|||
(cs-status-expanding-expression "語法檢查：擴展表達式")
|
||||
(cs-mouse-over-import "綁定~s由~s導入")
|
||||
|
||||
(cs-view-docs "察看~a的文檔")
|
||||
|
||||
(cs-lexical-variable "詞彙變量")
|
||||
(cs-imported-variable "導入變量")
|
||||
|
||||
|
|
@ -155,6 +157,7 @@
|
|||
|
||||
(save "保存")
|
||||
(close-anyway "強制關閉")
|
||||
(dont-save "不保存")
|
||||
(clear-anyway "強制清空")
|
||||
|
||||
;; menu item title
|
||||
|
|
@ -786,7 +789,7 @@
|
|||
;; The "-explanatory-label" variants are the labels used for the radio buttons in
|
||||
;; the "Create Executable..." dialog for the "(module ...)" language.
|
||||
(launcher "啟動程序")
|
||||
(launcher-explanatory-label "啟動程序（僅在本機運行，運行原始碼）")
|
||||
(launcher-explanatory-label "啟動程序（僅在本機運行，運行源代碼）")
|
||||
(stand-alone "獨立程序")
|
||||
(stand-alone-explanatory-label "獨立程序（僅在本機運行，運行編譯代碼）")
|
||||
(distribution "可發佈程序")
|
||||
|
|
@ -916,7 +919,7 @@
|
|||
(how-to-design-programs "程序設計方法/How to Design Programs") ;; should agree with MIT Press on this one...
|
||||
(pretty-big-scheme "相當大（包括MrEd和HtDP高級）")
|
||||
(pretty-big-scheme-one-line-summary "增加了HtDP(程序設計方法)語言的語法和函數")
|
||||
(r5rs-language-name "R5RS")
|
||||
(r5rs-lang-name "R5RS")
|
||||
(r5rs-one-line-summary "Scheme語言標準第5修改稿")
|
||||
(expander "Expander")
|
||||
(expander-one-line-summary "展開表達式，而不是求值")
|
||||
|
|
@ -1037,8 +1040,8 @@
|
|||
;; This is used in this context: "PLT Scheme vNNN <<<*>>> http://download..."
|
||||
(version:now-available-at "可以從這裡獲取：")
|
||||
|
||||
;; special menu
|
||||
(special-menu "特殊符號(&P)")
|
||||
;; insert menu
|
||||
(insert-menu "插入(&I)")
|
||||
|
||||
;; large semi colon letters
|
||||
(insert-large-letters... "插入大字...")
|
||||
|
|
|
|||
2895
doc/srfi-std/srfi-41.html
Normal file
2895
doc/srfi-std/srfi-41.html
Normal file
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user