diff options
| author |  Peter McGoron
| 2025-04-12 12:54:35 -0400 |
|---|---|---|
| committer | Peter McGoron
| 2025-04-12 12:54:35 -0400 |
| commit | 638df69633e1a36079a9c53bf35b4f9090609bb4 (patch) | |
| tree | 062e091c1f0341898c1c89bda6673d6911a93b92 | |
| parent | trigger a manual minor garbage collection to try and smoke out stack corruption (diff) | |
test predicates on non-procedures0.9.0
| -rw-r--r-- | lowlevel.scm | 2 | ||||
| -rw-r--r-- | srfi-259.egg | 2 | ||||
| -rw-r--r-- | srfi-259.sld | 1 | ||||
| -rw-r--r-- | tests/run.scm | 8 |
4 files changed, 12 insertions, 1 deletions
diff --git a/lowlevel.scm b/lowlevel.scm index 3f22155..21bfba8 100644 --- a/lowlevel.scm +++ b/lowlevel.scm @@ -28,6 +28,8 @@ ;;; The code works by having a "signifier pair", whose car is a unique ;;; (in the sense of eqv) symbol and whose cdr is a integer map to the ;;; tag values. +;;; +;;; The code is similar to `extend-procedure`. (define unique-id ;; Generate a fixnum, which will serve as the ID for each tagged diff --git a/srfi-259.egg b/srfi-259.egg index 6cc1531..559e739 100644 --- a/srfi-259.egg +++ b/srfi-259.egg @@ -8,4 +8,4 @@ (components (extension srfi-259 (source "srfi-259.sld") (source-dependencies "lowlevel.scm") - (csc-options "-k" "-debug-info" "-R" "r7rs" "-X" "r7rs" "-O3")))) + (csc-options "-R" "r7rs" "-X" "r7rs" "-O3")))) diff --git a/srfi-259.sld b/srfi-259.sld index 20a78be..7a3dfb2 100644 --- a/srfi-259.sld +++ b/srfi-259.sld @@ -47,6 +47,7 @@ (set! predicate? (lambda (proc) (cond + ((not (procedure? proc)) #f) ((get-mapping proc) => (cut fxmapping-contains? <> id)) (else #f)))) (set! accessor diff --git a/tests/run.scm b/tests/run.scm index b35427d..bdc08c2 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -74,4 +74,12 @@ (test "get-tag-foo" 'foo (get-tag-foo tagged)) (test "get-tag-baz" 'baz (get-tag-baz tagged)))) +(test-group "predicates on other objects" + (test-assert "integers are not tagged" (not (tag-foo? 0))) + (test-assert "strings are not tagged" (not (tag-foo? "hello"))) + (test-assert "bytevectors are not tagged" (not (tag-foo? #u8(1 2 3 4)))) + (test-assert "vectors are not tagged" (not (tag-foo? #(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)))) + (test-end "SRFI 259") |