From: Chris Hanson Date: Mon, 21 May 2018 06:16:48 +0000 (-0700) Subject: Actually implement a library and imports parser. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~15 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bb3a4c08a32953fc375b900be06a0d2389129621;p=mit-scheme.git Actually implement a library and imports parser. This one isn't done as macros, since these "forms" are a specialized syntax that is available only in constrained contexts. This implementation handles both cond-expand and include-library-declarations. This isn't yet tested, so don't expect it to work. --- diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm new file mode 100644 index 000000000..73bb7311e --- /dev/null +++ b/src/runtime/library-parser.scm @@ -0,0 +1,238 @@ +#| -*-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 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. + +|# + +;;;; R7RS libraries: define-library parser +;;; package: (runtime library parser) + +(declare (usual-integrations)) + +(define (parse-define-library-form form) + (let ((result (%parse-define-library form))) + (and result + (let loop + ((decls (expand-parsed-decls (cdr result))) + (exports '()) + (imports '()) + (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) + contents)) + (else + (loop decls + exports + imports + (append (reverse (cdr decl)) contents))))) + (make-parsed-library (car result) + (reverse exports) + (reverse imports) + (reverse contents))))))) + +(define-record-type + (make-parsed-library name exports imports contents) + parsed-library? + (name parsed-library-name) + (exports parsed-library-exports) + (imports parsed-library-imports) + (contents parsed-library-contents)) + +(define (expand-parsed-decls parsed-decls) + (append-map (lambda (parsed-decl) + (case (car parsed-decl) + ((include-library-declarations) + (append-map (lambda (pathname) + (expand-parsed-decls + (get-library-declarations pathname))) + (cdr parsed-decl))) + ((cond-expand) + (expand-parsed-decls + (evaluate-cond-expand eq? parsed-decl))) + (else + (list parsed-decl)))) + parsed-decls)) + +(define (get-library-declarations pathname) + (cdr + (%parse-define-library + (call-with-input-file (pathname-default-type pathname "scm") read)))) + +(define define-library-parser + (object-parser + (encapsulate list + (list 'define-library + (object (alt (match 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"))))))) + +(define library-declaration-parser + (object-parser + (alt export-parser + import-parser + include-parser + begin-parser + cond-expand-parser))) + +(define export-parser + (object-parser + (encapsulate list + (list (match export) + (* (object export-spec-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"))))) + +(define import-parser + (object-parser + (encapsulate list + (list (match import) + (* (object import-set-parser)))))) + +(define import-set-parser + (object-parser + (alt (encapsulate (lambda (library-name) (list 'library library-name)) + (match-if library-name?)) + (encapsulate list + (alt (list (alt (match only) (match except)) + (object import-set-parser) + (* (match-if symbol?))) + (list (match prefix) + (object import-set-parser) + (match-if symbol?)) + (list (match rename) + (object import-set-parser) + (* (encapsulate cons + (list (match-if symbol?) + (match-if symbol?))))))) + (sexp (parsing-error "import set"))))) + +(define include-parser + (object-parser + (encapsulate (lambda (keyword . pathnames) + (cons 'include + (map (lambda (pathname) + (list pathname keyword)) + pathnames))) + (list (alt (match include) (match include-ci)) + (* (object pathname-parser)))))) + +(define include-library-declarations-parser + (object-parser + (encapsulate list + (list (match include-library-declarations) + (* (object pathname-parser)))))) + +(define (pathname-parser object win lose) + (let ((pathname + (ignore-errors + (lambda () + (merge-pathnames object))))) + (if (not (pathname? pathname)) + (error "Unrecognized pathname:" object)) + (win (structure-parser-values pathname) + lose))) + +(define begin-parser + (object-parser + (encapsulate list + (list (match begin) + (* (match-any)))))) + +(define cond-expand-parser + (object-parser + (encapsulate list + (list (match cond-expand) + (* (object cond-expand-clause-parser)))))) + +(define cond-expand-clause-parser + (object-parser + (encapsulate list + (list (object feature-requirement-parser) + library-declarations-parser)))) + +(define feature-requirement-parser + (object-parser + (alt (match-if symbol?) + (encapsulate list + (list (alt (match or) (match and)) + (* (object feature-requirement-parser)))) + (encapsulate list + (list (match not) + (object feature-requirement-parser))) + (encapsulate list + (list (match library) + (match-if library-name?)))))) + +(define (wrap-parser parser description) + (let ((message (string-append "Unable to parse " description ":"))) + (lambda (object) + (let ((result (apply-object-parser parser object))) + (if (not result) + (error message object)) + (car result))))) + +(define %parse-define-library + (wrap-parser define-library-parser "define-library form")) + +(define parse-import-form + (wrap-parser import-parser "import form")) + +(define parse-import-set + (wrap-parser import-set-parser "import set")) + +(define (parsing-error description) + (lambda (object win lose) + (win (error (string-append "Unrecognized " description ":") object) + lose))) + +(define (library-name? object) + (and (list? object) + (every (lambda (elt) + (or (interned-symbol? elt) + (exact-nonnegative-integer? elt))) + object))) \ No newline at end of file diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 0a1dea874..4ae0f6b59 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -631,66 +631,6 @@ 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 @@ -717,6 +657,9 @@ USA. (list (keep-if id=? library) ,(library-name-pattern)))))))) +(define (library-name-pattern) + `(subform (* (or symbol ,exact-nonnegative-integer?)))) + (define (evaluate-cond-expand id=? clauses) (let ((clause (find (lambda (clause) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3713409d5..e48cc0dfb 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4790,10 +4790,8 @@ USA. (when $when) ;R7RS features ;R7RS ) - (export (runtime) - (define-library $define-library) ;R7RS - (import $import) ;R7RS - )) + (export (runtime library parser) + evaluate-cond-expand)) (define-package (runtime syntax syntax-rules) (files "syntax-rules") @@ -5806,3 +5804,17 @@ USA. time-world-restored) (export () world-report)) + +(define-package (runtime library parser) + (files "library-parser") + (parent (runtime)) + (export (runtime) + library-name? + parse-define-library-form + parse-import-form + parse-import-set + parsed-library-contents + parsed-library-exports + parsed-library-imports + parsed-library-name + parsed-library?)) \ No newline at end of file