#| -*-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, 2019, 2020, 2021, 2022 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: loader
;;; package: (runtime library loader)

(declare (usual-integrations))

(add-boot-deps! '(runtime comparator))

;;;; Syntax

(define (syntax-r7rs-source source db)
  (register-r7rs-source! source (copy-library-db db))
  (r7rs-source->scode-file source))

(define-automatic-property '(contents bound-names free-names)
    '(parsed-contents imports-environment)
  #f
  (lambda (parsed-contents env)
    (syntax-library-forms (expand-contents parsed-contents) env)))

(define-automatic-property 'imports-used
    '(imports export-groups free-names bound-names)
  #f
  (lambda (imports groups free-names bound-names)
    (let ((imports-to
	   (lset-difference eq?
			    (map library-ixport-to imports)
			    bound-names)))
      (let ((missing (lset-difference eq? free-names imports-to)))
	(if (pair? missing)
	    (warn "Library has free references not provided by imports:"
		  missing)))
      (let ((used
	     (lset-intersection eq?
				imports-to
				(lset-union eq?
					    free-names
					    (all-exported-names groups)))))
	(filter (lambda (import)
		  (memq (library-ixport-to import) used))
		imports)))))

(define (all-exported-names groups)
  (fold (lambda (group names)
	  (lset-union eq?
		      (map library-ixport-from
			   (export-group-exports group))
		      names))
	'()
	groups))

(define (expand-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))

;;;; Imports environment

(define (environment-available? import db)
  (let ((name (library-ixport-from-library import)))
    (and (registered-library? name db)
	 (library-has? 'environment (registered-library name db)))))

(define (make-environment-from-imports imports db importing-library sealed?)
  (let ((env
	 ((if sealed?
	      make-root-top-level-environment
	      make-top-level-environment)
	  (delete-duplicates (map library-ixport-to imports) eq?))))
    (add-imports-to-env! imports env db importing-library)
    (if importing-library (set-environment->library! env importing-library))
    env))

(define (add-imports-to-env! imports env db importing-library)
  (let ((grouped
	 (let ((table (make-strong-eq-hash-table)))
	   (for-each (lambda (import)
		       (let-values
			   (((senv sname)
			     (library-import-source import db
						    importing-library)))
			 (hash-table-update! table (library-ixport-to import)
			   (lambda (sources) (cons (cons senv sname) sources))
			   (lambda () '()))))
		     imports)
	   (hash-table->alist table))))
    (let ((conflicts
	   (remove (lambda (p)
		     (let ((source (cadr p)))
		       (every (lambda (source*)
				(and (eq? (car source) (car source*))
				     (eq? (cdr source) (cdr source*))))
			      (cddr p))))
		   grouped)))
      (if (pair? conflicts)
	  (error "Conflicting imports:" conflicts)))
    (let-values (((overrides other)
		  (partition (let ((existing (environment-bindings env)))
			       (lambda (p)
				 (let ((binding (assq (car p) existing)))
				   (and binding
					(not (null? (cdr binding)))))))
			     grouped)))
      (if (pair? overrides)
	  (warn "Not overriding names with imports:" (map car overrides)))
      (for-each (lambda (p)
		  (let ((tname (car p))
			(source (cadr p)))
		    (let ((value
			   (environment-safe-lookup (car source) (cdr source))))
		      (cond ((macro-reference-trap? value)
			     (environment-define-macro
			      env tname
			      (macro-reference-trap-transformer value)))
			    ((unassigned-reference-trap? value)
			     ;; nothing to do
			     )
			    (else
			     (environment-define env tname value))))))
		other))))

(define (library-import-source import db importing-library)
  (let ((name (library-ixport-from import))
	(library (registered-library (library-ixport-from-library import) db)))
    (let ((export
	   (find (lambda (export)
		   (eq? name (library-ixport-to export)))
		 (library-exports library importing-library))))
      (if (not export)
	  (error "Not an exported name:" name))
      (values (library-environment library)
	      (library-ixport-from export)))))

(define-automatic-property 'imports-environment '(imports db library)
  (lambda (imports db library)
    (declare (ignore library))
    (every (lambda (import)
	     (environment-available? import db))
	   imports))
  (lambda (imports db library)
    (make-environment-from-imports imports db library #t)))

(define (environment . import-sets)
  (let ((db (current-library-db)))
    (make-environment-from-imports (import-sets->imports import-sets db)
				   db #f #t)))

(define (top-level-environment . import-sets)
  (let ((db (current-library-db)))
    (make-environment-from-imports (import-sets->imports import-sets db)
				   db #f #f)))

(define (scheme-report-environment version)
  (if (not (eqv? version 5))
      (error "Unsupported version:" version))
  (environment '(scheme r5rs)))

(define (null-environment version)
  (if (not (eqv? version 5))
      (error "Unsupported version:" version))
  (environment '(only (scheme r5rs)
		      ... => _ and begin case cond define define-syntax delay do
		      else if lambda let let* let-syntax letrec letrec-syntax or
		      quasiquote quote set! syntax-rules)))

(define (repl-import . import-sets)
  (let ((db (current-library-db)))
    (add-imports-to-env! (import-sets->imports import-sets db)
			 (nearest-repl/environment)
			 db
			 #f)))

(define (environment->library env)
  (let ((value
	 (and (eq? 'normal
		   (environment-reference-type env environment-library-tag))
	      (environment-lookup env environment-library-tag))))
    (and (library? value)
	 value)))

(define (set-environment->library! env library)
  (environment-define env environment-library-tag library))

(define-integrable environment-library-tag
  '|#[(library database)library-tag]|)

(define (environment-name environment)
  (cond ((environment->package environment) => package/name)
	((environment->library environment) => library-key)
	(else #f)))

(define (environment-name&type environment)
  (cond ((environment->package environment)
	 => (lambda (package)
	      (values (package/name package) "package")))
	((environment->library environment)
	 => (lambda (library)
	      (values (library-key library) "library")))
	(else
	 (values #f #f))))

(define (environment-has-name? environment)
  (or (environment->package environment)
      (environment->library environment)))

(define (import-sets->imports import-sets db)
  (parsed-imports->imports (map parse-import-set import-sets) db))

(define (make-environment-from-parsed-imports parsed-imports)
  (let ((db (current-library-db)))
    (make-environment-from-imports (parsed-imports->imports parsed-imports db)
				   db #f #t)))

(define (parsed-imports->imports parsed-imports db)
  (let ((imports (expand-parsed-imports parsed-imports db)))
    (maybe-load-libraries! imports db)
    (let ((unavailable
	   (remove (lambda (import)
		     (environment-available? import db))
		   imports)))
      (if (pair? unavailable)
	  (error "Imported libraries unavailable:"
		 (library-ixports->library-names unavailable))))
    imports))

(define (maybe-load-libraries! imports db)
  (let ((libraries (library-ixports->libraries imports db)))
    (if (any library-preregistered? libraries)
	(for-each load-preregistered-library!
		  (reverse
		   (filter library-preregistered?
			   ((compute-dependency-graph libraries db)
			    'topological-sort)))))))

(define (compute-dependency-graph libraries db)
  (let ((table (make-key-weak-eq-hash-table)))

    (define (trace library)
      (if (not (hash-table-exists? table library))
	  (let ((deps
		 (library-ixports->libraries (library-imports library) db)))
	    (hash-table-set! table library deps)
	    (for-each trace deps))))

    (for-each trace libraries)
    (make-digraph (hash-table-keys table)
		  (lambda (library) (hash-table-ref table library)))))

;;;; Evaluation

(define (eval-r7rs-source source)
  (let ((program (register-r7rs-source! source (current-library-db))))
    (if program
	(library-eval-result program))))

(define (eval-r7rs-scode-file scode pathname)
  (fold (lambda (library result)
	  (declare (ignore result))
	  (library-eval-result library))
	unspecific
	(let ((filename (->namestring pathname))
	      (db (current-library-db)))
	  (map (lambda (library)
		 (register-library! (scode-library->library library filename)
				    db))
	       (r7rs-scode-file-elements scode)))))

(define-automatic-property '(eval-result environment)
    '(contents imports-environment name)
  #f
  (lambda (contents env name)
    (let ((result (scode-eval contents env)))
      (values (or name result)
	      env))))

;;;; Preregistration

(define (preregister-standard-libraries!)
  (parameterize ((param:hide-notifications? #t))
    (let ((pn (system-library-directory-pathname "libraries")))
      (if pn
	  (find-scheme-libraries! pn)))
    (let ((pn (init-file-specifier->pathname '("libraries"))))
      (if (file-directory? pn)
	  (find-scheme-libraries! (pathname-as-directory pn))))))
(add-event-receiver! event:after-restore preregister-standard-libraries!)

(define (find-scheme-libraries! pathname)
  (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)
	      (let ((groups (group-scheme-files files))
		    (db (current-library-db)))
		(for-each (lambda (name)
			    (preregister-scheme-file! (groups name) root db))
			  (groups)))
	      (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)
  (let ((type (pathname-type pathname)))
    (or (equal? (file-type-src file-types:library) type)
	(equal? (file-type-bin file-types:library) type)
	(equal? (file-type-com file-types:library) type)
	(equal? (file-type-src file-types:program) type)
	(equal? (file-type-bin file-types:program) type)
	(equal? (file-type-com file-types:program) type))))

(define-deferred group-scheme-files
  (partition-generator pathname-name string-comparator cons '()))

(define (preregister-scheme-file! file-group root db)

  (define (try-types types fail)
    (let ((com (find-file (file-type-com types)))
	  (bin (find-file (file-type-bin types)))
	  (src (find-file (file-type-src types))))
      (if (or com bin src)
	  (try-scode com
	    (lambda ()
	      (try-scode bin
		(lambda ()
		  (try-source src
		    (lambda () #f))))))
	  (fail))))

  (define (find-file type)
    (find (lambda (file)
	    (string=? type (pathname-type file)))
	  file-group))

  (define (try-scode file fail)
    (if file
	(let ((scode (fasload file)))
	  (if (r7rs-scode-file? scode)
	      (let ((libs (r7rs-scode-file-libraries scode)))
		(if (every scode-library-version-usable? libs)
		    (succeed (let ((ns (->namestring file)))
			       (map (lambda (lib)
				      (scode-library->library lib ns))
				    libs))
			     file)
		    (begin
		      (warn "Compiled library has old version:"
			    (scode-library-version (car libs))
			    file)
		      (fail))))
	      (fail)))
	(fail)))

  (define (try-source file fail)
    (if file
	(let ((parsed (read-r7rs-source file)))
	  (if parsed
	      (succeed (r7rs-source-libraries parsed) file)
	      (fail)))
	(fail)))

  (define (succeed libs file)
    (preregister-libraries! libs file root db))

  (try-types file-types:library
    (lambda ()
      (try-types file-types:program
	(lambda () #f)))))

(define (preregister-libraries! libraries filename root db)
  (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 ()
			  (deregister-library! library db))))))
	      (registered-libraries db))
    ;; 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)))