From 72037363015ebe9fb7c6f5409d73262910d311c2 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Oct 2018 16:53:20 -0700
Subject: [PATCH] Implement test-library-parser and fix bugs in library-parser.

---
 src/runtime/library-parser.scm                | 123 +++++++++----
 src/runtime/runtime.pkg                       |  15 +-
 tests/check.scm                               |   1 +
 tests/runtime/test-library-data/foo-bar-1.scm |   7 +
 tests/runtime/test-library-data/foo-bar-2.scm |   7 +
 tests/runtime/test-library-data/foo-foo.scm   |   8 +
 tests/runtime/test-library-parser.scm         | 169 ++++++++++++++++++
 7 files changed, 294 insertions(+), 36 deletions(-)
 create mode 100644 tests/runtime/test-library-data/foo-bar-1.scm
 create mode 100644 tests/runtime/test-library-data/foo-bar-2.scm
 create mode 100644 tests/runtime/test-library-data/foo-foo.scm
 create mode 100644 tests/runtime/test-library-parser.scm

diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm
index 26e42b41a..07f36553a 100644
--- a/src/runtime/library-parser.scm
+++ b/src/runtime/library-parser.scm
@@ -37,41 +37,45 @@ USA.
     (let ((result (%parse-define-library form)))
       (and result
 	   (let loop
-	       ((decls (expand-parsed-decls (cdr result) pathname))
-		(exports '())
+	       ((decls (expand-parsed-decls (cdr result) directory))
 		(imports '())
+		(exports '())
 		(contents '()))
 	     (if (pair? decls)
 		 (let ((decl (car decls))
 		       (decls (cdr decls)))
 		   (case (car decl)
-		     ((export)
-		      (loop decls
-			    (append (reverse (cdr decl)) exports)
-			    imports
-			    contents))
 		     ((import)
 		      (loop decls
-			    exports
 			    (append (reverse (cdr decl)) imports)
+			    exports
+			    contents))
+		     ((export)
+		      (loop decls
+			    imports
+			    (append (reverse (cdr decl)) exports)
 			    contents))
 		     (else
 		      (loop decls
-			    exports
 			    imports
+			    exports
 			    (append (reverse (cdr decl)) contents)))))
 		 (make-parsed-library (car result)
-				      (reverse exports)
 				      (reverse imports)
-				      (reverse contents))))))))
+				      (reverse exports)
+				      (reverse contents)
+				      (if (default-object? pathname)
+					  #f
+					  pathname))))))))
 
 (define-record-type <parsed-library>
-    (make-parsed-library name exports imports contents)
+    (make-parsed-library name imports exports contents pathname)
     parsed-library?
   (name parsed-library-name)
-  (exports parsed-library-exports)
   (imports parsed-library-imports)
-  (contents parsed-library-contents))
+  (exports parsed-library-exports)
+  (contents parsed-library-contents)
+  (pathname parsed-library-pathname))
 
 (define (expand-parsed-decls parsed-decls directory)
   (append-map (lambda (parsed-decl)
@@ -87,11 +91,12 @@ USA.
 		  ((cond-expand)
 		   (expand-parsed-decls
 		    (evaluate-cond-expand eq? parsed-decl)))
-		  ((include include-ci)
+		  ((include)
 		   (list
 		    (cons (car parsed-decl)
-			  (map (lambda (pathname)
-				 (merge-pathnames pathname directory))
+			  (map (lambda (p)
+				 (list (merge-pathnames (car p) directory)
+				       (cadr p)))
 			       (cdr parsed-decl)))))
 		  (else
 		   (list parsed-decl))))
@@ -106,22 +111,23 @@ USA.
   (object-parser
     (encapsulate list
       (list 'define-library
-	    (object (alt (match library-name?)
+	    (object (alt (match-if library-name?)
 			 (sexp (parsing-error "library name"))))
 	    library-declarations-parser))))
 
 (define library-declarations-parser
   (list-parser
-    (* (object (alt library-declaration-parser
-		    (sexp (parsing-error "library declaration")))))))
+    (* (object library-declaration-parser))))
 
 (define library-declaration-parser
   (object-parser
     (alt export-parser
 	 import-parser
 	 include-parser
+	 include-library-declarations-parser
 	 begin-parser
-	 cond-expand-parser)))
+	 cond-expand-parser
+	 (sexp (parsing-error "library declaration")))))
 
 (define export-parser
   (object-parser
@@ -131,14 +137,12 @@ USA.
 
 (define export-spec-parser
   (object-parser
-   (alt (encapsulate (lambda (name)
-                       (cons name name))
-                     (match-if symbol?))
-        (encapsulate cons
-	  (list 'rename
-		(match-if symbol?)
-		(match-if symbol?)))
-        (sexp (parsing-error "export spec")))))
+    (encapsulate make-library-export
+      (alt (match-if symbol?)
+           (list 'rename
+		 (match-if symbol?)
+		 (match-if symbol?))
+           (sexp (parsing-error "export spec"))))))
 
 (define import-parser
   (object-parser
@@ -184,7 +188,7 @@ USA.
   (let ((pathname
          (ignore-errors
           (lambda ()
-            (merge-pathnames object)))))
+            (parse-namestring object)))))
     (if (not (pathname? pathname))
         (error "Unrecognized pathname:" object))
     (win (structure-parser-values pathname)
@@ -248,4 +252,61 @@ USA.
        (every (lambda (elt)
 		(or (interned-symbol? elt)
 		    (exact-nonnegative-integer? elt)))
-	      object)))
\ No newline at end of file
+	      object)))
+
+(define (parsed-exports-from exports)
+  (map (lambda (export)
+	 (if (pair? export)
+	     (car export)
+	     export))
+       exports))
+
+(define (parsed-exports-to exports)
+  (map (lambda (export)
+	 (if (pair? export)
+	     (cdr export)
+	     export))
+       exports))
+
+(define (expand-parsed-contents contents)
+  (append-map (lambda (directive)
+		(case (car directive)
+		  ((include)
+		   (parameterize ((param:reader-fold-case? #f))
+		     (append-map read-file
+				 (cdr directive))))
+		  ((include-ci)
+		   (parameterize ((param:reader-fold-case? #t))
+		     (append-map read-file
+				 (cdr directive))))
+		  ((begin)
+		   (cdr directive))
+		  (else
+		   (error "Unknown content directive:" directive))))
+	      contents))
+
+(define (make-library-export from #!optional to)
+  (guarantee symbol? from 'make-library-export)
+  (if (default-object? to)
+      (%make-library-export from from)
+      (begin
+	(guarantee symbol? to 'make-library-export)
+	(%make-library-export from to))))
+
+(define-record-type <library-export>
+    (%make-library-export from to)
+    library-export?
+  (from library-export-from)
+  (to library-export-to))
+
+(define-print-method library-export?
+  (standard-print-method 'library-export
+    (lambda (export)
+      (list (library-export-from export)
+	    (library-export-to export)))))
+
+(define (library-export=? e1 e2)
+  (and (eq? (library-export-from e1)
+	    (library-export-from e2))
+       (eq? (library-export-to e1)
+	    (library-export-to e2))))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f255a1f51..39f0f479f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5835,15 +5835,23 @@ USA.
   (files "library-parser")
   (parent (runtime library))
   (export (runtime library)
+	  expand-parsed-contents
+	  library-export-from
+	  library-export-to
+	  library-export=?
+	  library-export?
 	  library-name?
-	  make-parsed-library
+	  make-library-export
 	  parse-define-library-form
 	  parse-import-form
 	  parse-import-set
+	  parsed-exports-from
+	  parsed-exports-to
 	  parsed-library-contents
 	  parsed-library-exports
 	  parsed-library-imports
 	  parsed-library-name
+	  parsed-library-pathname
 	  parsed-library?))
 
 (define-package (runtime library database)
@@ -5864,12 +5872,9 @@ USA.
   (parent (runtime library))
   (export (runtime library)
 	  convert-import-sets
-	  library-export-from
-	  library-export-to
 	  library-import-from
 	  library-import-from-library
-	  library-import-to
-	  make-library-export))
+	  library-import-to))
 
 (define-package (runtime library loader)
   (files "library-loader")
diff --git a/tests/check.scm b/tests/check.scm
index 6b47e87cd..33cebe75e 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -63,6 +63,7 @@ USA.
     "runtime/test-floenv"
     "runtime/test-hash-table"
     "runtime/test-integer-bits"
+    ("runtime/test-library-parser" (runtime library))
     "runtime/test-md5"
     "runtime/test-mime-codec"
     ("runtime/test-parametric-predicate" (runtime parametric-predicate))
diff --git a/tests/runtime/test-library-data/foo-bar-1.scm b/tests/runtime/test-library-data/foo-bar-1.scm
new file mode 100644
index 000000000..eb1eaf3f2
--- /dev/null
+++ b/tests/runtime/test-library-data/foo-bar-1.scm
@@ -0,0 +1,7 @@
+(define (bar-product bar)
+  (* (foo-bar-v1 bar)
+     (foo-bar-v2 bar)))
+
+(define (bar-quotient bar)
+  (/ (foo-bar-v1 bar)
+     (foo-bar-v2 bar)))
\ No newline at end of file
diff --git a/tests/runtime/test-library-data/foo-bar-2.scm b/tests/runtime/test-library-data/foo-bar-2.scm
new file mode 100644
index 000000000..598b71ed9
--- /dev/null
+++ b/tests/runtime/test-library-data/foo-bar-2.scm
@@ -0,0 +1,7 @@
+(DEFINE (BAR-SUM BAR)
+  (+ (FOO-BAR-V1 BAR)
+     (FOO-BAR-V2 BAR)))
+
+(DEFINE (BAR-DIFFERENCE BAR)
+  (- (FOO-BAR-V1 BAR)
+     (FOO-BAR-V2 BAR)))
\ No newline at end of file
diff --git a/tests/runtime/test-library-data/foo-foo.scm b/tests/runtime/test-library-data/foo-foo.scm
new file mode 100644
index 000000000..b27ee481a
--- /dev/null
+++ b/tests/runtime/test-library-data/foo-foo.scm
@@ -0,0 +1,8 @@
+(define-library (foo foo)
+  (import (scheme base))
+  (export <foo>
+	  foo?)
+  (begin
+    (define-record-type <foo>
+	(make-foo)
+	foo?)))
\ No newline at end of file
diff --git a/tests/runtime/test-library-parser.scm b/tests/runtime/test-library-parser.scm
new file mode 100644
index 000000000..47909b5d0
--- /dev/null
+++ b/tests/runtime/test-library-parser.scm
@@ -0,0 +1,169 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests for library parser
+
+(declare (usual-integrations))
+
+(define test-pathname
+  (current-load-pathname))
+
+(define test-directory
+  (directory-pathname test-pathname))
+
+(define-comparator library-export=?
+  'library-export=?)
+
+(define-test 'parse-library:empty
+  (lambda ()
+    (let ((parsed
+	   (parse-define-library-form '(define-library (foo bar))
+				      test-pathname)))
+      (value-assert parsed-library?
+		    "parsed library"
+		    parsed)
+      (assert-equal (parsed-library-name parsed)
+		    '(foo bar))
+      (assert-null (parsed-library-exports parsed))
+      (assert-null (parsed-library-imports parsed))
+      (assert-null (parsed-library-contents parsed))
+      (assert-equal (parsed-library-pathname parsed)
+		    test-pathname))))
+
+(define-test 'parse-library:ex1
+  (lambda ()
+    (let ((parsed (parse-define-library-form ex1 test-pathname)))
+      (assert-equal (parsed-library-name parsed)
+		    '(foo bar))
+      (assert-lset= equal?
+		    (parsed-library-imports parsed)
+		    (map convert-import ex1-imports))
+      (assert-lset= library-export=?
+		    (parsed-library-exports parsed)
+		    (map convert-export ex1-exports))
+      (assert-list= equal?
+		    (parsed-library-contents parsed)
+		    (append-map convert-content ex1-contents))
+      (assert-equal (parsed-library-pathname parsed)
+		    test-pathname))))
+
+(define-test 'parse-library:ex2
+  (lambda ()
+    (let ((parsed (parse-define-library-form ex2 test-pathname)))
+      (assert-equal (parsed-library-name parsed)
+		    '(foo bar))
+      (assert-lset= equal?
+		    (parsed-library-imports parsed)
+		    (map convert-import (append ex1-imports ex2-extra-imports)))
+      (assert-lset= library-export=?
+		    (parsed-library-exports parsed)
+		    (map convert-export (append ex1-exports ex2-extra-exports)))
+      (assert-list= equal?
+		    (parsed-library-contents parsed)
+		    (append-map convert-content
+				(append ex2-extra-contents ex1-contents)))
+      (assert-equal (parsed-library-pathname parsed)
+		    test-pathname))))
+
+(define (convert-import import)
+  (case (car import)
+    ((only except prefix)
+     `(,(car import)
+       (library ,(cadr import))
+       ,@(cddr import)))
+    ((rename)
+     `(,(car import)
+       (library ,(cadr import))
+       ,@(map (lambda (p)
+		(cons (car p) (cadr p)))
+	      (cddr import))))
+    (else
+     `(library ,import))))
+
+(define (convert-export export)
+  (if (symbol? export)
+      (make-library-export export)
+      (make-library-export (cadr export) (caddr export))))
+
+(define (convert-content content)
+  (case (car content)
+    ((include include-ci)
+     (map (lambda (path)
+	    (list (merge-pathnames path test-directory) (car content)))
+	  (cdr content)))
+    ((begin)
+     (cdr content))
+    (else
+     (error "Unknown content:" content))))
+
+(define ex1-imports
+  '((foo mumble)
+    (only (foo bletch) make-bletch bletch? bletch-thing)
+    (prefix (foo grumble) grumble-)
+    (except (foo quux) make-quux)
+    (rename (foo quux) (make-quux create-quux))))
+
+(define ex1-exports
+  '(make-bar
+    bar?
+    bar-v1
+    bar-v2
+    (rename set-bar-v1! bar-v1!)))
+
+(define ex1-contents
+  '((include "foo-bar-1")
+    (include-ci "foo-bar-2")
+    (begin
+      (define-record-type <bar>
+	  (make-bar v1 v2)
+	  bar?
+	(v1 bar-v1 set-bar-v1!)
+	(v2 bar-v2)))))
+
+(define ex1
+  `(define-library (foo bar)
+     (import ,@ex1-imports)
+     (export ,@ex1-exports)
+     ,@ex1-contents))
+
+(define ex2-extra-imports
+  '((scheme base)))
+
+(define ex2-extra-exports
+  '(<foo> foo?))
+
+(define ex2-extra-contents
+  '((begin
+      (define-record-type <foo>
+	  (make-foo)
+	  foo?))))
+
+(define ex2
+  `(define-library (foo bar)
+     (import ,@ex1-imports)
+     (export ,@ex1-exports)
+     (include-library-declarations "test-library-data/foo-foo")
+     ,@ex1-contents))
\ No newline at end of file
-- 
2.25.1