#| -*-Scheme-*-

$Id: adhoc.scm 4192 2007-10-12 01:07:29Z cph $

Copyright (C) 2006,2007 Massachusetts Institute of Technology

This program 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.

This program 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 this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Ad-hoc packaging

(declare (usual-integrations))

(define (create-ad-hoc-package! target name exports)
  (if (eq? (environment-reference-type target name) 'normal)
      (let ((value (environment-lookup target name)))
	(if (ad-hoc-package? value)
	    (delete-ad-hoc-package! value)
	    (error "Name bound to non-package:" name value))))
  (for-each (lambda (name)
	      (if (environment-bound? target name)
		  (warn "Redefining variable:" name)))
	    (cons name exports))
  (let ((env (extend-top-level-environment target exports)))
    (%install-ad-hoc-package env target name exports)
    env))

(define (%install-ad-hoc-package env target name exports)
  (environment-define env '|#[ad-hoc-package]| (cons* target name exports))
  (set! %ad-hoc-packages (cons env %ad-hoc-packages))
  (environment-define target name env)
  (for-each (lambda (name)
	      (link-variables target name env name))
	    exports))

(define (delete-ad-hoc-package! env)
  (%delete-package! env)
  (set! %ad-hoc-packages (delq! env %ad-hoc-packages))
  unspecific)

(define (%delete-package! env)
  (let ((s (environment-lookup env '|#[ad-hoc-package]|)))
    (let ((target (car s)))
      (for-each (lambda (name)
		  (unbind-variable target name))
		(cdr s)))))

(define (delete-all-ad-hoc-packages!)
  (for-each %delete-package! %ad-hoc-packages)
  (set! %ad-hoc-packages '())
  unspecific)

(define %ad-hoc-packages '())

(define (ad-hoc-package? object)
  (and (top-level-environment? object)
       (memq '|#[ad-hoc-package]| (environment-bound-names object))))

(define (ad-hoc-exports pathname #!optional target public-name?)
  (let ((expr
	 (syntax* (read-file (pathname-new-type pathname "scm"))
		  (%default-target-env target))))
    (if (open-block? expr)
	(open-block-components expr
	 (lambda (names decls body)
	   decls
	   body
	   (keep-matching-items names
	     (if (default-object? public-name?)
		 ad-hoc-public-name?
		 public-name?))))
	'())))

(define (ad-hoc-public-name? name)
  (not (let ((s (symbol-name name)))
	 (or (string-prefix? "%" s)
	     (string-prefix? "#" s)
	     (and (string-prefix? "<%" s)
		  (string-suffix? ">" s))))))

(define (ad-hoc-load pathname #!optional target exports package-name)
  (let ((pathnames (if (pair? pathname) pathname (list pathname)))
	(target (%default-target-env target)))
    (load pathnames
	  (create-ad-hoc-package! target
				  (if (default-object? package-name)
				      (%default-package-name (car pathnames))
				      package-name)
				  (if (default-object? exports)
				      (append-map (lambda (pathname)
						    (ad-hoc-exports pathname
								    target))
						  pathnames)
				      exports)))))

(define (%default-package-name pathname)
  (symbol 'ad-hoc-package:
	  (->namestring (pathname-new-type (merge-pathnames pathname) #f))))

(define %default-target-env
  (let ((current-load-environment
	 (if (environment-bound? system-global-environment
				 'current-load-environment)
	     current-load-environment
	     nearest-repl/environment)))
    (lambda (target)
      (if (default-object? target)
	  (current-load-environment)
	  target))))

(define %get-env)

(%install-ad-hoc-package (the-environment)
			 system-global-environment
			 (%default-package-name (current-load-pathname))
			 (ad-hoc-exports (current-load-pathname)
					 system-global-environment))