From: Chris Hanson Date: Sat, 24 Nov 2018 05:56:17 +0000 (-0800) Subject: Initial draft of program to grovel over files looking for libraries. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=aafa6ac04e1b39110227242465d9dc1b8ef2e85b;p=mit-scheme.git Initial draft of program to grovel over files looking for libraries. This eliminates the need for the library names to be tied to the filesystem structure. The loader still needs to be enhanced to automatically load the registered libraries. For now this is essentially a no-op. --- diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm index 3fb06d104..67e8c9b42 100644 --- a/src/runtime/library-database.scm +++ b/src/runtime/library-database.scm @@ -40,16 +40,28 @@ USA. (define (put! library) (if (and (library 'has? 'db) - (not (eq? (library 'get 'db) this))) - (error "Can't use library in multiple databases:" library)) + (not (eqv? (library 'get 'db) this))) + (error "Can't use library in multiple databases:" library this)) (library 'put! 'db this) (let ((name (library 'get 'name))) (if name (begin (if (has? name) - (warn "Overwriting library:" name)) + (let ((library* (get name))) + (if (not (library-preregistered? library*)) + (warn "Replacing library:" library* this)) + (library* 'delete! 'db))) (hash-table-set! table name library))))) + (define (delete! name) + (if (not (has? name)) + (error "No library of this name in database:" name this)) + (let ((library (get name))) + (if (not (library-preregistered? library)) + (warn "Removing library:" library this)) + (library 'delete! 'db)) + (hash-table-delete! table name)) + (define (get-names) (hash-table-keys table)) @@ -69,7 +81,7 @@ USA. (define this (bundle library-db? - has? get put! get-names get-all get-copy + has? get put! delete! get-names get-all get-copy summarize-self describe-self)) this)) @@ -314,6 +326,15 @@ USA. (register-library! library db)) libraries)) +(define (preregister-library! library db) + (library 'delete! 'parsed-contents) + (library 'delete! 'contents) + (library 'put! 'preregistration? #t) + (register-library! library db)) + +(define (library-preregistered? library) + (library 'has? 'preregistration?)) + (define (library-accessor key) (lambda (library) (library 'get key))) diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm index 26c8a7eeb..08f4f1a48 100644 --- a/src/runtime/library-loader.scm +++ b/src/runtime/library-loader.scm @@ -33,13 +33,7 @@ USA. (define (syntax-r7rs-source source db) (register-r7rs-source! source (copy-library-db db)) - (make-r7rs-scode-file - (map library->scode-library - (append (r7rs-source-libraries source) - (let ((program (r7rs-source-program source))) - (if program - (list program) - '())))))) + (r7rs-source->scode-file source)) (define-automatic-property '(contents bound-names imports-used) '(parsed-contents imports exports imports-environment) @@ -177,7 +171,7 @@ USA. (let ((filename (->namestring pathname))) (map (lambda (library) (scode-library->library library filename)) - (r7rs-scode-file-libraries scode))))) + (r7rs-scode-file-elements scode))))) (register-libraries! libraries db) (let loop ((libraries libraries) (result unspecific)) (if (pair? libraries) @@ -206,4 +200,133 @@ USA. (let ((p (assq name export-alist))) (if (not p) (error "Not an exported name:" name)) - (cdr p)))))) \ No newline at end of file + (cdr p)))))) + +(define (find-scheme-libraries! pathname) + (preregister-libraries! pathname (current-library-db))) + +(define (preregister-libraries! pathname db) + (let ((pattern (get-directory-read-pattern pathname))) + (if pattern + (let ((root (directory-pathname pattern))) + (let loop ((pattern pattern)) + (receive (files subdirs) + (find-matching-files scheme-pathname? pattern) + (for-each (lambda (group) + (preregister-scheme-file! group root db)) + (group-scheme-files files)) + (for-each (lambda (subdir) + (loop (pathname-as-directory subdir))) + subdirs))))))) + +(define (get-directory-read-pattern pathname) + (case (file-type-direct pathname) + ((regular) + (and (or (scheme-pathname? pathname) + (not (pathname-type pathname))) + (pathname-new-type pathname 'wild))) + ((directory) (pathname-as-directory pathname)) + (else #f))) + +(define (find-matching-files predicate pattern) + (let loop + ((pathnames (directory-read pattern #f)) + (files '()) + (directories '())) + (if (pair? pathnames) + (let ((pathname (car pathnames)) + (pathnames (cdr pathnames))) + (case (file-type-direct pathname) + ((regular) + (loop pathnames + (if (predicate pathname) + (cons pathname files) + files) + directories)) + ((directory) + (loop pathnames + files + (if (member (file-namestring pathname) '("." "..")) + directories + (cons pathname directories)))) + (else + (loop pathnames files directories)))) + (values files directories)))) + +(define (scheme-pathname? pathname) + (member (pathname-type pathname) '("scm" "bin" "com"))) + +(define (group-scheme-files files) + (let ((table (make-string-hash-table))) + (for-each (lambda (file) + (hash-table-update! table + (pathname-name file) + (lambda (files) (cons file files)) + (lambda () '()))) + files) + (hash-table-values table))) + +(define (preregister-scheme-file! file-group root db) + + (define (find-file type) + (find (lambda (file) + (string=? type (pathname-type file))) + file-group)) + + (define (handle-compiled compiled) + (let ((scode (fasload compiled))) + (if (r7rs-scode-file? scode) + (finish (map (lambda (scode-library) + (scode-library->library scode-library + (->namestring compiled))) + (r7rs-scode-file-libraries scode)) + compiled)))) + + (define (handle-source source) + (let ((parsed (read-r7rs-source source))) + (if parsed + (finish (r7rs-source-libraries parsed) source)))) + + (define (finish libraries filename) + (let ((display-filename (enough-namestring filename root))) + ;; Remove any previously registed libraries from this file. + (for-each (let ((no-type (pathname-new-type filename #f))) + (lambda (library) + (if (let ((filename* (library-filename library))) + (and filename* + (pathname=? (pathname-new-type filename* #f) + no-type))) + (with-notification + (lambda (port) + (write-string "Deregistering library " port) + (write (library-name library) port) + (write-string " from \"" port) + (write-string + (enough-namestring (library-filename library) + root) + port) + (write-string "\"" port)) + (lambda () + (db 'delete! (library-name library))))))) + (db 'get-all)) + ;; Now register the current file contents. + (for-each (lambda (library) + (with-notification + (lambda (port) + (write-string "Registering library " port) + (write (library-name library) port) + (write-string " from \"" port) + (write-string display-filename port) + (write-string "\"" port)) + (lambda () + (preregister-library! library db)))) + libraries))) + + (let ((compiled (or (find-file "com") (find-file "bin"))) + (source (find-file "scm"))) + (if compiled + (handle-compiled compiled) + (begin + (if (not source) + (error "No scheme files:" file-group)) + (handle-source source))))) \ No newline at end of file diff --git a/src/runtime/library-parser.scm b/src/runtime/library-parser.scm index 6a6a7cef0..dbb5190ea 100644 --- a/src/runtime/library-parser.scm +++ b/src/runtime/library-parser.scm @@ -92,6 +92,13 @@ USA. (libraries r7rs-source-libraries) (program r7rs-source-program)) +(define (r7rs-source-elements source) + (let ((libraries (r7rs-source-libraries source)) + (program (r7rs-source-program source))) + (if program + (append libraries (list program)) + libraries))) + (define (register-r7rs-source! source db) (register-libraries! (r7rs-source-libraries source) db) (let ((program (r7rs-source-program source))) diff --git a/src/runtime/library-scode.scm b/src/runtime/library-scode.scm index af7ae84a8..2e7023aee 100644 --- a/src/runtime/library-scode.scm +++ b/src/runtime/library-scode.scm @@ -98,6 +98,11 @@ USA. (guarantee metadata-elt? elt 'metadata-elt-values) (cdr elt)) +(define (r7rs-source->scode-file source) + (make-r7rs-scode-file + (map library->scode-library + (r7rs-source-elements source)))) + (define (library->scode-library library) (make-scode-library `(scode-library @@ -116,9 +121,9 @@ USA. 'contents (scode-library-contents library) 'filename filename)) -(define (make-r7rs-scode-file libraries) - (guarantee-list-of scode-library? libraries 'make-r7rs-scode-file) - (make-scode-sequence libraries)) +(define (make-r7rs-scode-file elements) + (guarantee-list-of scode-library? elements 'make-r7rs-scode-file) + (make-scode-sequence elements)) (define (r7rs-scode-file? scode) (let ((scode (strip-comments scode))) @@ -129,7 +134,7 @@ USA. (every scode-library? actions))))))) (register-predicate! r7rs-scode-file? 'r7rs-scode-file) -(define (r7rs-scode-file-libraries scode) +(define (r7rs-scode-file-elements scode) (let ((scode (strip-comments scode))) (if (scode-library? scode) (list scode) @@ -141,11 +146,16 @@ USA. (strip-comments (scode-comment-expression object)) object)) -;; Unlike map, guarantees that procedure is called on the libraries in order. +(define (r7rs-scode-file-libraries scode) + (filter scode-library-name (r7rs-scode-file-elements scode))) + +(define (r7rs-scode-file-program scode) + (let ((elts (remove scode-library-name (r7rs-scode-file-elements scode)))) + (and (pair? elts) + (car elts)))) + (define (map-r7rs-scode-file procedure scode) (guarantee r7rs-scode-file? scode 'map-r7rs-scode-file) - (let loop ((libraries (r7rs-scode-file-libraries scode)) (results '())) - (if (pair? libraries) - (loop (cdr libraries) - (cons (procedure (car libraries)) results)) - (make-scode-sequence (reverse results))))) \ No newline at end of file + (make-scode-sequence + (map-in-order procedure + (r7rs-scode-file-elements scode)))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 211a8a788..5476dd94b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5925,6 +5925,7 @@ USA. library-imports-environment library-parsed-contents library-parsed-imports + library-preregistered? library-syntaxed-contents list->library-export list->library-import @@ -5932,6 +5933,7 @@ USA. make-library-db make-library-export make-library-import + preregister-library! register-libraries! register-library!)) @@ -5941,8 +5943,9 @@ USA. (export (runtime) library-name=? library-name? - r7rs-source-program + r7rs-source-elements r7rs-source-libraries + r7rs-source-program r7rs-source? read-r7rs-source register-r7rs-source!) @@ -5987,7 +5990,10 @@ USA. (export (runtime library) library->scode-library make-r7rs-scode-file + r7rs-scode-file-elements r7rs-scode-file-libraries + r7rs-scode-file-program + r7rs-source->scode-file scode-library->library)) (define-package (runtime library loader) @@ -5995,6 +6001,7 @@ USA. (parent (runtime library)) (export () environment ;R7RS + find-scheme-libraries! null-environment ;R7RS scheme-report-environment ;R7RS )