Changeset 37040 in project
- Timestamp:
- 01/15/19 12:49:21 (5 weeks ago)
- Location:
- release/5/simple-exceptions
- Files:
-
- 6 edited
- 1 copied
-
tags/1.2 (copied) (copied from release/5/simple-exceptions/trunk)
-
tags/1.2/simple-exceptions.egg (modified) (1 diff)
-
tags/1.2/simple-exceptions.scm (modified) (6 diffs)
-
tags/1.2/tests/run.scm (modified) (1 diff)
-
trunk/simple-exceptions.egg (modified) (1 diff)
-
trunk/simple-exceptions.scm (modified) (6 diffs)
-
trunk/tests/run.scm (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
release/5/simple-exceptions/tags/1.2/simple-exceptions.egg
r36637 r37040 4 4 (test-dependencies simple-tests) 5 5 (author "Juergen Lorenz") 6 (version "1. 1")6 (version "1.2") 7 7 (components (extension simple-exceptions))) -
release/5/simple-exceptions/tags/1.2/simple-exceptions.scm
r36637 r37040 3 3 ju (at) jugilo (dot) de 4 4 5 Copyright (c) 2014-201 8, Juergen Lorenz5 Copyright (c) 2014-2019, Juergen Lorenz 6 6 All rights reserved. 7 7 … … 116 116 name)))) 117 117 118 ;;; (<<< loc )119 ;;; --------- 118 ;;; (<<< loc [arg-name]) 119 ;;; -------------------- 120 120 ;;; returns a localized argument checker (<< arg . preds) 121 ;;; at location loc 122 (define (<<< loc )121 ;;; at location loc with name arg-name 122 (define (<<< loc . arg-name) 123 123 (case-lambda 124 124 (() '()) … … 126 126 (if (null? preds) 127 127 arg 128 (let ((arg-name (if (symbol? (car preds)) (car preds) #f)) 128 (let ((name (cond 129 ((symbol? (car preds)) (car preds)) ; deprecated 130 ((not (null? arg-name)) (car arg-name)) 131 (else #f))) 129 132 (preds (if (symbol? (car preds)) (cdr preds) preds))) 130 133 (let loop ((preds preds)) … … 135 138 (loop (cdr preds))) 136 139 (else 137 (if arg-name138 (raise (argument-exception loc arg-name arg (car preds)))139 (raise (argument-exception loc arg (car 140 preds))))))))))))140 (if name 141 (raise (argument-exception loc name arg (car preds))) 142 (raise (argument-exception loc arg (car preds))) 143 ))))))))) 141 144 142 145 ;;; (<< arg [arg-name] arg? ...) 143 146 ;;; ---------------------------- 144 147 ;;; pass in a checked argument in an and fashion 145 ;(define (<< arg . preds)146 ; (apply (<<< '<<) arg preds))147 148 (define << 148 149 (case-lambda 149 150 (() '()) 150 151 ((arg . preds) 151 (apply (<<< '<<) arg preds)))) 152 153 ;;; (>>> loc) 154 ;;; --------- 152 (if (null? preds) 153 arg 154 (if (symbol? (car preds)) ; deprecated 155 (apply (<<< '<< (car preds)) arg (cdr preds)) 156 (apply (<<< '<<) arg preds)))))) 157 158 ;;; (>>> loc [result-name]) 159 ;;; ----------------------- 155 160 ;;; returns a localized result checker (>> result . preds) 156 161 ;;; at location loc 157 (define (>>> loc) 158 (lambda (result . preds) 159 (if (null? preds) 160 result 161 (let ((result-name (if (symbol? (car preds)) (car preds) #f)) 162 (preds (if (symbol? (car preds)) (cdr preds) preds))) 163 (let loop ((preds preds)) 164 (cond 165 ((null? preds) 166 result) 167 (((car preds) result) 168 (loop (cdr preds))) 169 (else 170 (if result-name 171 (raise (result-exception loc result-name result (car preds))) 172 (raise (result-exception loc 'result result (car preds))))))))))) 162 (define (>>> loc . result-name) 163 (case-lambda 164 (() '()) 165 ((result . preds) 166 (if (null? preds) 167 result 168 (let ((name (cond 169 ((symbol? (car preds)) (car preds)) ; deprecated 170 ((not (null? result-name)) (car result-name)) 171 (else #f))) 172 (preds (if (symbol? (car preds)) (cdr preds) preds))) 173 (let loop ((preds preds)) 174 (cond 175 ((null? preds) 176 result) 177 (((car preds) result) 178 (loop (cdr preds))) 179 (else 180 (if name 181 (raise (result-exception loc name result (car preds))) 182 (raise (result-exception loc result (car preds))) 183 ))))))))) 173 184 174 185 ;;; (>> result [result-name] result? ...) 175 186 ;;; ------------------------------------- 176 187 ;;; pass out a checked result in an and fashion 177 (define (>> result . preds) 178 (apply (>>> '>>) result preds)) 188 (define >> 189 (case-lambda 190 (() '()) 191 ((result . preds) 192 (if (null? preds) 193 result 194 (if (symbol? (car preds)) ; deprecated 195 (apply (>>> '>> (car preds)) result (cdr preds)) 196 (apply (>>> '>>) result preds)))))) 179 197 180 198 ;;; (guard (exn cond-clause . cond-clauses) xpr . xprs) … … 348 366 (<<< 349 367 procedure: 350 (<<< loc )368 (<<< loc [arg-name]) 351 369 "returns a localized precondition test" 352 370 "(<< arg [arg-name] arg? ...)" 353 "at location loc ")371 "at location loc with name arg-name") 354 372 (<< 355 373 procedure: … … 360 378 (>>> 361 379 procedure: 362 (>>> loc )380 (>>> loc [result-name]) 363 381 "returns a localized postcondition test" 364 382 "(>> result [result-name] result? ...)" 365 "at location loc ")383 "at location loc with name result-name") 366 384 (>> 367 385 procedure: -
release/5/simple-exceptions/tags/1.2/tests/run.scm
r36637 r37040 29 29 (= (<< 5) 5) 30 30 (= (<< 5 integer? odd? (named-lambda (5<= x) (<= 5 x))) 5) 31 (= ((<<< 'foo 'x) 5 integer? odd?) 5) 32 (= ((<<< 'foo) 5 integer? odd?) 5) 33 (= ((>>> 'foo 'x) 5 integer? odd?) 5) 34 (= ((>>> 'foo) 5 integer? odd?) 5) 31 35 (not (condition-case 32 36 (>> 5 integer? even?) -
release/5/simple-exceptions/trunk/simple-exceptions.egg
r36637 r37040 4 4 (test-dependencies simple-tests) 5 5 (author "Juergen Lorenz") 6 (version "1. 1")6 (version "1.2") 7 7 (components (extension simple-exceptions))) -
release/5/simple-exceptions/trunk/simple-exceptions.scm
r36637 r37040 3 3 ju (at) jugilo (dot) de 4 4 5 Copyright (c) 2014-201 8, Juergen Lorenz5 Copyright (c) 2014-2019, Juergen Lorenz 6 6 All rights reserved. 7 7 … … 116 116 name)))) 117 117 118 ;;; (<<< loc )119 ;;; --------- 118 ;;; (<<< loc [arg-name]) 119 ;;; -------------------- 120 120 ;;; returns a localized argument checker (<< arg . preds) 121 ;;; at location loc 122 (define (<<< loc )121 ;;; at location loc with name arg-name 122 (define (<<< loc . arg-name) 123 123 (case-lambda 124 124 (() '()) … … 126 126 (if (null? preds) 127 127 arg 128 (let ((arg-name (if (symbol? (car preds)) (car preds) #f)) 128 (let ((name (cond 129 ((symbol? (car preds)) (car preds)) ; deprecated 130 ((not (null? arg-name)) (car arg-name)) 131 (else #f))) 129 132 (preds (if (symbol? (car preds)) (cdr preds) preds))) 130 133 (let loop ((preds preds)) … … 135 138 (loop (cdr preds))) 136 139 (else 137 (if arg-name138 (raise (argument-exception loc arg-name arg (car preds)))139 (raise (argument-exception loc arg (car 140 preds))))))))))))140 (if name 141 (raise (argument-exception loc name arg (car preds))) 142 (raise (argument-exception loc arg (car preds))) 143 ))))))))) 141 144 142 145 ;;; (<< arg [arg-name] arg? ...) 143 146 ;;; ---------------------------- 144 147 ;;; pass in a checked argument in an and fashion 145 ;(define (<< arg . preds)146 ; (apply (<<< '<<) arg preds))147 148 (define << 148 149 (case-lambda 149 150 (() '()) 150 151 ((arg . preds) 151 (apply (<<< '<<) arg preds)))) 152 153 ;;; (>>> loc) 154 ;;; --------- 152 (if (null? preds) 153 arg 154 (if (symbol? (car preds)) ; deprecated 155 (apply (<<< '<< (car preds)) arg (cdr preds)) 156 (apply (<<< '<<) arg preds)))))) 157 158 ;;; (>>> loc [result-name]) 159 ;;; ----------------------- 155 160 ;;; returns a localized result checker (>> result . preds) 156 161 ;;; at location loc 157 (define (>>> loc) 158 (lambda (result . preds) 159 (if (null? preds) 160 result 161 (let ((result-name (if (symbol? (car preds)) (car preds) #f)) 162 (preds (if (symbol? (car preds)) (cdr preds) preds))) 163 (let loop ((preds preds)) 164 (cond 165 ((null? preds) 166 result) 167 (((car preds) result) 168 (loop (cdr preds))) 169 (else 170 (if result-name 171 (raise (result-exception loc result-name result (car preds))) 172 (raise (result-exception loc 'result result (car preds))))))))))) 162 (define (>>> loc . result-name) 163 (case-lambda 164 (() '()) 165 ((result . preds) 166 (if (null? preds) 167 result 168 (let ((name (cond 169 ((symbol? (car preds)) (car preds)) ; deprecated 170 ((not (null? result-name)) (car result-name)) 171 (else #f))) 172 (preds (if (symbol? (car preds)) (cdr preds) preds))) 173 (let loop ((preds preds)) 174 (cond 175 ((null? preds) 176 result) 177 (((car preds) result) 178 (loop (cdr preds))) 179 (else 180 (if name 181 (raise (result-exception loc name result (car preds))) 182 (raise (result-exception loc result (car preds))) 183 ))))))))) 173 184 174 185 ;;; (>> result [result-name] result? ...) 175 186 ;;; ------------------------------------- 176 187 ;;; pass out a checked result in an and fashion 177 (define (>> result . preds) 178 (apply (>>> '>>) result preds)) 188 (define >> 189 (case-lambda 190 (() '()) 191 ((result . preds) 192 (if (null? preds) 193 result 194 (if (symbol? (car preds)) ; deprecated 195 (apply (>>> '>> (car preds)) result (cdr preds)) 196 (apply (>>> '>>) result preds)))))) 179 197 180 198 ;;; (guard (exn cond-clause . cond-clauses) xpr . xprs) … … 348 366 (<<< 349 367 procedure: 350 (<<< loc )368 (<<< loc [arg-name]) 351 369 "returns a localized precondition test" 352 370 "(<< arg [arg-name] arg? ...)" 353 "at location loc ")371 "at location loc with name arg-name") 354 372 (<< 355 373 procedure: … … 360 378 (>>> 361 379 procedure: 362 (>>> loc )380 (>>> loc [result-name]) 363 381 "returns a localized postcondition test" 364 382 "(>> result [result-name] result? ...)" 365 "at location loc ")383 "at location loc with name result-name") 366 384 (>> 367 385 procedure: -
release/5/simple-exceptions/trunk/tests/run.scm
r36637 r37040 29 29 (= (<< 5) 5) 30 30 (= (<< 5 integer? odd? (named-lambda (5<= x) (<= 5 x))) 5) 31 (= ((<<< 'foo 'x) 5 integer? odd?) 5) 32 (= ((<<< 'foo) 5 integer? odd?) 5) 33 (= ((>>> 'foo 'x) 5 integer? odd?) 5) 34 (= ((>>> 'foo) 5 integer? odd?) 5) 31 35 (not (condition-case 32 36 (>> 5 integer? even?)
Note: See TracChangeset
for help on using the changeset viewer.
