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/stklos/configure.stk b/src/stklos/configure.stk
new file mode 100644
index 0000000..ece7abc
--- /dev/null
+++ b/src/stklos/configure.stk
@@ -0,0 +1,90 @@
+;;;;
+;;;; configure.stk	-- Skribe configuration options
+;;;; 
+;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;; 
+;;;; 
+;;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
+;;;; USA.
+;;;; 
+;;;;           Author: Erick Gallesio [eg@essi.fr]
+;;;;    Creation date: 10-Feb-2004 11:47 (eg)
+;;;; Last file update: 17-Feb-2004 09:43 (eg)
+;;;;
+
+(define-module SKRIBE-CONFIGURE-MODULE
+  (export skribe-configure skribe-enforce-configure)
+
+  
+(define %skribe-conf
+  `((: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-conf))
+    (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)))
+	 (skribe-error 'skribe-enforce-configure "Illegal enforcement" opt))
+	((skribe-configure (car o) (cadr o))
+	 (loop (cddr o)))
+	(else
+	 (skribe-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)))))))))
+)
\ No newline at end of file