diff options
Diffstat (limited to 'collect.scm')
| -rw-r--r-- | collect.scm | 105 |
1 files changed, 51 insertions, 54 deletions
diff --git a/collect.scm b/collect.scm index 35a333d..05bc2cf 100644 --- a/collect.scm +++ b/collect.scm @@ -2,49 +2,55 @@ ; COPYRIGHT (c) Kenneth Dickey 1992 ; ; This software may be used for any purpose whatever -; without warrantee of any kind. +; without warranty of any kind. ; AUTHOR Ken Dickey ; DATE 1992 September 1 ; LAST UPDATED 1992 September 2 ; NOTES Expository (optimizations & checks elided). ; Requires YASOS (Yet Another Scheme Object System). +(require 'object) (require 'yasos) -(define-operation (collect:collection? obj) +(define collect:size size) +(define collect:print print) + +;@ +(define-operation (collection? obj) ;; default (cond ((or (list? obj) (vector? obj) (string? obj)) #t) (else #f) ) ) - -(define (collect:empty? collection) (zero? (yasos:size collection))) - -(define-operation (collect:gen-elts <collection>) ;; return element generator +;@ +(define (empty? collection) (zero? (collect:size collection))) +;@ +(define-operation (gen-elts <collection>) ;; return element generator ;; default behavior (cond ;; see utilities, below, for generators ((vector? <collection>) (collect:vector-gen-elts <collection>)) ((list? <collection>) (collect:list-gen-elts <collection>)) ((string? <collection>) (collect:string-gen-elts <collection>)) (else - (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f))) + (slib:error 'gen-elts 'operation-not-supported + (collect:print <collection> #f))) ) ) - -(define-operation (collect:gen-keys collection) +;@ +(define-operation (gen-keys collection) (if (or (vector? collection) (list? collection) (string? collection)) - (let ( (max+1 (yasos:size collection)) (index 0) ) + (let ( (max+1 (collect:size collection)) (index 0) ) (lambda () (cond ((< index max+1) (set! index (collect:add1 index)) (collect:sub1 index)) - (else (slib:error "no more keys in generator")) + (else (slib:error 'no-more 'keys 'in 'generator)) ) ) ) - (slib:error "Operation not handled: GEN-KEYS " collection) + (slib:error 'gen-keys 'operation-not-handled collection) ) ) - -(define (collect:do-elts <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (counter 0) ) @@ -56,9 +62,9 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:do-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (do-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) ) (let loop ( (counter 0) ) @@ -70,11 +76,11 @@ (else 'unspecific) ; done ) ) ) ) - -(define (collect:map-elts <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-elts <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -85,11 +91,11 @@ (else vec) ; done ) ) ) ) - -(define (collect:map-keys <proc> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (map-keys <proc> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-keys <collections>)) - (vec (make-vector (yasos:size (car <collections>)))) + (vec (make-vector (collect:size (car <collections>)))) ) (let loop ( (index 0) ) (cond @@ -100,18 +106,18 @@ (else vec) ; done ) ) ) ) - -(define-operation (collect:for-each-key <collection> <proc>) +;@ +(define-operation (for-each-key <collection> <proc>) ;; default (collect:do-keys <proc> <collection>) ;; talk about lazy! ) - -(define-operation (collect:for-each-elt <collection> <proc>) +;@ +(define-operation (for-each-elt <collection> <proc>) (collect:do-elts <proc> <collection>) ) - -(define (collect:reduce <proc> <seed> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;@ +(define (reduce <proc> <seed> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -127,9 +133,9 @@ -;; pred true for every elt? -(define (collect:every? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for every elt? +(define (every? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -143,9 +149,9 @@ ) ) ) ) -;; pred true for any elt? -(define (collect:any? <pred?> . <collections>) - (let ( (max+1 (yasos:size (car <collections>))) +;;@ pred true for any elt? +(define (any? <pred?> . <collections>) + (let ( (max+1 (collect:size (car <collections>))) (generators (map collect:gen-elts <collections>)) ) (let loop ( (count 0) ) @@ -191,7 +197,7 @@ (define (collect:list-gen-elts <list>) (lambda () (if (null? <list>) - (slib:error "No more list elements in generator") + (slib:error 'no-more 'list-elements 'in 'generator) (let ( (elt (car <list>)) ) (set! <list> (cdr <list>)) elt)) @@ -200,7 +206,7 @@ ;; generator for vector elements (define (collect:make-vec-gen-elts <accessor>) (lambda (vec) - (let ( (max+1 (yasos:size vec)) + (let ( (max+1 (collect:size vec)) (index 0) ) (lambda () @@ -219,18 +225,9 @@ ;;; exports: -(define collection? collect:collection?) -(define empty? collect:empty?) -(define gen-keys collect:gen-keys) -(define gen-elts collect:gen-elts) -(define do-elts collect:do-elts) -(define do-keys collect:do-keys) -(define map-elts collect:map-elts) -(define map-keys collect:map-keys) -(define for-each-key collect:for-each-key) -(define for-each-elt collect:for-each-elt) -(define reduce collect:reduce) ; reduce is also in comlist.scm -(define every? collect:every?) -(define any? collect:any?) +(define collect:gen-keys gen-keys) +(define collect:gen-elts gen-elts) +(define collect:do-elts do-elts) +(define collect:do-keys do-keys) ;; --- E O F "collect.oo" --- ;; |