;;;; 	Copyright (C) 1994, 1995 Free Software Foundation, Inc.
;;;; 
;;;; 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, 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 software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 

;; by Miles Bader (bader@gnu.ai.mit.edu)
;; and Tom Lord (lord@gnu.ai.mit.edu)
;;



;;; {Error Handling}
;;;
;;; This is the error handler used by the low-level module system.
;;; It has its own name so that calls are easy to find and change
;;; later once we know what we are doing.
;;;


(define guile:error error)


;;; {Low Level Modules}
;;;
;;; These are the low level data structures for modules.
;;;
;;; (make-module size use-list lazy-binding-proc) => module
;;; module-{obarray,uses,binder}[|-set!]
;;; (module? obj) => [#t|#f]
;;; (module-locally-bound? module symbol) => [#t|#f]
;;; (module-bound? module symbol) => [#t|#f]
;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
;;; (module-symbol-interned? module symbol) => [#t|#f]
;;; (module-local-variable module symbol) => [#<variable ...> | #f]
;;; (module-variable module symbol) => [#<variable ...> | #f]
;;; (module-symbol-binding module symbol opt-value)
;;;		=> [ <obj> | opt-value | an error occurs ]
;;; (module-make-local-var! module symbol) => #<variable...>
;;; (module-add! module symbol var) => unspecified
;;; (module-remove! module symbol) =>  unspecified
;;; (module-for-each proc module) => unspecified
;;; the-symhash-module ; a module wrapper for the built-in top level
;;; (make-scm-module) => module ; a lazy copy of the symhash module
;;; (set-current-module module) => unspecified
;;; (current-module) => #<module...>
;;;
;;;


;;; {and-map, or-map, and map-in-order}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
;;;

;; and-map f l
;;
;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f.  Otherwise, return the last value returned
;; by f.  If f has never been called because l is empty, return #t.
;; 
(define (and-map f lst)
  (let loop ((result #t)
	     (l lst))
    (and result
	 (or (and (null? l)
		  result)
	     (loop (f (car l)) (cdr l))))))

;; or-map f l
;;
;; Apply f to successive elements of l until exhaustion or while f returns #f.
;; If returning early, return the return value of f.
;;
(define (or-map f lst)
  (let loop ((result #f)
	     (l lst))
    (or result
	(and (not (null? l))
	     (loop (f (car l)) (cdr l))))))

;; map-in-order
;;
;; Like map, but guaranteed to process the list in order.
;;
(define (map-in-order fn l)
  (if (null? l)
      '()
      (cons (fn (car l))
	    (map-in-order fn (cdr l)))))

;; DEFINE-MACRO
;; 
;; A more schemey version of scm's common-lispy defmacro.  Should also be
;; more module-safe.
;; 
(defmacro define-macro (first . rest)
  (let ((name (if (symbol? first) first (car first)))
	(transformer
	 (if (symbol? first)
	     (car rest)
	     `(lambda ,(cdr first) ,@rest))))
    `(define ,name
	(,(lambda (transformer)
	    (set! *defmacros* (acons name transformer *defmacros*))
  	    (defmacro:transformer transformer))
	 ,transformer))))

;; This is how modules are printed.
;; You can re-define it.
;;
(define (%print-module mod port wr?)
  (display "#<" port)
  (display (or (module-kind mod) "module") port)
  (let ((name (module-name mod)))
    (if name
	(begin
	  (display " " port)
	  (display name port))))
  (display " " port)
  (display (number->string (object-address mod) 16) port)
  (display ">" port))

;; module-type
;;
;; A module is characterized by an obarray in which local symbols
;; are interned, a list of modules, "uses", from which non-local
;; bindings can be inherited, and an optional lazy-binder which
;; is a (THUNK module symbol) which, as a last resort, can provide
;; bindings that would otherwise not be found locally in the module.
;;
(define module-type
  (make-record-type 'module '(obarray uses binder eval-thunk name kind)
		    (lambda (mod port wr?)
		      (%print-module mod port wr?))))

;; make-module &opt size uses
;;
;; Create a new module, perhaps with a particular size of obarray
;; or initial uses list.
;;
(define module-constructor (record-constructor module-type))

(define make-module
    (lambda args
      (let* ((size 1021)
	     (uses '())
	     (binder #f)
	     (answer #f)
	     (eval-thunk
	      (lambda (symbol define?)
		(if define?
		    (module-make-local-var! answer symbol)
		    (module-variable answer symbol)))))

	(if (> (length args) 0)
	    (begin
	      (set! size (or (car args) size))
	      (set! args (cdr args))))

	(if (> (length args) 0)
	    (begin
	      (set! uses (or (car args) uses))
	      (set! args (cdr args))))

	(if (> (length args) 0)
	    (begin
	      (set! binder (or (car args) binder))
	      (set! args (cdr args))))

	(if (not (null? args))
	    (guile:error "Too many args to make-module." args))

	(if (not (integer? size))
	    (guile:error "Illegal size to make-module." size))

	(and (list? uses)
	     (or (and-map module? uses)
		 (guile:error "Incorrect use list." uses)))

	(if (and binder (not (procedure? binder)))
	    (guile:error
	     "Lazy-binder expected to be a procedure or #f." binder))

	(set! answer
	      (module-constructor (make-vector size '())
				  uses
				  binder
				  eval-thunk
				  #f
				  #f))
	answer)))

(define module-obarray  (record-accessor module-type 'obarray))
(define module-obarray-set! (record-modifier module-type 'obarray))
(define module-uses  (record-accessor module-type 'uses))
(define module-uses-set! (record-modifier module-type 'uses))
(define module-binder (record-accessor module-type 'binder))
(define module-binder-set! (record-modifier module-type 'binder))
(define module-eval-thunk (record-accessor module-type 'eval-thunk))
(define module-eval-thunk-set! (record-modifier module-type 'eval-thunk))
(define module-name (record-accessor module-type 'name))
(define module-set-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define module-set-kind! (record-modifier module-type 'kind))
(define module? (record-predicate module-type))


;;; {Module Searching in General}
;;;
;;; We sometimes want to look for properties of a symbol
;;; just within the obarray of one module.  If the property
;;; holds, then it is said to hold ``locally'' as in, ``The symbol
;;; DISPLAY is locally rebound in the module `safe-guile'.''
;;;
;;;
;;; Other times, we want to test for a symbol property in the obarray
;;; of M and, if it is not found there, try each of the modules in the
;;; uses list of M.  This is the normal way of testing for some
;;; property, so we state these properties without qualification as
;;; in: ``The symbol 'fnord is interned in module M because it is
;;; interned locally in module M2 which is a member of the uses list
;;; of M.''
;;;

;; module-search fn m
;; 
;; return the first non-#f result of FN applied to M and then to
;; the modules in the uses of m, and so on recursively.  If all applications
;; return #f, then so does this function.
;;
(define (module-search fn m v)
  (define (loop pos)
    (and (pair? pos)
	 (or (module-search fn (car pos) v)
	     (loop (cdr pos)))))
  (or (fn m v)
      (loop (module-uses m))))


;;; {Is a symbol bound in a module?}
;;;
;;; Symbol S in Module M is bound if S is interned in M and if the binding
;;; of S in M has been set to some well-defined value.
;;;

;; module-locally-bound? module symbol
;;
;; Is a symbol bound (interned and defined) locally in a given module?
;;
(define (module-locally-bound? m v)
  (let ((var (module-local-variable m v)))
    (and var
	 (variable-bound? var))))

;; module-bound? module symbol
;;
;; Is a symbol bound (interned and defined) anywhere in a given module
;; or its uses?
;;
(define (module-bound? m v)
  (module-search module-locally-bound? m v))

;;; {Is a symbol interned in a module?}
;;;
;;; Symbol S in Module M is interned if S occurs in 
;;; of S in M has been set to some well-defined value.
;;;
;;; It is possible to intern a symbol in a module without providing
;;; an initial binding for the corresponding variable.  This is done
;;; with:
;;;       (module-add! module symbol (make-undefined-variable))
;;;
;;; In that case, the symbol is interned in the module, but not
;;; bound there.  The unbound symbol shadows any binding for that
;;; symbol that might otherwise be inherited from a member of the uses list.
;;;

;; module-symbol-locally-interned? module symbol
;; 
;; is a symbol interned (not neccessarily defined) locally in a given module
;; or its uses?  Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value.
;;
(define (module-symbol-locally-interned? m v)
  (symbol-interned? (module-obarray m) v))


;; module-symbol-interned? module symbol
;; 
;; is a symbol interned (not neccessarily defined) anywhere in a given module
;; or its uses?  Interned symbols shadow inherited bindings even if
;; they are not themselves bound to a defined value.
;;
(define (module-symbol-interned? m v)
  (module-search module-symbol-locally-interned? m v))


;;; {Mapping modules x symbols --> variables}
;;;

;; module-local-variable module symbol
;; return the local variable associated with a MODULE and SYMBOL.
;;
;;; This function is very important. It is the only function that can
;;; return a variable from a module other than the mutators that store
;;; new variables in modules.  Therefore, this function is the location
;;; of the "lazy binder" hack.
;;;
;;; If symbol is defined in MODULE, and if the definition binds symbol
;;; to a variable, return that variable object.
;;;
;;; If the symbols is not found at first, but the module has a lazy binder,
;;; then try the binder.
;;;
;;; If the symbol is not found at all, return #f.
;;;
(define (module-local-variable m v)
  (or (and (module-symbol-locally-interned? m v)
	   (let ((b (symbol-binding (module-obarray m) v)))
	     (and (variable? b) b)))
      (and (module-binder m)
	   ((module-binder m) m v))))

;; module-variable module symbol
;; 
;; like module-local-variable, except search the uses in the 
;; case V is not found in M.
;;
(define (module-variable m v)
  (module-search module-local-variable m v))


;;; {Mapping modules x symbols --> bindings}
;;;
;;; These are similar to the mapping to variables, except that the
;;; variable is dereferenced.
;;;

;; module-symbol-binding module symbol opt-value
;; 
;; return the binding of a variable specified by name within
;; a given module, signalling an guile:error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an guile:error,
;; return OPT-VALUE.
;;
(define (module-symbol-local-binding m v . opt-val)
  (let ((var (module-local-variable m v)))
    (if var
	(variable-ref var)
	(if (not (null? opt-val))
	    (car opt-val)
	    (guile:error "Locally unbound variable." v)))))

;; module-symbol-binding module symbol opt-value
;; 
;; return the binding of a variable specified by name within
;; a given module, signalling an guile:error if the variable is unbound.
;; If the OPT-VALUE is passed, then instead of signalling an guile:error,
;; return OPT-VALUE.
;;
(define (module-symbol-binding m v . opt-val)
  (let ((var (module-variable m v)))
    (if var
	(variable-ref var)
	(if (not (null? opt-val))
	    (car opt-val)
	    (guile:error "Unbound variable." v)))))



;;; {Adding Variables to Modules}
;;;
;;;


;; module-make-local-var! module symbol
;; 
;; ensure a variable for V in the local namespace of M.
;; If no variable was already there, then create a new and uninitialzied
;; variable.
;;
(define (module-make-local-var! m v)
  (or (module-local-variable m v)
      (begin
	(intern-symbol! (module-obarray m) v)
	(let ((answer (make-undefined-variable v)))
	  (symbol-set! (module-obarray m) v answer)
	  answer))))

;; module-add! module symbol var
;; 
;; ensure a particular variable for V in the local namespace of M.
;;
(define (module-add! m v var)
  (if (not (variable? var))
      (guile:error "Bad variable to module-add!" var))
  (intern-symbol! (module-obarray m) v)
  (symbol-set! (module-obarray m) v var))


;; module-remove! 
;; 
;; make sure that a symbol is undefined in the local namespace of M.
;;
(define (module-remove! m v)
  (unintern-symbol! (module-obarray m) v))

;; MODULE-FOR-EACH -- exported
;; 
;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
;;
(define (module-for-each proc module)
  (let ((obarray (module-obarray module)))
    (do ((index 0 (+ index 1))
	 (end (vector-length obarray)))
	((= index end))
      (for-each
       (lambda (bucket)
	 (proc (car bucket) (cdr bucket)))
       (vector-ref obarray index)))))


;;; {Low Level Bootstrapping}
;;;

;; make-scm-module 

;; An scm module is a module into which the lazy binder copies variable
;; bindings from the symhash table.  Newly introduced bindings
;; are local to this module.   They are not reflected in the symhash
;; table.
;;
(define (make-scm-module)
  (make-module 1019 #f
	       (lambda (m s)
		 (let ((bi (and (symbol-interned? #f s)
				(builtin-variable s))))
		   (and bi
			(variable-bound? bi)
			bi)))))

(define the-default-module (make-scm-module))

(define default-uses (list the-default-module))

;; the-module
;; 
;; the module used by the normalizer to resolve free variables
;;
(define the-module the-default-module)

;; set-current-module module
;;
;; set the current module as viewed by the normalizer.
;;
(define (set-current-module m)
  (set! the-module m)
  (set! *top-level-lookup-thunk* (and m (module-eval-thunk m)))
  #t)


;; current-module
;;
;; return the current module as viewed by the normalizer.
;;
(define (current-module) the-module)


;;; {How to Load the User Module System}
;;;

(define (use-modules)
  (for-each
   (lambda (name)
     (load (in-vicinity (implementation-vicinity) name (scheme-file-suffix))))
   '("modops" "extlibs" "libguile" "defmod"))
  (set-current-module *load-module*))

(define (gscm-create-top-level) #f)
(define (gscm-destroy-top-level it) #f)


