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, 0 insertions, 262 deletions
diff --git a/skribe/src/bigloo/engine.scm b/skribe/src/bigloo/engine.scm
deleted file mode 100644
index bd8a027..0000000
--- a/skribe/src/bigloo/engine.scm
+++ /dev/null
@@ -1,262 +0,0 @@
-;*=====================================================================*/
-;* 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)))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-08 05:09:02 +0000