;*=====================================================================*/
;*    serrano/prgm/project/skribe/src/bigloo/configure.bgl             */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Wed Jul 23 18:42:21 2003                          */
;*    Last change :  Mon Feb  9 06:51:11 2004 (serrano)                */
;*    Copyright   :  2003-04 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    The general configuration options.                               */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module skribe_configure
   (export (skribe-release)
	   (skribe-url)
	   (skribe-doc-dir)
	   (skribe-ext-dir)
	   (skribe-default-path)
	   (skribe-scheme)
	   
	   (skribe-configure . opt)
	   (skribe-enforce-configure . opt)))

;*---------------------------------------------------------------------*/
;*    skribe-configuration ...                                         */
;*---------------------------------------------------------------------*/
(define (skribe-configuration)
   `((:release ,(skribe-release))
     (:scheme ,(skribe-scheme))
     (:url ,(skribe-url))
     (:doc-dir ,(skribe-doc-dir))
     (:ext-dir ,(skribe-ext-dir))
     (:default-path ,(skribe-default-path))))

;*---------------------------------------------------------------------*/
;*    skribe-configure ...                                             */
;*---------------------------------------------------------------------*/
(define (skribe-configure . opt)
   (let ((conf (skribe-configuration)))
      (cond
	 ((null? opt)
	  conf)
	 ((null? (cdr opt))
	  (let ((cell (assq (car opt) conf)))
	     (if (pair? cell)
		 (cadr cell)
		 'void)))
	 (else
	  (let loop ((opt opt))
	     (cond
		((null? opt)
		 #t)
		((not (keyword? (car opt)))
		 #f)
		((or (null? (cdr opt)) (keyword? (cadr opt)))
		 #f)
		(else
		 (let ((cell (assq (car opt) conf)))
		    (if (and (pair? cell)
			     (if (procedure? (cadr opt))
				 ((cadr opt) (cadr cell))
				 (equal? (cadr opt) (cadr cell))))
			(loop (cddr opt))
			#f)))))))))

;*---------------------------------------------------------------------*/
;*    skribe-enforce-configure ...                                     */
;*---------------------------------------------------------------------*/
(define (skribe-enforce-configure . opt)
   (let loop ((o opt))
      (when (pair? o)
	 (cond
	    ((or (not (keyword? (car o)))
		 (null? (cdr o)))
	     (error 'skribe-enforce-configure
		    "Illegal enforcement"
		    opt))
	    ((skribe-configure (car o) (cadr o))
	     (loop (cddr o)))
	    (else
	     (error 'skribe-enforce-configure
		    (format "Configuration mismatch: ~a" (car o))
		    (if (procedure? (cadr o))
			(format "provided `~a'"
				(skribe-configure (car o)))
			(format "provided `~a', required `~a'"
				(skribe-configure (car o))
				(cadr o)))))))))