From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 May 2018 01:05:44 +0000 (-0700)
Subject: Non-functioning implementation of import and define-library.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~25
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2e96b4d03b2c50c86ce815877ae9e0f0fb98e501;p=mit-scheme.git

Non-functioning implementation of import and define-library.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index e467696bb..41dfb69de 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -611,26 +611,88 @@ USA.
      (syntax-check '(_ expression) form)
      (descend (cadr form) 0 finalize))))
 
+;;;; R7RS: libraries
+
+(define $define-library
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+	 `(,(library-name-pattern)
+	   (* ,(library-declaration-pattern)))
+       (lambda (name declarations)
+	 (scons-quote (cons name declarations))
+	 )))))
+
+(define (library-declaration-pattern)
+  (spar-pattern-fixed-point
+   (lambda (library-declaration)
+     `(subform
+       (or (cons (keep-if id=? export)
+		 (* (or id
+			(subform (ignore-if id=? rename)
+				 (cons id id)))))
+	   (cons (keep-if id=? import)
+		 (* ,(import-set-pattern)))
+	   (cons (keep-if id=? begin)
+		 (* any))
+	   (cons (or (keep-if id=? include)
+		     (keep-if id=? include-ci)
+		     (keep-if id=? include-library-declarations))
+		 (+ ,string?))
+	   (cons (keep-if id=? cond-expand)
+		 (+ (subform
+		     (cons ,(feature-requirement-pattern)
+			   (* ,library-declaration))))))))))
+
+(define $import
+  (spar-transformer->runtime
+   (delay
+     (scons-rule `((* ,(import-set-pattern)))
+       (lambda (import-sets)
+	 (scons-quote import-sets)
+	 )))))
+
+(define (import-set-pattern)
+  (spar-pattern-fixed-point
+   (lambda (import-set)
+     `(or ,(library-name-pattern)
+	  (subform
+	   (or (cons* (or (keep-if id=? only)
+			  (keep-if id=? except))
+		      ,import-set
+		      (* id))
+	       (list (keep-if id=? prefix)
+		     ,import-set
+		     id)
+	       (cons* (keep-if id=? rename)
+		      ,import-set
+		      (* (subform (cons id id))))))))))
+
+(define (library-name-pattern)
+  `(subform (* (or symbol ,exact-nonnegative-integer?))))
+
 ;;;; SRFI 0 and R7RS: cond-expand
 
 (define $cond-expand
   (spar-transformer->runtime
    (delay
      (scons-rule `((value id=?)
-		   (+ ,(cond-expand-clause-pattern)))
+		   (+ (subform (cons ,(feature-requirement-pattern)
+				     (* any)))))
        generate-cond-expand))))
 
-(define (cond-expand-clause-pattern)
-  `(subform (cons ,(spar-pattern-fixed-point
-		    (lambda (feature-requirement)
-		      `(or id
-			   (subform
-			    (or (cons (or (keep-if id=? or)
-					  (keep-if id=? and))
-				      (* ,feature-requirement))
-				(list (keep-if id=? not)
-				      ,feature-requirement))))))
-		  (* any))))
+(define (feature-requirement-pattern)
+  (spar-pattern-fixed-point
+   (lambda (feature-requirement)
+     `(or id
+	  (subform
+	   (or (cons (or (keep-if id=? or)
+			 (keep-if id=? and))
+		     (* ,feature-requirement))
+	       (list (keep-if id=? not)
+		     ,feature-requirement)
+	       (list (keep-if id=? library)
+		     ,(library-name-pattern))))))))
 
 (define (generate-cond-expand id=? clauses)
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a01851012..f6a787a5e 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4788,6 +4788,10 @@ USA.
 	  (unless $unless)		;R7RS
 	  (when $when)			;R7RS
 	  features			;R7RS
+	  )
+  (export (runtime)
+	  (define-library $define-library) ;R7RS
+	  (import $import)		;R7RS
 	  ))
 
 (define-package (runtime syntax syntax-rules)