aboutsummaryrefslogtreecommitdiff
path: root/legacy/bigloo/resolve.scm
diff options
context:
space:
mode:
Diffstat (limited to 'legacy/bigloo/resolve.scm')
-rw-r--r--legacy/bigloo/resolve.scm283
1 files changed, 283 insertions, 0 deletions
diff --git a/legacy/bigloo/resolve.scm b/legacy/bigloo/resolve.scm
new file mode 100644
index 0000000..8248a4f
--- /dev/null
+++ b/legacy/bigloo/resolve.scm
@@ -0,0 +1,283 @@
+;*=====================================================================*/
+;* 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))
+ (let ((e `((parent ,node) ,@env ,@env0)))
+ (set! body (do-resolve! body engine e))
+ 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 (proc node 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)))))))))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-07-01 15:41:31 +0000