aboutsummaryrefslogtreecommitdiff
path: root/skribe/src/bigloo/engine.scm
diff options
context:
space:
mode:
Diffstat (limited to 'skribe/src/bigloo/engine.scm')
-rw-r--r--skribe/src/bigloo/engine.scm262
1 files changed, 262 insertions, 0 deletions
diff --git a/skribe/src/bigloo/engine.scm b/skribe/src/bigloo/engine.scm
new file mode 100644
index 0000000..bd8a027
--- /dev/null
+++ b/skribe/src/bigloo/engine.scm
@@ -0,0 +1,262 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/engine.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Tue Sep 9 08:01:30 2003 */
+;* Last change : Fri May 21 16:12:32 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Skribe engines */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module skribe_engine
+
+ (option (set! dsssl-symbol->keyword
+ (lambda (s)
+ (string->keyword
+ (string-append ":" (symbol->string s))))))
+
+ (include "debug.sch")
+
+ (import skribe_types
+ skribe_eval
+ skribe_param
+ skribe_output)
+
+ (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if)
+ (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st)
+ (find-engine ::symbol #!key version)
+
+ (default-engine::obj)
+ (default-engine-set! ::%engine)
+ (push-default-engine ::%engine)
+ (pop-default-engine)
+
+ (processor-get-engine ::obj ::obj ::%engine)
+
+ (engine-format? ::bstring . e)
+
+ (engine-custom::obj ::%engine ::symbol)
+ (engine-custom-set! ::%engine ::symbol ::obj)
+
+ (engine-add-writer! ::%engine ::obj ::procedure ::obj
+ ::obj ::obj ::obj ::obj ::obj ::obj)))
+
+;*---------------------------------------------------------------------*/
+;* *engines* ... */
+;*---------------------------------------------------------------------*/
+(define *engines* '())
+
+;*---------------------------------------------------------------------*/
+;* *default-engine* ... */
+;*---------------------------------------------------------------------*/
+(define *default-engine* #f)
+(define *default-engines* '())
+
+;*---------------------------------------------------------------------*/
+;* default-engine-set! ... */
+;*---------------------------------------------------------------------*/
+(define (default-engine-set! e)
+ (if (not (engine? e))
+ (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e))
+ (begin
+ (set! *default-engine* e)
+ (set! *default-engines* (cons *default-engine* *default-engines*))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* default-engine ... */
+;*---------------------------------------------------------------------*/
+(define (default-engine)
+ *default-engine*)
+
+;*---------------------------------------------------------------------*/
+;* push-default-engine ... */
+;*---------------------------------------------------------------------*/
+(define (push-default-engine e)
+ (set! *default-engines* (cons e *default-engines*))
+ (default-engine-set! e))
+
+;*---------------------------------------------------------------------*/
+;* pop-default-engine ... */
+;*---------------------------------------------------------------------*/
+(define (pop-default-engine)
+ (if (null? *default-engines*)
+ (skribe-error 'pop-default-engine "Empty engine stack" '())
+ (begin
+ (set! *default-engines* (cdr *default-engines*))
+ (if (pair? *default-engines*)
+ (default-engine-set! (car *default-engines*))
+ (set! *default-engine* #f)))))
+
+;*---------------------------------------------------------------------*/
+;* processor-get-engine ... */
+;*---------------------------------------------------------------------*/
+(define (processor-get-engine combinator newe olde)
+ (cond
+ ((procedure? combinator)
+ (combinator newe olde))
+ ((engine? newe)
+ newe)
+ (else
+ olde)))
+
+;*---------------------------------------------------------------------*/
+;* engine-format? ... */
+;*---------------------------------------------------------------------*/
+(define (engine-format? fmt . e)
+ (let ((e (cond
+ ((pair? e) (car e))
+ ((%engine? *skribe-engine*) *skribe-engine*)
+ (else (find-engine *skribe-engine*)))))
+ (if (not (%engine? e))
+ (skribe-error 'engine-format? "No engine" e)
+ (string=? fmt (%engine-format e)))))
+
+;*---------------------------------------------------------------------*/
+;* make-engine ... */
+;*---------------------------------------------------------------------*/
+(define (make-engine ident
+ #!key
+ (version #unspecified)
+ (format "raw")
+ (filter #f)
+ (delegate #f)
+ (symbol-table '())
+ (custom '())
+ (info '()))
+ (let ((e (instantiate::%engine
+ (ident ident)
+ (version version)
+ (format format)
+ (filter filter)
+ (delegate delegate)
+ (symbol-table symbol-table)
+ (customs custom)
+ (info info))))
+ ;; store the engine in the global table
+ (set! *engines* (cons e *engines*))
+ ;; return it
+ e))
+
+;*---------------------------------------------------------------------*/
+;* copy-engine ... */
+;*---------------------------------------------------------------------*/
+(define (copy-engine ident
+ e
+ #!key
+ (version #unspecified)
+ (filter #f)
+ (delegate #f)
+ (symbol-table #f)
+ (custom #f))
+ (let ((e (duplicate::%engine e
+ (ident ident)
+ (version version)
+ (filter (or filter (%engine-filter e)))
+ (delegate (or delegate (%engine-delegate e)))
+ (symbol-table (or symbol-table (%engine-symbol-table e)))
+ (customs (or custom (%engine-customs e))))))
+ (set! *engines* (cons e *engines*))
+ e))
+
+;*---------------------------------------------------------------------*/
+;* find-loaded-engine ... */
+;*---------------------------------------------------------------------*/
+(define (find-loaded-engine id version)
+ (let loop ((es *engines*))
+ (cond
+ ((null? es)
+ #f)
+ ((eq? (%engine-ident (car es)) id)
+ (cond
+ ((eq? version #unspecified)
+ (car es))
+ ((eq? version (%engine-version (car es)))
+ (car es))
+ (else
+ (loop (cdr es)))))
+ (else
+ (loop (cdr es))))))
+
+;*---------------------------------------------------------------------*/
+;* find-engine ... */
+;*---------------------------------------------------------------------*/
+(define (find-engine id #!key (version #unspecified))
+ (with-debug 5 'find-engine
+ (debug-item "id=" id " version=" version)
+ (or (find-loaded-engine id version)
+ (let ((c (assq id *skribe-auto-load-alist*)))
+ (debug-item "c=" c)
+ (if (and (pair? c) (string? (cdr c)))
+ (begin
+ (skribe-load (cdr c) :engine 'base)
+ (find-loaded-engine id version))
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* engine-custom ... */
+;*---------------------------------------------------------------------*/
+(define (engine-custom e id)
+ (with-access::%engine e (customs)
+ (let ((c (assq id customs)))
+ (if (pair? c)
+ (cadr c)
+ #unspecified))))
+
+;*---------------------------------------------------------------------*/
+;* engine-custom-set! ... */
+;*---------------------------------------------------------------------*/
+(define (engine-custom-set! e id val)
+ (with-access::%engine e (customs)
+ (let ((c (assq id customs)))
+ (if (pair? c)
+ (set-car! (cdr c) val)
+ (set! customs (cons (list id val) customs))))))
+
+;*---------------------------------------------------------------------*/
+;* engine-add-writer! ... */
+;*---------------------------------------------------------------------*/
+(define (engine-add-writer! e id pred upred opt before action after class va)
+ ;; check the arity of a procedure
+ (define (check-procedure name proc arity)
+ (cond
+ ((not (procedure? proc))
+ (skribe-error id "Illegal procedure" proc))
+ ((not (correct-arity? proc arity))
+ (skribe-error id
+ (string-append "Illegal `" name "'procedure")
+ proc))))
+ (define (check-output name proc)
+ (and proc (or (string? proc) (check-procedure name proc 2))))
+ ;; check the engine
+ (if (not (engine? e))
+ (skribe-error id "Illegal engine" e))
+ ;; check the options
+ (if (not (or (eq? opt 'all) (list? opt)))
+ (skribe-error id "Illegal options" opt))
+ ;; check the correctness of the predicate and the validator
+ (check-procedure "predicate" pred 2)
+ (when va (check-procedure "validate" va 2))
+ ;; check the correctness of the three actions
+ (check-output "before" before)
+ (check-output "action" action)
+ (check-output "after" after)
+ ;; create a new writer...
+ (let ((n (instantiate::%writer
+ (ident (if (symbol? id) id 'all))
+ (class class)
+ (pred pred)
+ (upred upred)
+ (options opt)
+ (before before)
+ (action action)
+ (after after)
+ (validate va))))
+ ;; ...and bind it
+ (with-access::%engine e (writers)
+ (set! writers (cons n writers))
+ n)))