diff options
| author |  Peter McGoron
| 2025-03-05 17:57:07 -0500 |
|---|---|---|
| committer | Peter McGoron
| 2025-03-05 17:57:07 -0500 |
| commit | 122924a4d15b11a46ec4bade401174fe810cce15 (patch) | |
| tree | 5d2640e25aa9df4ea915b89cebafaf63699a42d3 /lib/SAHP.scm | |
| parent | remove special handling of the default implementation (diff) | |
add subtyping back
Diffstat (limited to 'lib/SAHP.scm')
| -rw-r--r-- | lib/SAHP.scm | 36 |
1 files changed, 24 insertions, 12 deletions
diff --git a/lib/SAHP.scm b/lib/SAHP.scm index 0e50b0a..1d17e45 100644 --- a/lib/SAHP.scm +++ b/lib/SAHP.scm @@ -1,4 +1,4 @@ -#| Copyright 2024 Peter McGoron +#| Copyright 2025 Peter McGoron | | Licensed under the Apache License, Version 2.0 (the "License"); | @@ -18,13 +18,22 @@ ;;; API ;;; ;;;;;;;;;;;; -(define (set-global-SAHP! SAHP type procedure) - (%SAHP-add-to-global (extract-SAHP-descriptor SAHP) - type - procedure)) +(define set-global-SAHP! + (case-lambda + ((SAHP type procedure) + (set-global-SAHP! SAHP type #f procedure)) + ((SAHP type flag procedure) + (%SAHP-set (SAHP-global-scope (extract-SAHP-descriptor SAHP)) + (list (list type flag procedure)))))) (define-syntax define-global-SAHP (syntax-rules () + ((_ (name (type flag arg1) . arg-rest) body ...) + (set-global-SAHP! name + type + flag + (lambda (arg1 . arg-rest) + body ...))) ((_ (name (type arg1) . arg-rest) body ...) (set-global-SAHP! name type @@ -34,24 +43,27 @@ (define-syntax parameterize-SAHP (syntax-rules () ((_ ((SAHP (type value) ...) ...) body ...) + (parameterize-SAHP ((SAHP (type #f value) ...) ...) body ...)) + ((_ ((SAHP (type flag value) ...) ...) body ...) (let ((param (SAHP-dynamic-scope-parameter (extract-SAHP-descriptor SAHP))) ...) - (parameterize ((param (%SAHP-set/subtypes (param) - (list type ...) - (list value ...))) + (parameterize ((param (%SAHP-set (param) + (list (list type flag value) + ...))) ...) body ...))))) (define-syntax letrec-SAHP (syntax-rules () ((_ ((SAHP (type value) ...) ...) body ...) + (letrec-SAHP ((SAHP (type #f value) ...) ...) body ...)) + ((_ ((SAHP (type flag value) ...) ...) body ...) (let ((%SAHP (extract-SAHP-descriptor SAHP)) ...) (letrec ((SAHP (%SAHP/local-scope %SAHP - (%SAHP-set/subtypes (SAHP-local-scope - %SAHP) - (list type ...) - (list value ...)))) + (%SAHP-set (SAHP-local-scope %SAHP) + (list (list type flag value) + ...)))) ...) body ...))))) |