Eliminate parse-define-form.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index cee09bff858db11d09d73d689657da4d9daf5ba6..b72c3428d4db0754912a40a629f9cbed1c065092 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -230,22 +230,6 @@ USA.
           (scons-define nested
             (apply scons-lambda bvl body-forms))))))
    system-global-environment))
-
-(define (parse-define-form form rename)
-  (cond ((syntax-match? '((datum . mit-bvl) + form) (cdr form))
-        (parse-define-form
-         `(,(car form) ,(caadr form)
-                       ,(if (identifier? (caadr form))
-                            `(,(rename 'NAMED-LAMBDA) ,@(cdr form))
-                            `(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
-         rename))
-       ((syntax-match? '(identifier ? expression) (cdr form))
-        (values (cadr form)
-                (if (pair? (cddr form))
-                    (caddr form)
-                    (unassigned-expression))))
-       (else
-        (ill-formed-syntax form))))
 \f
 (define :let
   (spar-transformer->runtime

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3106c77da8cb603b59c6a84ab47ca7794074f139..7276e53f92d3fe0f4f82ee36bfc90808b6f6ab7b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4722,9 +4722,7 @@ USA.
          (receive :receive)
          (unless :unless)
          (when :when)
-         get-supported-features)
-  (export (runtime)
-         parse-define-form))
+         get-supported-features))
 
 (define-package (runtime syntax syntax-rules)
   (files "syntax-rules")

diff --git a/src/runtime/sysmac.scm b/src/runtime/sysmac.scm
index 10eeff558282c547a8c3cdc9abdc23be58d0e793..853da7f2e4d114b9d67641399fccf5072a7d27f1 100644 (file)
--- a/src/runtime/sysmac.scm
+++ b/src/runtime/sysmac.scm
@@ -97,14 +97,15 @@ USA.
   (er-macro-transformer
    (lambda (form rename compare)
      (declare (ignore compare))
-     (receive (name value)
-        (parse-define-form form rename)
-       `(,(rename 'BEGIN)
-         (,(rename 'DEFINE) ,name)
-         (,(rename 'ADD-BOOT-INIT!)
-          (,(rename 'LAMBDA) ()
-            (,(rename 'SET!) ,name ,value)
-            ,(rename 'UNSPECIFIC))))))))
+     (syntax-check '(_ identifier expression) form)
+     (let ((name (cadr form))
+          (value (caddr form)))
+       `(,(rename 'begin)
+         (,(rename 'define) ,name)
+         (,(rename 'add-boot-init!)
+          (,(rename 'lambda) ()
+            (,(rename 'set!) ,name ,value)
+            ,(rename 'unspecific))))))))
 
 (define-syntax select-on-bytes-per-word
   (er-macro-transformer

diff --git a/tests/load.scm b/tests/load.scm
index 14e9e0a97299686d5e7dffaa05f687573d62d811..af4f54430510721517d2447b10f10ce0cd24392a 100644 (file)
--- a/tests/load.scm
+++ b/tests/load.scm
@@ -25,7 +25,6 @@ USA.
 |#
 
 (let ((environment (make-top-level-environment)))
-  (environment-link-name environment '(runtime mit-macros) 'parse-define-form)
   (load (merge-pathnames "unit-testing" (current-load-pathname))
        environment)
   (for-each (lambda (name)

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index ff410042094a84a198178f6dd53ad8cd2575c5b7..9ba6530c1dd68d911860551cdde2c24c929a9c86 100644 (file)
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -78,12 +78,15 @@ USA.
 (define-syntax define-for-tests
   (er-macro-transformer
    (lambda (form rename compare)
-     compare
-     (receive (name value)
-        (parse-define-form form rename)
-       `(,(rename 'BEGIN)
-        (,(rename 'DEFINE) ,name ,value)
-        (,(rename 'ADD-TEST-DEFINITION) ',name ,name))))))
+     (declare (ignore compare))
+     (let ((name
+           (let loop ((p (cadr form)))
+             (cond ((pair? p) (loop (car p)))
+                   ((identifier? p) p)
+                   (else (ill-formed-syntax form))))))
+       `(,(rename 'begin)
+        (,(rename 'define) ,@(cdr form))
+        (,(rename 'add-test-definition) ',name ,name))))))
 
 (define (add-test-definition name value)
   (let ((p (assq name test-definitions)))