X-Loop: help-debbugs@HIDDEN
Subject: bug#72645: [PATCH] srfi: Add SRFI-253 support
Resent-From: Artyom Bologov <mail@HIDDEN>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
Resent-CC: bug-guile@HIDDEN
Resent-Date: Fri, 16 Aug 2024 00:43:01 +0000
Resent-Message-ID: <handler.72645.B.172376895927857 <at> debbugs.gnu.org>
Resent-Sender: help-debbugs@HIDDEN
X-GNU-PR-Message: report 72645
X-GNU-PR-Package: guile
X-GNU-PR-Keywords: patch
To: 72645 <at> debbugs.gnu.org
X-Debbugs-Original-To: bug-guile@HIDDEN
Received: via spool by submit <at> debbugs.gnu.org id=B.172376895927857
(code B ref -1); Fri, 16 Aug 2024 00:43:01 +0000
Received: (at submit) by debbugs.gnu.org; 16 Aug 2024 00:42:39 +0000
Received: from localhost ([127.0.0.1]:49970 helo=debbugs.gnu.org)
by debbugs.gnu.org with esmtp (Exim 4.84_2)
(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
id 1sel38-0007F9-8R
for submit <at> debbugs.gnu.org; Thu, 15 Aug 2024 20:42:39 -0400
Received: from lists.gnu.org ([209.51.188.17]:55020)
by debbugs.gnu.org with esmtp (Exim 4.84_2)
(envelope-from <mail@HIDDEN>) id 1sel34-0007Ez-Vb
for submit <at> debbugs.gnu.org; Thu, 15 Aug 2024 20:42:37 -0400
Received: from eggs.gnu.org ([2001:470:142:3::10])
by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
(Exim 4.90_1) (envelope-from <mail@HIDDEN>) id 1sel2T-0005XB-Rn
for bug-guile@HIDDEN; Thu, 15 Aug 2024 20:41:57 -0400
Received: from layka.disroot.org ([178.21.23.139])
by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128)
(Exim 4.90_1) (envelope-from <mail@HIDDEN>) id 1sel1f-0004HH-GU
for bug-guile@HIDDEN; Thu, 15 Aug 2024 20:41:57 -0400
Received: from localhost (localhost [127.0.0.1])
by disroot.org (Postfix) with ESMTP id 2994240FF6;
Fri, 16 Aug 2024 02:40:45 +0200 (CEST)
X-Virus-Scanned: SPAM Filter at disroot.org
Received: from layka.disroot.org ([127.0.0.1])
by localhost (disroot.org [127.0.0.1]) (amavisd-new, port 10024)
with ESMTP id kVvSDkOJVnXX; Fri, 16 Aug 2024 02:40:41 +0200 (CEST)
From: Artyom Bologov <mail@HIDDEN>
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=aartaka.me; s=mail;
t=1723768841; bh=jtZd+mKT4hI+GaSLa+B8apVbJINvopf+zIcMCp8uK28=;
h=From:To:Subject:Date;
b=CYPOis7bSuldCVKD91Qu7egFWLDujaghWgrA8XyPnEFnfFkzTiYD3jwjYN1AfqTly
VaOcPtIzxI/hjLm4aiFaIuXBnB9/fmD7mYxbzIRj1oGY6hwo7fNV+2SOlWhTeaB0ae
vYz6a6TcDNqcim9kUAAwvDZY742x37oxJsB3tTlul5HMojQKhwVUvogFsR3lqpx+Rg
Da5/Gh9Pr4vX3GCtBWq8JXW3NHVeIf41Bzcl0Kp00J1Xr+9Ihh0rD27mB44h3shIek
V2JIT3CyiYRw8bKJAPHXKor2mLcoQVijOujw/Sl/do+PNx1qwBmhquo+WR8mnin+KW
SodKMiAaW7hgw==
Date: Fri, 16 Aug 2024 04:40:29 +0400
Message-ID: <877cchti4i.fsf@HIDDEN>
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="=-=-="
Received-SPF: none client-ip=178.21.23.139; envelope-from=mail@HIDDEN;
helo=layka.disroot.org
X-Spam_score_int: -20
X-Spam_score: -2.1
X-Spam_bar: --
X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, SPF_HELO_NONE=0.001,
SPF_NONE=0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-Spam-Score: -2.3 (--)
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>,
<mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>,
<mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -3.3 (---)
--=-=-=
Content-Type: text/plain
Hi y'all,
This patch adds support for a recent draft SRFI number 253
https://srfi.schemers.org/srfi-253/ (authored by me)
I'm pretty sure I messed up a lot of things convention-wise, so feel
free to edit and point out if something looks off. In particular:
- There's no copyright notice in the new files, because I wasn't sure
whether I should include any, and, if so, who to attribute copyright
to. I'm fine with any GPL license if you ask me.
- I've added more than one @cindex terms to the manual section. Is that
okay? They all are mostly relevant.
An expertise of someone familiar with types and optimization in Guile
won't hurt either, because I'm using GOOPS for type checking, which
likely causes a huge performance overhead. I'm sure there are faster and
stricter ways to check/enforce types. SCM_IS_A_P something? Is my assume
macro (what about adding support for SRFI-145, by the way?) going to
help type inference engine/optimizer or is it too noisy?
--=-=-=
Content-Type: text/x-patch
Content-Disposition: attachment;
filename=0001-srfi-Add-SRFI-253-support.patch
Content-Description: Add SRFI-253 patch
From e1e05e8062e757a0cb802c01f05bb6fa4e1828ec Mon Sep 17 00:00:00 2001
From: Artyom Bologov <mail@HIDDEN>
Date: Fri, 16 Aug 2024 04:27:01 +0400
Subject: [PATCH] srfi: Add SRFI-253 support
* AUTHORS: Add Artyom Bologov.
* am/bootstrap.am: Mention srfi-253 file.
* doc/ref/srfi-modules.texi(SRFI-253): Document SRFI support.
* module/srfi/srfi-253.scm: New file.
* test-suite/Makefile.am: Mention srfi-253.test.
* test-suite/tests/srfi-253.test: New file.
---
AUTHORS | 8 ++
am/bootstrap.am | 1 +
doc/ref/srfi-modules.texi | 50 ++++++++
module/srfi/srfi-253.scm | 211 +++++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-253.test | 141 ++++++++++++++++++++++
6 files changed, 412 insertions(+)
create mode 100644 module/srfi/srfi-253.scm
create mode 100644 test-suite/tests/srfi-253.test
diff --git a/AUTHORS b/AUTHORS
index d756a74ce..9dd9c9c1e 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -370,3 +370,11 @@ John W. Eaton, based on code from AT&T Bell Laboratories and Bellcore:
Gregory Marton:
In the subdirectory test-suite/tests, changes to:
hash.test
+
+Artyom Bologov
+In the subdirectory test-suite/tests, wrote:
+ srfi-253.test
+In the subdirectory srfi, wrote:
+ srfi-253.scm
+In the subdirectory doc, changes to:
+ srfi-modules.texi
\ No newline at end of file
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 9e5fca0db..24e237206 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -351,6 +351,7 @@ SOURCES = \
srfi/srfi-171.scm \
srfi/srfi-171/gnu.scm \
srfi/srfi-171/meta.scm \
+ srfi/srfi-253.scm \
\
statprof.scm \
\
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 02da3e2f2..7faade48d 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -66,6 +66,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-111:: Boxes.
* SRFI-119:: Wisp: simpler indentation-sensitive Scheme.
* SRFI-171:: Transducers
+* SRFI-253:: Data (Type-)Checking
@end menu
@@ -6179,6 +6180,55 @@ The generator version of list-reduce. It reduces over @code{gen} until
it returns the EOF object
@end deffn
+
+@node SRFI-253
+@subsection SRFI-253 Data (Type-)Checking
+@cindex SRFI-253
+@cindex type checking validation
+
+SRFI-253 defines a set of primitives checking the provided data for
+conformance with predicates/types. Guile implementation uses GOOPS class
+checking where appropriate, falling back to predicate checks if no type
+is recognized.
+
+@deffn {library syntax} check-arg predicate value who . rest
+Checks whether the @var{value} conforms to the @var{predicate}. If
+@var{predicate} returns @code{#f} when called on @var{value}, signals an
+@code{assertion-violation} with @var{who} and @var{rest} as irritants.
+@end deffn
+
+@deffn {library syntax} values-checked (predicates @dots{}) values @dots{}
+Checks @var{values} with @var{predicates} (the number of values and
+predicates should match) and returns them as multiple values. If any of
+the @var{predicates} returned @code{#f}, signals an
+@code{assertion-violation}. Supports multiple values.
+@end deffn
+
+@deffn {library syntax} let-checked ((name predicate [value]) @dots{}) body @dots{}
+Ensures that, for the duration of the @var{body}, every @var{name} abides by the respective @var{predicate}.
+Supports lists as @var{name} and @var{predicate}, allowing for multiple checked values.
+Binds symbols in the order of appearance, with all the defined bindings available to the bindings following them.
+@end deffn
+
+@deffn {library syntax} lambda-checked (args @dots{}) body @dots{}
+A regular lambda, but with any argument (except the rest argument)
+optionally having the form @code{name} or the form @code{(name
+predicate)} Arguments of the latter form will be checked by the
+respective @code{predicate}.
+@end deffn
+
+@deffn {library syntax} case-lambda-checked ((args @dots{}) body @dots{}) @dots{}
+Same as @code{case-lambda}, but with any argument taking a form of
+@code{(name predicate)} to be checked.
+@end deffn
+
+@deffn {library syntax} define-checked (name args @dots{}) body @dots{}
+@deffn {library syntax} define-checked name predicate value
+Defines a procedure or variable checked by the given predicates.
+For procedures, effectively equal to @code{define}+@code{lambda-checked}:
+@end deffn
+@end deffn
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/module/srfi/srfi-253.scm b/module/srfi/srfi-253.scm
new file mode 100644
index 000000000..5b59b09c7
--- /dev/null
+++ b/module/srfi/srfi-253.scm
@@ -0,0 +1,211 @@
+(define-module (srfi srfi-253)
+ #:export-syntax (check-arg
+ values-checked
+ let-checked
+ lambda-checked
+ case-lambda-checked
+ define-checked)
+ #:use-module (srfi srfi-8)
+ #:use-module (rnrs base)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm vm)
+ #:use-module (oop goops)
+ #:use-module (system foreign))
+
+(cond-expand-provide (current-module) '(srfi-253))
+
+(define-syntax assume
+ (syntax-rules ()
+ ((_ expr who . rest)
+ (or expr
+ (assertion-violation who . rest)))))
+
+(define-syntax check-arg
+ (syntax-rules (boolean?
+ char? list? pair? null? string? symbol? vector? pointer?
+ hash-table? fluid? frame? bytevector? array? bitvector? number?
+ complex? number? real? integer? exact-integer? rational?
+ keyword? procedure? port? input-port? output-port?
+
+ <boolean> <char> <list> <pair> <null> <string> <symbol>
+ <vector> <foreign> <hashtable> <fluid> <frame> <bytevector>
+ <array> <bitvector> <number> <complex> <real> <integer>
+ <keyword> <procedure> <port> <input-port> <output-port>)
+ ((_ pred val)
+ (check-arg pred val 'check-arg))
+ ((_ char? val who . rest)
+ (assume (is-a? val <char>) who "Wrong type argument" <char> val . rest))
+ ((_ list? val who . rest)
+ (assume (is-a? val <list>) who "Wrong type argument" <list> val . rest))
+ ((_ pair? val who . rest)
+ (assume (is-a? val <pair>) who "Wrong type argument" <pair> val . rest))
+ ((_ null? val who . rest)
+ (assume (is-a? val <null>) who "Wrong type argument" <null> val . rest))
+ ((_ string? val who . rest)
+ (assume (is-a? val <string>) who "Wrong type argument" <string> val . rest))
+ ((_ symbol? val who . rest)
+ (assume (is-a? val <symbol>) who "Wrong type argument" <symbol> val . rest))
+ ((_ vector? val who . rest)
+ (assume (is-a? val <vector>) who "Wrong type argument" <vector> val . rest))
+ ((_ pointer? val who . rest)
+ (assume (is-a? val <foreign>) who "Wrong type argument" <foreign> val . rest))
+ ((_ hash-table? val who . rest)
+ (assume (is-a? val <hashtable>) who "Wrong type argument" <hashtable> val . rest))
+ ((_ fluid? val who . rest)
+ (assume (is-a? val <fluid>) who "Wrong type argument" <fluid> val . rest))
+ ((_ frame? val who . rest)
+ (assume (is-a? val <frame>) who "Wrong type argument" <frame> val . rest))
+ ((_ bytevector? val who . rest)
+ (assume (is-a? val <bytevector>) who "Wrong type argument" <bytevector> val . rest))
+ ((_ array? val who . rest)
+ (assume (is-a? val <array>) who "Wrong type argument" <array> val . rest))
+ ((_ bitvector? val who . rest)
+ (assume (is-a? val <bitvector>) who "Wrong type argument" <bitvector> val . rest))
+ ((_ number? val who . rest)
+ (assume (is-a? val <number>) who "Wrong type argument" <number> val . rest))
+ ((_ complex? val who . rest)
+ (assume (is-a? val <complex>) who "Wrong type argument" <complex> val . rest))
+ ((_ real? val who . rest)
+ (assume (is-a? val <real>) who "Wrong type argument" <real> val . rest))
+ ((_ integer? val who . rest)
+ (assume (is-a? val <integer>) who "Wrong type argument" <integer> val . rest))
+ ((_ exact-integer? val who . rest)
+ (assume (is-a? val <integer>) who "Wrong type argument" <integer> val . rest))
+ ((_ keyword? val who . rest)
+ (assume (is-a? val <keyword>) who "Wrong type argument" <keyword> val . rest))
+ ((_ procedure? val who . rest)
+ (assume (is-a? val <procedure>) who "Wrong type argument" <procedure> val . rest))
+ ((_ port? val who . rest)
+ (assume (is-a? val <port>) who "Wrong type argument" <port> val . rest))
+ ((_ input-port? val who . rest)
+ (assume (is-a? val <input-port>) who "Wrong type argument" <input-port> val . rest))
+ ((_ output-port? val who . rest)
+ (assume (is-a? val <output-port>) who "Wrong type argument" <output-port> val . rest))
+ ((_ pred val who . rest)
+ (assume (pred val) who "check mismatch" . rest))))
+
+(define-syntax values-checked
+ (syntax-rules ()
+ ((_ (predicate) value)
+ (let ((v value))
+ (check-arg predicate v 'values-checked)
+ v))
+ ((_ (predicate ...) value ...)
+ (values (values-checked (predicate) value) ...))))
+
+(define-syntax let-checked
+ (syntax-rules ()
+ ((_ () body ...)
+ (begin body ...))
+ ((_ ((name pred) bindings ...) body ...)
+ (let ((name (values-checked (pred) name)))
+ (let-checked
+ (bindings ...)
+ body ...)))
+ ((_ (((name ...) (pred ...) form) bindings ...) body ...)
+ (receive (name ...)
+ form
+ (let ((name (values-checked (pred) name))
+ ...)
+ (let-checked
+ (bindings ...)
+ body ...))))
+ ((_ ((name pred val) bindings ...) body ...)
+ (let ((name (values-checked (pred) val)))
+ (let-checked
+ (bindings ...)
+ body ...)))))
+
+(define-syntax %lambda-checked
+ (syntax-rules ()
+ ((_ name (body ...) args (checks ...))
+ (lambda args
+ checks ...
+ body ...))
+ ((_ name body (args ...) (checks ...) (arg pred) . rest)
+ (%lambda-checked
+ name body
+ (args ... arg) (checks ... (check-arg pred arg 'name)) . rest))
+ ((_ name body (args ...) (checks ...) arg . rest)
+ (%lambda-checked
+ name body
+ (args ... arg) (checks ...) . rest))
+ ((_ name body (args ...) (checks ...) . last)
+ (%lambda-checked
+ name body
+ (args ... . last) (checks ...)))))
+
+(define-syntax lambda-checked
+ (syntax-rules ()
+ ((_ () body ...)
+ (lambda () body ...))
+ ((_ (arg . args) body ...)
+ (%lambda-checked lambda-checked (body ...) () () arg . args))
+ ;; Case of arg->list lambda, no-op.
+ ((_ arg body ...)
+ (lambda arg body ...))))
+
+(define-syntax %case-lambda-checked
+ (syntax-rules ()
+ ((_ (clauses-so-far ...)
+ ()
+ args-so-far (checks-so-far ...) (body ...))
+ (case-lambda
+ clauses-so-far ...
+ (args-so-far
+ checks-so-far ...
+ body ...)))
+ ((_ (clauses-so-far ...)
+ ((() body-to-process ...) clauses-to-process ...)
+ args-so-far (checks-so-far ...) (body ...))
+ (%case-lambda-checked
+ (clauses-so-far ... (args-so-far checks-so-far ... body ...))
+ (clauses-to-process ...)
+ () () (body-to-process ...)))
+ ((_ (clauses-so-far ...)
+ (((arg . args-to-process) body-to-process ...) clauses-to-process ...)
+ args-so-far (checks-so-far ...) (body ...))
+ (%case-lambda-checked
+ (clauses-so-far ... (args-so-far checks-so-far ... body ...))
+ (clauses-to-process ...)
+ () () (body-to-process ...) arg . args-to-process))
+ ((_ (clauses-so-far ...)
+ ((arg-to-process body-to-process ...) clauses-to-process ...)
+ args-so-far (checks-so-far ...) (body ...))
+ (%case-lambda-checked
+ (clauses-so-far ... (args-so-far checks-so-far ... body ...))
+ (clauses-to-process ...)
+ arg-to-process () (body-to-process ...)))
+ ((_ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ...) (checks-so-far ...) (body ...) (arg pred) . args)
+ (%case-lambda-checked
+ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ... arg) (checks-so-far ... (check-arg pred arg)) (body ...) . args))
+ ((_ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ...) (checks-so-far ...) (body ...) arg . args)
+ (%case-lambda-checked
+ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ... arg) (checks-so-far ...) (body ...) . args))
+ ((_ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ...) (checks-so-far ...) (body ...) . arg)
+ (%case-lambda-checked
+ (clauses-so-far ...) (clauses-to-process ...)
+ (args-so-far ... . arg) (checks-so-far ...) (body ...)))))
+
+(define-syntax case-lambda-checked
+ (syntax-rules ()
+ ((_ (() first-body ...) rest-clauses ...)
+ (%case-lambda-checked () (rest-clauses ...) () () (first-body ...)))
+ ((_ ((first-arg . first-args) first-body ...) rest-clauses ...)
+ (%case-lambda-checked () (rest-clauses ...) () () (first-body ...) first-arg . first-args))
+ ((_ (args-var first-body ...) rest-clauses ...)
+ (%case-lambda-checked () (rest-clauses ...) args-var () (first-body ...)))))
+
+(define-syntax define-checked
+ (syntax-rules ()
+ ;; Procedure
+ ((_ (name . args) body ...)
+ (define name (%lambda-checked name (body ...) () () . args)))
+ ;; Variable
+ ((_ name pred value)
+ (define name (values-checked (pred) value)))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 6014b1f1f..6343c4a83 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -161,6 +161,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-111.test \
tests/srfi-119.test \
tests/srfi-171.test \
+ tests/srfi-253.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-253.test b/test-suite/tests/srfi-253.test
new file mode 100644
index 000000000..19977ee03
--- /dev/null
+++ b/test-suite/tests/srfi-253.test
@@ -0,0 +1,141 @@
+(define-module (test-srfi-253)
+ #:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-253)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm vm)
+ #:use-module (oop goops)
+ #:use-module (system foreign))
+
+(test-begin "check-arg")
+;; Sanity checks
+(test-assert (check-arg exact-integer? 3))
+(test-assert (check-arg integer? 3))
+(test-assert (check-arg boolean? #f))
+(test-assert (check-arg char? #\d))
+(test-assert (check-arg complex? 3+2i))
+(test-assert (check-arg inexact? 3.8))
+(test-assert (check-arg real? 3))
+(test-assert (check-arg real? 3/2))
+(test-assert (check-arg real? 3.8))
+(test-assert (check-arg list? '()))
+(test-assert (check-arg list? '(1 2 3)))
+(test-assert (check-arg null? '()))
+(test-assert (check-arg fluid? (make-fluid)))
+(test-equal #f (check-arg frame? 3))
+(test-assert (check-arg bytevector? (make-bytevector 3)))
+(test-assert (check-arg array? (make-array 1 2 3)))
+(test-assert (check-arg bitvector? (make-bitvector 3 0)))
+(test-assert (check-arg number? 3))
+(test-assert (check-arg number? 3+2i))
+(test-assert (check-arg number? 3.8))
+(test-assert (check-arg pair? '(1 2 3)))
+(test-assert (check-arg port? (current-input-port)))
+(test-assert (check-arg input-port? (current-input-port)))
+(test-assert (check-arg output-port? (current-output-port)))
+(test-assert (check-arg procedure? procedure?))
+(test-assert (check-arg rational? 3))
+(test-assert (check-arg rational? 3/2))
+(test-assert (check-arg string? ""))
+(test-assert (check-arg string? "hello"))
+(test-assert (check-arg symbol? 'hello))
+;; Only enable on implementations supporting symbol->keyword
+(test-assert (check-arg keyword? (symbol->keyword 'hello)))
+(test-assert (check-arg vector? #(1 2 3)))
+;; Predicate checks
+(test-assert (check-arg (lambda (x) (positive? (string-length x)))
+ "hello"))
+(test-assert (check-arg positive? 9))
+(test-assert (check-arg string-length "hello")) ;; If it works it works.
+(test-assert (check-arg (lambda (x)
+ (and (integer? x) (positive? x)))
+ 8))
+(test-assert (check-arg ((lambda (x y)
+ (lambda (a) (and (x a) (y a))))
+ integer? positive?)
+ 8))
+;; Erroring checks
+(test-error (check-arg string? 3))
+(test-error (check-arg real? 3+2i))
+(test-error (check-arg symbol? "hello"))
+(test-error (check-arg procedure? 3))
+(test-error (check-arg (lambda (a) (> a 3)) 0))
+;; Syntax checks
+(test-assert (check-arg integer? 3 'testing 'extra 'args))
+(test-end "check-arg")
+
+
+(test-begin "values-checked")
+(test-equal 3 (values-checked (integer?) 3))
+(test-equal 3 (values-checked ((lambda (x) (= 3 x))) 3))
+(test-approximate 3.0 (values-checked (real?) 3.0) 0.00001)
+(test-equal 3 (values-checked (real?) 3))
+(test-assert (values-checked (integer? string?) 3 "hello"))
+(test-approximate 3.0 (values-checked (inexact?) 3.0) 0.00001)
+(test-error (values-checked (integer?) "hello"))
+(test-error (values-checked (integer? string?) 3 3))
+(test-end "values-checked")
+
+(test-begin "let-checked")
+(define a 3)
+(define b 4)
+(test-equal 3 (let-checked ((a integer?)) a))
+(test-equal 3 (let-checked ((a integer? 3)) a))
+(test-equal 6 (let-checked ((a integer? 2) (b integer?)) (+ a b)))
+(test-equal 3 (let-checked ((a integer? 2) (b integer? 1)) (+ a b)))
+(test-equal 3 (let-checked (((a b) (integer? integer?) (values 2 1))) (+ a b)))
+(test-error (let-checked ((a string? 3)) a))
+(test-end "let-checked")
+
+
+(test-begin "lambda-checked")
+(test-assert (lambda-checked () #t))
+(test-assert (lambda-checked (a) #t))
+(test-assert (lambda-checked (a b) #t))
+(test-assert (lambda-checked ((a integer?)) #t))
+(test-assert (lambda-checked (a (b integer?)) #t))
+(test-assert (lambda-checked ((a string?) (b integer?)) #t))
+(test-assert ((lambda-checked (a) #t) 3))
+(test-assert ((lambda-checked (a) #t) "hello"))
+(test-assert ((lambda-checked ((a integer?)) #t) 3))
+(test-assert ((lambda-checked (a (b integer?)) #t) 3 3))
+(test-assert ((lambda-checked (a (b integer?)) #t) "hello" 3))
+(test-error ((lambda-checked ((a integer?)) #t) "hello"))
+(test-error ((lambda-checked (a (b integer?)) #t) "hello" "hi"))
+;; Rest args. Sample implementation doesn't reliably pass this.
+(test-assert (lambda-checked (a . c) #t))
+(test-assert (lambda-checked ((a integer?) . c) #t))
+(test-assert (lambda-checked (a b . c) #t))
+(test-assert (lambda-checked (a (b integer?) . c) #t))
+(test-assert ((lambda-checked (a (b integer?) . c) #t) 2 3 4 3))
+(test-assert ((lambda-checked (a (b integer?) . c) #t) 2 3))
+(test-assert ((lambda-checked (a (b integer?) . c) #t) 2 3 3 3 2))
+(test-error ((lambda-checked (a (b integer?) . c) #t) 2 "hello"))
+(test-end "lambda-checked")
+
+
+(test-begin "define-checked")
+(define-checked (c) #t)
+(test-assert (c))
+(define-checked (c (a integer?)) #t)
+(test-assert (c 3))
+(test-error (c "hello"))
+(define-checked (c b) #t)
+(test-assert (c "anything"))
+(test-error (c 1 2 3))
+(define-checked (c (b string?)) #t)
+(test-assert (c "hello"))
+(test-error (c 3))
+;; Rest args. Sample implementation doesn't reliably pass this.
+(define-checked (c b . d) #t)
+(test-assert (c 2))
+(test-assert (c 2 2 4 5))
+(define-checked (c (b integer?) . d) #t)
+(test-assert (c 2 2 4 5))
+(test-assert (c 2))
+(test-error (c "hello"))
+(test-error (c "hello" 2 4))
+(define-checked c string? "hello")
+(test-assert c)
+(set! c "whatever")
+(test-assert c)
+(test-end "define-checked")
--
2.41.0
--=-=-=
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: quoted-printable
Anyway, thanks for working on Guile and (possibly) giving me an
opportunity to contribute =F0=9F=96=A4
--=20
Artyom Bologov
https://aartaka.me
--=-=-=--
Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.505 (Entity 5.505) Content-Type: text/plain; charset=utf-8 X-Loop: help-debbugs@HIDDEN From: help-debbugs@HIDDEN (GNU bug Tracking System) To: Artyom Bologov <mail@HIDDEN> Subject: bug#72645: Acknowledgement ([PATCH] srfi: Add SRFI-253 support) Message-ID: <handler.72645.B.172376895927857.ack <at> debbugs.gnu.org> References: <877cchti4i.fsf@HIDDEN> X-Gnu-PR-Message: ack 72645 X-Gnu-PR-Package: guile X-Gnu-PR-Keywords: patch Reply-To: 72645 <at> debbugs.gnu.org Date: Fri, 16 Aug 2024 00:43:02 +0000 Thank you for filing a new bug report with debbugs.gnu.org. This is an automatically generated reply to let you know your message has been received. Your message is being forwarded to the package maintainers and other interested parties for their attention; they will reply in due course. Your message has been sent to the package maintainer(s): bug-guile@HIDDEN If you wish to submit further information on this problem, please send it to 72645 <at> debbugs.gnu.org. Please do not send mail to help-debbugs@HIDDEN unless you wish to report a problem with the Bug-tracking system. --=20 72645: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=3D72645 GNU Bug Tracking System Contact help-debbugs@HIDDEN with problems
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997 nCipher Corporation Ltd,
1994-97 Ian Jackson.