bug#72645: [PATCH] srfi: Add SRFI-253 support

[Artyom Bologov <mail@aartaka.me>]

[-- Attachment #1: Type: text/plain, Size: 973 bytes --]

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?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Add SRFI-253 patch --]
[-- Type: text/x-patch, Size: 19947 bytes --]

From e1e05e8062e757a0cb802c01f05bb6fa4e1828ec Mon Sep 17 00:00:00 2001
From: Artyom Bologov <mail@aartaka.me>
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


[-- Attachment #3: Type: text/plain, Size: 142 bytes --]


Anyway, thanks for working on Guile and (possibly) giving me an
opportunity to contribute 🖤

-- 
Artyom Bologov
https://aartaka.me