(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))
(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))
(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)))
(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)
(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)
(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))))))
+\f
+(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)))
+\f
+(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
(guarantee metadata-elt? elt 'metadata-elt-values)
(cdr elt))
\f
+(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
'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)))
(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)
(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
projects / mit-scheme.git / commitdiff