From fc42fe56a57eace2dbdb31574c2e161f0eacf839 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 15 Jun 2005 13:00:39 +0000 Subject: Initial import of Skribe 1.2d. Initial import of Skribe 1.2d. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0 --- skribe/src/bigloo/resolve.scm | 281 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 281 insertions(+) create mode 100644 skribe/src/bigloo/resolve.scm (limited to 'skribe/src/bigloo/resolve.scm') diff --git a/skribe/src/bigloo/resolve.scm b/skribe/src/bigloo/resolve.scm new file mode 100644 index 0000000..7507560 --- /dev/null +++ b/skribe/src/bigloo/resolve.scm @@ -0,0 +1,281 @@ +;*=====================================================================*/ +;* 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))))))))))) -- cgit v1.2.3