From b6d8f4fe04afb19976d9ded559baeb3f7e72fe2c Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Wed, 15 Sep 2021 17:21:52 +0900
Subject: Change `define-system` interface.

---
 tests/test-vikalpa.scm |  2 +-
 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))))))
-- 
cgit v1.2.3