diff options
| author |  Peter McGoron
| 2025-04-13 16:03:35 -0400 |
|---|---|---|
| committer | Peter McGoron
| 2025-04-13 16:03:35 -0400 |
| commit | 7277f4420d933b9710b645d61a8139e8e06c7102 (patch) | |
| tree | ae291b0ea13cf3e9272745104f59ca889345fc9f | |
| parent | add chicken release-info (diff) | |
use more specific exceptions0.9.1
Diffstat (limited to '')
| -rw-r--r-- | lowlevel.scm | 11 | ||||
| -rw-r--r-- | srfi-259.egg | 2 | ||||
| -rw-r--r-- | srfi-259.sld | 54 | ||||
| -rw-r--r-- | tests/run.scm | 26 |
4 files changed, 67 insertions, 26 deletions
diff --git a/lowlevel.scm b/lowlevel.scm index 21bfba8..e6bb9c5 100644 --- a/lowlevel.scm +++ b/lowlevel.scm @@ -102,6 +102,10 @@ C_return(closure); ;; does not exist. This relies on an undocumented internal function, ;; although it could be implemented with documented functions. (cond + ((not (procedure? proc)) (abort + (make-property-condition 'type + 'message + "not a procedure"))) ((##sys#lambda-decoration proc decoration-is-tag?) => cdr) (else #f))) @@ -113,18 +117,13 @@ C_return(closure); ;; Return a new closure object that is tagged, has all of its previous ;; tags except that `key` maps to `value`. (cond - ((not (procedure? proc)) (raise - (make-property-condition '(srfi-259 assertion-violation) - 'message - "not a procedure" - 'arguments - (list proc key value)))) ((get-mapping proc) => (lambda (oldmap) (set-signifier-pair proc unique-symbol (make-signifier (fxmapping-set oldmap key value))))) + ;; get-mapping will test if `proc` is a procedure (else (create/signifier-pair proc (make-signifier (fxmapping key value)))))) diff --git a/srfi-259.egg b/srfi-259.egg index 559e739..278ef6f 100644 --- a/srfi-259.egg +++ b/srfi-259.egg @@ -1,5 +1,5 @@ ((author "Peter McGoron") - (version "0.9.0") + (version "0.9.1") (synopsis "Tagged procedures with type safety") (category data) (license "MIT") diff --git a/srfi-259.sld b/srfi-259.sld index 7a3dfb2..50f0e3e 100644 --- a/srfi-259.sld +++ b/srfi-259.sld @@ -31,6 +31,7 @@ (export define-procedure-tag) (include "lowlevel.scm") (begin + (define is-type? (condition-predicate 'type)) (define-syntax define-procedure-tag (syntax-rules () ((define-procedure-tag constructor predicate? accessor) @@ -43,7 +44,18 @@ (let ((id (unique-id))) (set! constructor (lambda (tag proc) - (set-tagged-mapping proc id tag))) + (handle-exceptions E (abort + (make-composite-condition + (make-property-condition + 'exn + 'location + (quote accessor) + 'arguments + (list proc) + 'message + "not a procedure") + E)) + (set-tagged-mapping proc id tag)))) (set! predicate? (lambda (proc) (cond @@ -52,15 +64,31 @@ (else #f)))) (set! accessor (lambda (proc) - (let ((map (get-mapping proc)) - (raise-error (lambda () - (raise - (make-property-condition - '(srfi-259 assertion-violation) - 'message - "procedure does not contain id" - 'arguments - (list proc id)))))) - (if map - (fxmapping-ref map id raise-error) - (raise-error))))))))))))
\ No newline at end of file + (define map + (handle-exceptions E (abort + (make-composite-condition + (make-property-condition + 'exn + 'location + (quote accessor) + 'arguments + (list proc) + 'message + "not a procedure") + E)) + (get-mapping proc))) + (define (raise-error) + (abort + (make-composite-condition + (make-property-condition 'exn + 'location + (quote accessor) + 'arguments + (list proc) + 'message + "tag was not found") + (make-property-condition 'assertion + 'tag)))) + (if map + (fxmapping-ref map id raise-error) + (raise-error)))))))))))
\ No newline at end of file diff --git a/tests/run.scm b/tests/run.scm index bdc08c2..a6a9f29 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -22,7 +22,7 @@ | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |# -(import r7rs test (chicken gc) (srfi 259)) +(import r7rs test (chicken condition) (chicken gc) (srfi 259)) (test-begin "SRFI 259") @@ -40,10 +40,11 @@ (test "tagged procedure is callable" 110 (tagged 10)) (test "var has changed" 110 var) (test-assert "not tag-baz?" (not (tag-baz? tagged))) - (test-assert "get-tag-baz raises an exception" - (handle-exceptions exn #t - (get-tag-baz tagged) - #f)) + (test "get-tag-baz raises an exception" + 'assertion + (condition-case (begin (get-tag-baz tagged) 'success) + ((exn assertion) 'assertion) + (exn () 'error))) (test-group "tagged again" (let ((tagged-again (tag-foo 'quux tagged))) (test-assert "tagging again retains tag-foo?" (tag-foo? tagged-again)) @@ -74,12 +75,25 @@ (test "get-tag-foo" 'foo (get-tag-foo tagged)) (test "get-tag-baz" 'baz (get-tag-baz tagged)))) +(define-syntax raises-type-error + (syntax-rules () + ((raises-type-error name expr) + (test name + 'type + (condition-case (begin expr 'success) + ((exn type) 'type) + (var () (display (condition->list var)) 'error)))))) + (test-group "predicates on other objects" (test-assert "integers are not tagged" (not (tag-foo? 0))) + (raises-type-error "integers are not tagged" (tag-foo 'data 0)) (test-assert "strings are not tagged" (not (tag-foo? "hello"))) + (raises-type-error "strings are not tagged" (tag-foo 'data "hello")) (test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4)))) + (raises-type-error "bytevectors are not tagged" (tag-foo 'data #u8(1 2 3 4))) (test-assert "vectors are not tagged" (not (tag-foo? #(call/cc)))) + (raises-type-error "vectors are not tagged" (tag-foo 'data #(call/cc))) (test-assert "lists are not tagged" (not (tag-foo? '(1 2 3 4)))) - (test-assert "non-tagged procedures are not tagged" (not (tag-foo? call/cc)))) + (raises-type-error "lists are not tagged" (tag-foo 'data '(1 2 3 4)))) (test-end "SRFI 259") |