From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Mar 2018 06:51:23 +0000 (-0700)
Subject: Eliminate parse-define-form.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~186
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dcb6101d29e852c4ba618f34bcd1362b9e8c391a;p=mit-scheme.git

Eliminate parse-define-form.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index cee09bff8..b72c3428d 100644
--- 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))))
 
 (define :let
   (spar-transformer->runtime
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3106c77da..7276e53f9 100644
--- 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 10eeff558..853da7f2e 100644
--- 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 14e9e0a97..af4f54430 100644
--- 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 ff4100420..9ba6530c1 100644
--- 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)))