(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)
((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))))
(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
(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
(let ((pathname
(ignore-errors
(lambda ()
- (merge-pathnames object)))))
+ (parse-namestring object)))))
(if (not (pathname? pathname))
(error "Unrecognized pathname:" object))
(win (structure-parser-values pathname)
(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
--- /dev/null
+#| -*-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))
+\f
+(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
projects / mit-scheme.git / commitdiff