From 2d73d445be2ada75746b55dea831b5e0a3764410 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 3 Jul 2022 12:35:01 +0200 Subject: Extend object type system to allow list-of. --- module/hnh/util/object.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 1ecacf8e..6a26336e 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -5,6 +5,8 @@ :use-module (hnh util) :export (define-type)) + + ;; If given a syntax list extract the first lexeme, if given a "symbol", return that. (define (syntax-first stx) (syntax-case stx () @@ -36,9 +38,15 @@ ;; DSL for specifying type predicates ;; Basically a procedure body, but the variable to test is implicit. (define-syntax build-validator-body - (syntax-rules (and or) + (syntax-rules (and or list-of) ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) + ((_ variable (list-of (proc args ...))) + (and (list? variable) + (every (lambda (x) (build-validator-body x (proc args ...))) + variable))) + ((_ variable (list-of proc)) (and (list? variable) + (every proc variable))) ((_ variable (proc args ...)) (proc variable args ...)) ((_ variable proc) (proc variable)))) -- cgit v1.2.3