diff options
| -rw-r--r-- | tests/test-vikalpa.scm | 2 | ||||
| -rw-r--r-- | vikalpa.scm | 17 |
2 files changed, 10 insertions, 9 deletions
diff --git a/tests/test-vikalpa.scm b/tests/test-vikalpa.scm index 6561e17..961d683 100644 --- a/tests/test-vikalpa.scm +++ b/tests/test-vikalpa.scm @@ -20,7 +20,7 @@ #:use-module (srfi srfi-64) #:use-module (vikalpa)) -(define-system test/defs () +(define-system test/defs (core-system) (define-syntax-rules implies () ((implies x y) (if x y #t)) ((implies x y z . rest) diff --git a/vikalpa.scm b/vikalpa.scm index 290b90d..771d484 100644 --- a/vikalpa.scm +++ b/vikalpa.scm @@ -25,6 +25,7 @@ system-lookup set-measure-predicate set-measure-less-than + core-system define-system define-proof define-core-function @@ -1134,8 +1135,8 @@ (make-exception-with-message "not found") (make-exception-with-irritants 'name)))))))) -(define* (core-system #:optional (parent (make <system>))) - (parameterize ((current-system parent)) +(define (core-system) + (parameterize ((current-system (make <system>))) (define-syntax-rules and () ((and) '#t) ((and x) x) @@ -1146,16 +1147,16 @@ (define-syntax define-system (syntax-rules () - ((_ name (systems ...) expr ...) - (define* (name #:optional (parent (core-system))) - (when (member 'name (list 'systems ...)) + ((_ name (system) expr ...) + (define (name) + (when (equal? 'name 'system) (raise-exception (make-exception (make-exception-with-origin 'name) (make-exception-with-message "recursive system") - (make-exception-with-irritants '(systems ...))))) - (parameterize ((current-system - ((compose systems ... identity) parent))) + (make-exception-with-irritants 'system)))) + (parameterize + ((current-system (system))) expr ... (current-system)))))) |