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 /skribe/src/bigloo/resolve.scm | |
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 'skribe/src/bigloo/resolve.scm')
-rw-r--r-- | skribe/src/bigloo/resolve.scm | 281 |
1 files changed, 0 insertions, 281 deletions
diff --git a/skribe/src/bigloo/resolve.scm b/skribe/src/bigloo/resolve.scm deleted file mode 100644 index 7507560..0000000 --- a/skribe/src/bigloo/resolve.scm +++ /dev/null @@ -1,281 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/resolve.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jul 25 09:31:18 2003 */ -;* Last change : Sun Jul 11 09:17:52 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe resolve stage */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_resolve - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_bib - skribe_eval) - - (import skribe_index) - - (export (resolve! ::obj ::%engine ::pair-nil) - (resolve-children ::obj) - (resolve-children* ::obj) - (resolve-parent ::%ast ::pair-nil) - (resolve-search-parent ::%ast ::pair-nil ::procedure) - (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o) - (resolve-ident ::bstring ::obj ::%ast ::obj))) - -;*---------------------------------------------------------------------*/ -;* *unresolved* ... */ -;*---------------------------------------------------------------------*/ -(define *unresolved* #f) - -;*---------------------------------------------------------------------*/ -;* 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) - (let ((old *unresolved*)) - (let loop ((ast ast)) - (set! *unresolved* #f) - (let ((ast (do-resolve! ast engine env))) - (if *unresolved* - (loop ast) - (begin - (set! *unresolved* old) - ast))))))) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ... */ -;*---------------------------------------------------------------------*/ -(define-generic (do-resolve! ast engine env) - (if (pair? ast) - (do-resolve*! ast engine env) - ast)) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (do-resolve! node::%node engine env) - (with-access::%node node (body options parent) - (with-debug 5 'do-resolve::body - (debug-item "node=" (if (markup? node) - (markup-markup node) - (find-runtime-type node))) - (debug-item "body=" (find-runtime-type body)) - (if (not (eq? parent #unspecified)) - node - (let ((p (assq 'parent env))) - (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (if (pair? options) - (begin - (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))))) - (set! body (do-resolve! body engine env)) - node))) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ::%container ... */ -;*---------------------------------------------------------------------*/ -(define-method (do-resolve! node::%container engine env0) - (with-access::%container node (body options env parent) - (with-debug 5 'do-resolve::%container - (debug-item "markup=" (markup-markup node)) - (debug-item "body=" (find-runtime-type body)) - (debug-item "env0=" env0) - (debug-item "env=" env) - (if (not (eq? parent #unspecified)) - node - (let ((p (assq 'parent env0))) - (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (if (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))) - (set! body (do-resolve! body engine e)) - node)))) - ;; return the container - node)) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ::%document ... */ -;*---------------------------------------------------------------------*/ -(define-method (do-resolve! node::%document engine env0) - (with-access::%document node (env) - (call-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)))) - (%engine-customs engine))) - ;; return the container - node)) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ::%unresolved ... */ -;*---------------------------------------------------------------------*/ -(define-method (do-resolve! node::%unresolved engine env) - (with-debug 5 'do-resolve::%unresolved - (debug-item "node=" node) - (with-access::%unresolved node (proc parent loc) - (let ((p (assq 'parent env))) - (set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))) - (let ((res (resolve! (proc node engine env) engine env))) - (if (ast? res) (%ast-loc-set! res loc)) - (debug-item "res=" res) - (set! *unresolved* #t) - res)))) - -;*---------------------------------------------------------------------*/ -;* do-resolve! ::handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (do-resolve! node::%handle engine env) - node) - -;*---------------------------------------------------------------------*/ -;* do-resolve*! ... */ -;*---------------------------------------------------------------------*/ -(define (do-resolve*! n+ engine env) - (let loop ((n* n+)) - (cond - ((pair? n*) - (set-car! n* (do-resolve! (car n*) engine env)) - (loop (cdr n*))) - ((not (null? n*)) - (skribe-error 'do-resolve "Illegal argument" n*)) - (else - n+)))) - -;*---------------------------------------------------------------------*/ -;* resolve-children ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-children n) - (if (pair? n) - n - (list n))) - -;*---------------------------------------------------------------------*/ -;* resolve-children* ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-children* n) - (cond - ((pair? n) - (map resolve-children* n)) - ((%container? n) - (cons n (resolve-children* (%container-body n)))) - (else - (list n)))) - -;*---------------------------------------------------------------------*/ -;* resolve-parent ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-parent n e) - (with-debug 5 'resolve-parent - (debug-item "n=" n) - (cond - ((not (%ast? n)) - (let ((c (assq 'parent e))) - (if (pair? c) - (cadr c) - n))) - ((eq? (%ast-parent n) #unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) - (else - (%ast-parent n))))) - -;*---------------------------------------------------------------------*/ -;* resolve-search-parent ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-search-parent n e pred) - (with-debug 5 'resolve-search-parent - (debug-item "node=" (find-runtime-type n)) - (debug-item "searching=" pred) - (let ((p (resolve-parent n e))) - (debug-item "parent=" (find-runtime-type p) " " - (if (markup? p) (markup-markup p) "???")) - (cond - ((pred p) - p) - ((%unresolved? p) - p) - ((not p) - #f) - (else - (resolve-search-parent p e pred)))))) - -;*---------------------------------------------------------------------*/ -;* resolve-counter ... */ -;*---------------------------------------------------------------------*/ -(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))))))))))) |