aboutsummaryrefslogtreecommitdiff
path: root/src/stklos/engine.stk
diff options
context:
space:
mode:
Diffstat (limited to 'src/stklos/engine.stk')
-rw-r--r--src/stklos/engine.stk242
1 files changed, 242 insertions, 0 deletions
diff --git a/src/stklos/engine.stk b/src/stklos/engine.stk
new file mode 100644
index 0000000..a13ed0f
--- /dev/null
+++ b/src/stklos/engine.stk
@@ -0,0 +1,242 @@
+;;;;
+;;;; engines.stk -- Skribe Engines Stuff
+;;;;
+;;;; Copyright © 2003-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: 24-Jul-2003 20:33 (eg)
+;;;; Last file update: 28-Oct-2004 21:21 (eg)
+;;;;
+
+(define-module SKRIBE-ENGINE-MODULE
+ (import SKRIBE-DEBUG-MODULE SKRIBE-EVAL-MODULE)
+
+ (export default-engine default-engine-set!
+ make-engine copy-engine find-engine
+ engine-custom engine-custom-set!
+ engine-format? engine-add-writer!
+ processor-get-engine
+ push-default-engine pop-default-engine)
+)
+
+;;; Module definition is split here because this file is read by the documentation
+;;; Should be changed.
+(select-module SKRIBE-ENGINE-MODULE)
+
+(define *engines* '())
+(define *default-engine* #f)
+(define *default-engines* '())
+
+
+(define (default-engine)
+ *default-engine*)
+
+
+(define (default-engine-set! e)
+ (unless (engine? e)
+ (skribe-error 'default-engine-set! "bad engine ~S" e))
+ (set! *default-engine* e)
+ (set! *default-engines* (cons e *default-engines*))
+ e)
+
+
+(define (push-default-engine e)
+ (set! *default-engines* (cons e *default-engines*))
+ (default-engine-set! e))
+
+(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)))))
+
+
+(define (processor-get-engine combinator newe olde)
+ (cond
+ ((procedure? combinator)
+ (combinator newe olde))
+ ((engine? newe)
+ newe)
+ (else
+ olde)))
+
+
+(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 (make <engine> :ident ident :version version :format format
+ :filter filter :delegate delegate
+ :symbol-table symbol-table
+ :custom 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 ((new (shallow-clone e)))
+ (slot-set! new 'ident ident)
+ (slot-set! new 'version version)
+ (slot-set! new 'filter (or filter (slot-ref e 'filter)))
+ (slot-set! new 'delegate (or delegate (slot-ref e 'delegate)))
+ (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table)))
+ (slot-set! new 'customs (or custom (slot-ref e 'customs)))
+
+ (set! *engines* (cons new *engines*))
+ new))
+
+
+;;;
+;;; FIND-ENGINE
+;;;
+(define (%find-loaded-engine id version)
+ (let Loop ((es *engines*))
+ (cond
+ ((null? es) #f)
+ ((eq? (slot-ref (car es) 'ident) id)
+ (cond
+ ((eq? version 'unspecified) (car es))
+ ((eq? version (slot-ref (car es) 'version)) (car es))
+ (else (Loop (cdr es)))))
+ (else (loop (cdr es))))))
+
+
+(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 c (string? (cdr c)))
+ (begin
+ (skribe-load (cdr c) :engine 'base)
+ (%find-loaded-engine id version))
+ #f)))))
+
+;;;
+;;; ENGINE-CUSTOM
+;;;
+(define (engine-custom e id)
+ (let* ((customs (slot-ref e 'customs))
+ (c (assq id customs)))
+ (if (pair? c)
+ (cadr c)
+ 'unspecified)))
+
+
+;;;
+;;; ENGINE-CUSTOM-SET!
+;;;
+(define (engine-custom-set! e id val)
+ (let* ((customs (slot-ref e 'customs))
+ (c (assq id customs)))
+ (if (pair? c)
+ (set-car! (cdr c) val)
+ (slot-set! e 'customs (cons (list id val) customs)))))
+
+
+;;;
+;;; ENGINE-ADD-WRITER!
+;;;
+(define (engine-add-writer! e ident pred upred opt before action after class valid)
+ (define (check-procedure name proc arity)
+ (cond
+ ((not (procedure? proc))
+ (skribe-error ident "Illegal procedure" proc))
+ ((not (equal? (%procedure-arity proc) arity))
+ (skribe-error ident
+ (format #f "Illegal ~S procedure" name)
+ proc))))
+
+ (define (check-output name proc)
+ (and proc (or (string? proc) (check-procedure name proc 2))))
+
+ ;;
+ ;; Engine-add-writer! starts here
+ ;;
+ (unless (is-a? e <engine>)
+ (skribe-error ident "Illegal engine" e))
+
+ ;; check the options
+ (unless (or (eq? opt 'all) (list? opt))
+ (skribe-error ident "Illegal options" opt))
+
+ ;; check the correctness of the predicate
+ (check-procedure "predicate" pred 2)
+
+ ;; check the correctness of the validation proc
+ (when valid
+ (check-procedure "validate" valid 2))
+
+ ;; check the correctness of the three actions
+ (check-output "before" before)
+ (check-output "action" action)
+ (check-output "after" after)
+
+ ;; create a new writer and bind it
+ (let ((n (make <writer>
+ :ident (if (symbol? ident) ident 'all)
+ :class class :pred pred :upred upred :options opt
+ :before before :action action :after after
+ :validate valid)))
+ (slot-set! e 'writers (cons n (slot-ref e 'writers)))
+ n))
+
+;;;; ======================================================================
+;;;;
+;;;; I N I T S
+;;;;
+;;;; ======================================================================
+
+;; A base engine must pre-exist before anything is loaded. In
+;; particular, this dummy base engine is used to load the actual
+;; definition of base.
+
+(make-engine 'base :version 'bootstrap)
+
+
+(select-module STklos)
generated by cgit v1.2.3 (git 2.45.0) at 2024-06-28 06:37:38 +0000