Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 90 insertions, 0 deletions

diff --git a/src/bigloo/configure.bgl b/src/bigloo/configure.bgl
new file mode 100644
index 0000000..e100d8d
--- /dev/null
+++ b/src/bigloo/configure.bgl
@@ -0,0 +1,90 @@
+;*=====================================================================*/
+;*    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)))))))))