From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Artyom Bologov Newsgroups: gmane.lisp.guile.bugs Subject: bug#72645: [PATCH] srfi: Add SRFI-253 support Date: Fri, 16 Aug 2024 04:40:29 +0400 Message-ID: <877cchti4i.fsf@aartaka.me> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="36954"; mail-complaints-to="usenet@ciao.gmane.io" To: 72645@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Fri Aug 16 02:43:12 2024 Return-path: Envelope-to: guile-bugs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1sel3g-0009Se-Ku for guile-bugs@m.gmane-mx.org; Fri, 16 Aug 2024 02:43:12 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sel3Q-0005yZ-TR; Thu, 15 Aug 2024 20:42:56 -0400 Original-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 ) id 1sel2y-0005iI-If for bug-guile@gnu.org; Thu, 15 Aug 2024 20:42:29 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1sel2v-0005FQ-IT for bug-guile@gnu.org; Thu, 15 Aug 2024 20:42:28 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:Subject; bh=nfeUTApTGFihNC7sI975wsPu4Yh+bLQIwi3RuwdZwSE=; b=skz1FENv+ILrEbT/ioEI5nMROKINapRvZ4WSgC7NsgU8VInZUH9igOhelooOBOIlrllszm6IActpwcld2gd8NdqGsuRHzaQN3g2rEltknc8IzdU40DrMEPlzLpfyZKB7QYwoWQXGjhou2ixHvzlKca8wfczw2uYy98jpbRFIlS7PRbAMXLgM6IhqXrH0cBzhetQOYc/UzB1emxUNgVinmIg0QUGzdYLojB4wdXAEjEoZ4B1oKWfDgYFzfB/bpIOMS0IpIAgB1tb48Ja3KWeRe7wPxvDNK805VlFWYpZGemT56M1+Pw3WE2EX09a31zgN+YUdFPLo5IGrn3JC+ewv0A==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1sel3V-0007Fu-R0 for bug-guile@gnu.org; Thu, 15 Aug 2024 20:43:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Artyom Bologov Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Fri, 16 Aug 2024 00:43:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 72645 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-guile@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.172376895927857 (code B ref -1); Fri, 16 Aug 2024 00:43:01 +0000 Original-Received: (at submit) by debbugs.gnu.org; 16 Aug 2024 00:42:39 +0000 Original-Received: from localhost ([127.0.0.1]:49970 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sel38-0007F9-8R for submit@debbugs.gnu.org; Thu, 15 Aug 2024 20:42:39 -0400 Original-Received: from lists.gnu.org ([209.51.188.17]:55020) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sel34-0007Ez-Vb for submit@debbugs.gnu.org; Thu, 15 Aug 2024 20:42:37 -0400 Original-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 ) id 1sel2T-0005XB-Rn for bug-guile@gnu.org; Thu, 15 Aug 2024 20:41:57 -0400 Original-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 ) id 1sel1f-0004HH-GU for bug-guile@gnu.org; Thu, 15 Aug 2024 20:41:57 -0400 Original-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 Original-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) 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== Received-SPF: none client-ip=178.21.23.139; envelope-from=mail@aartaka.me; 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-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.bugs:10951 Archived-At: --=-=-= 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 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? + + + + + ) + ((_ pred val) + (check-arg pred val 'check-arg)) + ((_ char? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ list? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ pair? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ null? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ string? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ symbol? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ vector? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ pointer? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ hash-table? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ fluid? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ frame? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ bytevector? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ array? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ bitvector? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ number? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ complex? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ real? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ integer? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ exact-integer? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ keyword? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ procedure? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ port? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ input-port? val who . rest) + (assume (is-a? val ) who "Wrong type argument" val . rest)) + ((_ output-port? val who . rest) + (assume (is-a? val ) who "Wrong type argument" 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 --=-=-=--