diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-23 17:53:06 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-23 18:00:55 +0200 |
commit | 65a47e17747a397b3ebea1c6fead303277ebed5f (patch) | |
tree | 20e7765d91288cdae8b1bdbfe9b25d0c47b5a83d /module/hnh | |
parent | Cpp "binary" now also prints parse result. (diff) | |
download | calp-65a47e17747a397b3ebea1c6fead303277ebed5f.tar.gz calp-65a47e17747a397b3ebea1c6fead303277ebed5f.tar.xz |
General cleanup in preprocessor.
Diffstat (limited to 'module/hnh')
-rw-r--r-- | module/hnh/util/type.scm | 34 |
1 files changed, 21 insertions, 13 deletions
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm index 50008a3a..b998d59c 100644 --- a/module/hnh/util/type.scm +++ b/module/hnh/util/type.scm @@ -1,11 +1,26 @@ (define-module (hnh util type) :use-module ((srfi srfi-1) :select (every)) :export (build-validator-body - list-of pair-of + list-of pair-of alist-of alist-of + list-of-length of-type? typecheck current-procedure-name)) +;; 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 not) + ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) + ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) + ((_ variable (not clause)) (not (build-validator-body variable clause))) + ((_ variable (proc args ...)) (proc variable args ...)) + ((_ variable proc) (proc variable)))) + +(define-syntax-rule (current-procedure-name) + ;; 1 since make-stack is at top of stack + (frame-procedure-name (stack-ref (make-stack #t) 1))) + (define-syntax list-of (syntax-rules () ((_ variable (rule ...)) @@ -20,19 +35,12 @@ (build-validator-body (car variable) a) (build-validator-body (cdr variable) b))) -;; 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 not) - ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) - ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) - ((_ variable (not clause)) (not (build-validator-body variable clause))) - ((_ variable (proc args ...)) (proc variable args ...)) - ((_ variable proc) (proc variable)))) +(define-syntax-rule (alist-of variable key-type value-type) + (build-validator-body variable (list-of (pair-of key-type value-type)))) -(define-syntax-rule (current-procedure-name) - ;; 1 since make-stack is at top of stack - (frame-procedure-name (stack-ref (make-stack #t) 1))) +(define (list-of-length lst n) + (and (list? lst) + (= n (length lst)))) (define-syntax of-type? (syntax-rules () |