Changeset 38868 in project
- Timestamp:
- 08/21/20 18:11:59 (5 months ago)
- Location:
- release/5/callable-sequences
- Files:
-
- 3 edited
- 4 copied
Legend:
- Unmodified
- Added
- Removed
-
release/5/callable-sequences/tags/1.1/callable-sequences.egg
r38851 r38868 3 3 ((synopsis "sequential- and random-access sequences as procedures") 4 4 (category data) 5 (version "1. 0.0")5 (version "1.1") 6 6 (license "BSD") 7 7 (test-dependencies simple-tests) -
release/5/callable-sequences/tags/1.1/callable-sequences.scm
r38851 r38868 4 4 make-ras-callable 5 5 make-callable 6 make-callable* 6 7 callable-sas? 7 8 callable-ras? … … 154 155 cdr 155 156 null?))) 157 (cons pair? 158 (lambda (seq) (make-sas-callable seq 159 cons 160 car 161 cdr 162 atom?))) 156 163 (cons vector? 157 164 (lambda (seq) (make-ras-callable seq … … 167 174 string-length))) 168 175 (cons any? 169 (lambda (seq) (make-sas-callable seq 170 cons 171 car 172 cdr 173 atom?))) 176 (lambda (seq) (error 'make-callable 177 "not a sequence" 178 seq))) 174 179 )) 175 180 (db standard-db) … … 180 185 db) 181 186 ((seq) 182 (let loop ((db db)) 183 (if ((caar db) seq) 184 ((cdar db) seq) 185 (loop (cdr db))))) 186 ((seq? seq-maker?) 187 ;; add new sequence type before trailing catch all pair 188 (set! db 189 (let recur ((db db)) 190 (if (null? (cdr db)) 191 (list (cons seq? seq-maker?) (car db)) 192 (cons (car db) (recur (cdr db)))))) 193 db) 187 (make-callable seq #f)) ; not recursive 188 ((x y) 189 (cond 190 ((boolean? y) 191 (let ((seq x) (recursive? y)) 192 (if recursive? 193 (let* ((sequence? 194 (lambda (seq) 195 (let ((tests (map car (cdr (reverse db))))) 196 (if (memv #t (map (lambda (fn) (fn seq)) 197 tests)) 198 #t #f)))) 199 (cseq (make-callable seq)) 200 (len (callable-length cseq))) 201 ;(print (map sequence? '(() #() (a . b) "" #f))) 202 (make-callable 203 (let recur ((i 0)) 204 (cond 205 ((= i len) 206 (callable-data (cseq i #f))) 207 ((sequence? (cseq i)) 208 (cons (make-callable (cseq i) #t) (recur (+ i 1)))) 209 ((pair? (cseq i)) 210 (cons (make-callable (cseq i) #t) (recur (+ i 1)))) 211 (else 212 (cons (cseq i) (recur (+ i 1)))))))) 213 (let loop ((db db)) 214 (if ((caar db) seq) 215 ((cdar db) seq) 216 (loop (cdr db))))))) 217 ((and (procedure? x) (procedure? y)) 218 (let ((seq? x) (seq-maker y)) 219 ;; add new predicate-maker-pair as the next to last item 220 (set! db 221 (let recur ((db db)) 222 (if (null? (cdr db)) 223 (list (cons seq? seq-maker) (car db)) 224 (cons (car db) (recur (cdr db)))))) 225 db)) 226 (else (error 'make-callable 227 "type mismatch" x y)))) 194 228 ))) 195 229 230 (define (make-callable* seq) 231 (make-callable seq #t)) 196 232 197 233 (define (callable? xpr) … … 242 278 (print " and the third inserts a new item to the local") 243 279 (print " database in next to last position")) 280 ((make-callable*) 281 (print " procdure:") 282 (print " (make-callable* seq)") 283 (print " recursive version of (make-callable seq")) 244 284 ((callable-sas?) 245 285 (print " procedure:") … … 271 311 ) ; module 272 312 273 ;(import callable-sequences simple-tests) 313 (import callable-sequences simple-tests) 314 ;(define nil (make-callable '())) 274 315 ;(define vec (make-callable #(0 1 2 3 4 5))) 275 316 ;(define str (make-callable "012345")) 276 317 ;(define lst (make-callable '(0 1 2 3 4 5))) 277 318 ;(define pair (make-callable '(0 1 2 3 4 5 . 6))) 278 ;(make-callable boolean? identity) 319 ;(ppp (make-callable) 320 ; (make-callable boolean? identity) 321 ; ) 322 (define ls* (make-callable* '(a (b c)))) 323 (define pl* (make-callable* '(a (b . c)))) 324 (define lv* (make-callable* '(a #(b c)))) 325 (define vp* (make-callable* (vector 'a '(b . c)))) 326 (define vs* (make-callable* (vector 'a "bc"))) 327 (ppp (ls* 0) 328 ((ls* 1) 1) 329 (((ls* 1) 2 #f)) 330 ((pl* 1) 0) 331 (((pl* 1) 1 #f)) 332 ((lv* 1) 1) 333 ((vp* 1) 0) 334 (((vp* 1) 1 #f)) 335 ((vs* 1) 0) 336 ((vs* 1) 1) 337 (((vs* 1) 2 #f)) 338 ) -
release/5/callable-sequences/tags/1.1/tests/run.scm
r38851 r38868 147 147 ;(callables?) 148 148 149 (check-all CALLABLES (callables?)) 149 (define-checks (recursives? verbose? 150 pl* 151 (make-callable* '(a (b . c))) 152 ls* 153 (make-callable* '(a (b c))) 154 lv* 155 (make-callable* '(a #(b c))) 156 vp* 157 (make-callable* (vector 'a '(b . c))) 158 vs* 159 (make-callable* (vector 'a "bc")) 160 lv** 161 (make-callable* '(a (b #(c d) e) f))) 162 (ls* 0) 163 'a 164 ((ls* 1) 1) 165 'c 166 (((ls* 1) 2 #f)) 167 '() 168 ((pl* 1) 0) 169 'b 170 (((pl* 1) 1 #f)) 171 'c 172 ((lv* 1) 1) 173 'c 174 ((vp* 1) 0) 175 'b 176 (((vp* 1) 1 #f)) 177 'c 178 ((vs* 1) 0) 179 #\b 180 ((vs* 1) 1) 181 #\c 182 (((vs* 1) 2 #f)) 183 "" 184 (lv** 0) 185 'a 186 ((lv** 1) 0) 187 'b 188 (((lv** 1) 1) 0) 189 'c 190 (((lv** 1) 1) 1) 191 'd 192 (lv** 2) 193 'f 194 ((lv** 1) 2) 195 'e 196 ) 197 ;(recursives?) 198 199 (check-all CALLABLES (callables?) (recursives?)) 200 -
release/5/callable-sequences/trunk/callable-sequences.egg
r38851 r38868 3 3 ((synopsis "sequential- and random-access sequences as procedures") 4 4 (category data) 5 (version "1. 0.0")5 (version "1.1") 6 6 (license "BSD") 7 7 (test-dependencies simple-tests) -
release/5/callable-sequences/trunk/callable-sequences.scm
r38851 r38868 4 4 make-ras-callable 5 5 make-callable 6 make-callable* 6 7 callable-sas? 7 8 callable-ras? … … 154 155 cdr 155 156 null?))) 157 (cons pair? 158 (lambda (seq) (make-sas-callable seq 159 cons 160 car 161 cdr 162 atom?))) 156 163 (cons vector? 157 164 (lambda (seq) (make-ras-callable seq … … 167 174 string-length))) 168 175 (cons any? 169 (lambda (seq) (make-sas-callable seq 170 cons 171 car 172 cdr 173 atom?))) 176 (lambda (seq) (error 'make-callable 177 "not a sequence" 178 seq))) 174 179 )) 175 180 (db standard-db) … … 180 185 db) 181 186 ((seq) 182 (let loop ((db db)) 183 (if ((caar db) seq) 184 ((cdar db) seq) 185 (loop (cdr db))))) 186 ((seq? seq-maker?) 187 ;; add new sequence type before trailing catch all pair 188 (set! db 189 (let recur ((db db)) 190 (if (null? (cdr db)) 191 (list (cons seq? seq-maker?) (car db)) 192 (cons (car db) (recur (cdr db)))))) 193 db) 187 (make-callable seq #f)) ; not recursive 188 ((x y) 189 (cond 190 ((boolean? y) 191 (let ((seq x) (recursive? y)) 192 (if recursive? 193 (let* ((sequence? 194 (lambda (seq) 195 (let ((tests (map car (cdr (reverse db))))) 196 (if (memv #t (map (lambda (fn) (fn seq)) 197 tests)) 198 #t #f)))) 199 (cseq (make-callable seq)) 200 (len (callable-length cseq))) 201 ;(print (map sequence? '(() #() (a . b) "" #f))) 202 (make-callable 203 (let recur ((i 0)) 204 (cond 205 ((= i len) 206 (callable-data (cseq i #f))) 207 ((sequence? (cseq i)) 208 (cons (make-callable (cseq i) #t) (recur (+ i 1)))) 209 ((pair? (cseq i)) 210 (cons (make-callable (cseq i) #t) (recur (+ i 1)))) 211 (else 212 (cons (cseq i) (recur (+ i 1)))))))) 213 (let loop ((db db)) 214 (if ((caar db) seq) 215 ((cdar db) seq) 216 (loop (cdr db))))))) 217 ((and (procedure? x) (procedure? y)) 218 (let ((seq? x) (seq-maker y)) 219 ;; add new predicate-maker-pair as the next to last item 220 (set! db 221 (let recur ((db db)) 222 (if (null? (cdr db)) 223 (list (cons seq? seq-maker) (car db)) 224 (cons (car db) (recur (cdr db)))))) 225 db)) 226 (else (error 'make-callable 227 "type mismatch" x y)))) 194 228 ))) 195 229 230 (define (make-callable* seq) 231 (make-callable seq #t)) 196 232 197 233 (define (callable? xpr) … … 242 278 (print " and the third inserts a new item to the local") 243 279 (print " database in next to last position")) 280 ((make-callable*) 281 (print " procdure:") 282 (print " (make-callable* seq)") 283 (print " recursive version of (make-callable seq")) 244 284 ((callable-sas?) 245 285 (print " procedure:") … … 271 311 ) ; module 272 312 273 ;(import callable-sequences simple-tests) 313 (import callable-sequences simple-tests) 314 ;(define nil (make-callable '())) 274 315 ;(define vec (make-callable #(0 1 2 3 4 5))) 275 316 ;(define str (make-callable "012345")) 276 317 ;(define lst (make-callable '(0 1 2 3 4 5))) 277 318 ;(define pair (make-callable '(0 1 2 3 4 5 . 6))) 278 ;(make-callable boolean? identity) 319 ;(ppp (make-callable) 320 ; (make-callable boolean? identity) 321 ; ) 322 (define ls* (make-callable* '(a (b c)))) 323 (define pl* (make-callable* '(a (b . c)))) 324 (define lv* (make-callable* '(a #(b c)))) 325 (define vp* (make-callable* (vector 'a '(b . c)))) 326 (define vs* (make-callable* (vector 'a "bc"))) 327 (ppp (ls* 0) 328 ((ls* 1) 1) 329 (((ls* 1) 2 #f)) 330 ((pl* 1) 0) 331 (((pl* 1) 1 #f)) 332 ((lv* 1) 1) 333 ((vp* 1) 0) 334 (((vp* 1) 1 #f)) 335 ((vs* 1) 0) 336 ((vs* 1) 1) 337 (((vs* 1) 2 #f)) 338 ) -
release/5/callable-sequences/trunk/tests/run.scm
r38851 r38868 147 147 ;(callables?) 148 148 149 (check-all CALLABLES (callables?)) 149 (define-checks (recursives? verbose? 150 pl* 151 (make-callable* '(a (b . c))) 152 ls* 153 (make-callable* '(a (b c))) 154 lv* 155 (make-callable* '(a #(b c))) 156 vp* 157 (make-callable* (vector 'a '(b . c))) 158 vs* 159 (make-callable* (vector 'a "bc")) 160 lv** 161 (make-callable* '(a (b #(c d) e) f))) 162 (ls* 0) 163 'a 164 ((ls* 1) 1) 165 'c 166 (((ls* 1) 2 #f)) 167 '() 168 ((pl* 1) 0) 169 'b 170 (((pl* 1) 1 #f)) 171 'c 172 ((lv* 1) 1) 173 'c 174 ((vp* 1) 0) 175 'b 176 (((vp* 1) 1 #f)) 177 'c 178 ((vs* 1) 0) 179 #\b 180 ((vs* 1) 1) 181 #\c 182 (((vs* 1) 2 #f)) 183 "" 184 (lv** 0) 185 'a 186 ((lv** 1) 0) 187 'b 188 (((lv** 1) 1) 0) 189 'c 190 (((lv** 1) 1) 1) 191 'd 192 (lv** 2) 193 'f 194 ((lv** 1) 2) 195 'e 196 ) 197 ;(recursives?) 198 199 (check-all CALLABLES (callables?) (recursives?)) 200
Note: See TracChangeset
for help on using the changeset viewer.