diff options
| author | Ludovic Court`es | 2005-11-02 10:08:38 +0000 |
|---|---|---|
| committer | Ludovic Court`es | 2005-11-02 10:08:38 +0000 |
| commit | b76d5e1b252967521f210eac10ddbf089dde8c6a (patch) | |
| tree | 00fc81c51256991c04799d79a749bbdd5b9fad30 /legacy/stklos/resolve.stk | |
| parent | ba63b8d4780428d9f63f6ace7f49361b77401112 (diff) | |
| parent | f553cb65b157b6df9563cefa593902d59301461b (diff) | |
| download | skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.tar.gz skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.tar.lz skribilo-b76d5e1b252967521f210eac10ddbf089dde8c6a.zip | |
Cleaned up the source tree and the installation process.
Patches applied:
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-6
Cosmetic changes.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-7
Removed useless files, integrated packages.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-8
Removed useless files, integrated packages.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9
Moved the STkLos and Bigloo code to `legacy'.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-10
Installed Autoconf/Automake machinery. Fixed a few things.
* lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-11
Changes related to source-highlighting and to the manual.
git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-10
Diffstat (limited to 'legacy/stklos/resolve.stk')
| -rw-r--r-- | legacy/stklos/resolve.stk | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/legacy/stklos/resolve.stk b/legacy/stklos/resolve.stk new file mode 100644 index 0000000..91dc965 --- /dev/null +++ b/legacy/stklos/resolve.stk @@ -0,0 +1,255 @@ +;;;; +;;;; resolve.stk -- Skribe Resolve Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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: 13-Aug-2003 18:39 (eg) +;;;; Last file update: 17-Feb-2004 14:43 (eg) +;;;; + +(define-module SKRIBE-RESOLVE-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-RUNTIME-MODULE) + (export resolve! resolve-search-parent resolve-children resolve-children* + find1 resolve-counter resolve-parent resolve-ident) + +(define *unresolved* #f) +(define-generic do-resolve!) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE! +;;;; +;;;; This function iterates over an ast until all unresolved references +;;;; are resolved. +;;;; +;;;; ====================================================================== +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + (fluid-let ((*unresolved* #f)) + (let Loop ((ast ast)) + (set! *unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if *unresolved* + (Loop ast) + ast)))))) + +;;;; ====================================================================== +;;;; +;;;; D O - R E S O L V E ! +;;;; +;;;; ====================================================================== + +(define-method do-resolve! (ast engine env) + ast) + + +(define-method do-resolve! ((ast <pair>) engine env) + (let Loop ((n* ast)) + (cond + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (Loop (cdr n*))) + ((not (null? n*)) + (error 'do-resolve "Illegal argument" n*)) + (else + ast)))) + + +(define-method do-resolve! ((node <node>) engine env) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve<body> + (debug-item "body=" body) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options)))) + (slot-set! node 'body (do-resolve! body engine env)) + node))) + + + +(define-method do-resolve! ((node <container>) engine env0) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (env (slot-ref node 'env)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve<container> + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" body) + (debug-item "env0=" env0) + (debug-item "env=" env) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env0))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))) + (let ((e `((parent ,node) ,@env ,@env0))) + (slot-set! node 'body (do-resolve! body engine e))))) + node))) + + +(define-method do-resolve! ((node <document>) engine env0) + (next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (slot-ref engine 'customs))) + node) + + +(define-method do-resolve! ((node <unresolved>) engine env) + (with-debug 5 'do-resolve<unresolved> + (debug-item "node=" node) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + + (let* ((proc (slot-ref node 'proc)) + (res (resolve! (proc node engine env) engine env)) + (loc (ast-loc node))) + (when (ast? res) + (ast-loc-set! res loc)) + (debug-item "res=" res) + (set! *unresolved* #t) + res))) + + +(define-method do-resolve! ((node <handle>) engine env) + node) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (is-a? n <ast>)) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (slot-ref n 'parent) 'unspecified) + (skribe-error 'resolve-parent "Orphan node" n)) + (else + (slot-ref n 'parent))))) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-SEARCH-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" n) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" p " " + (if (is-a? p 'markup) (slot-ref p 'markup) "???")) + (cond + ((pred p) p) + ((is-a? p <unresolved>) p) + ((not p) #f) + (else (resolve-search-parent p e pred)))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-COUNTER +;;;; +;;;; ====================================================================== +;;FIXME: factoriser +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-IDENT +;;;; +;;;; ====================================================================== +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) + +) |