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