blob: 602a95115600828ba5742b70090aacd659c74ba8 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
;*=====================================================================*/
;* serrano/prgm/project/skribe/src/bigloo/verify.scm */
;* ------------------------------------------------------------- */
;* Author : Manuel Serrano */
;* Creation : Fri Jul 25 09:54:55 2003 */
;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */
;* Copyright : 2003-04 Manuel Serrano */
;* ------------------------------------------------------------- */
;* The Skribe verification stage */
;*=====================================================================*/
;*---------------------------------------------------------------------*/
;* The module */
;*---------------------------------------------------------------------*/
(module skribe_verify
(include "debug.sch")
(import skribe_types
skribe_lib
skribe_engine
skribe_writer
skribe_eval)
(export (generic verify ::obj ::%engine)))
;*---------------------------------------------------------------------*/
;* check-required-options ... */
;*---------------------------------------------------------------------*/
(define (check-required-options n::%markup w::%writer e::%engine)
(with-access::%markup n (required-options)
(with-access::%writer w (ident options verified?)
(or verified?
(eq? options 'all)
(begin
(for-each (lambda (o)
(if (not (memq o options))
(skribe-error (%engine-ident e)
(format "Option unsupported: ~a, supported options: ~a" o options)
n)))
required-options)
(set! verified? #t))))))
;*---------------------------------------------------------------------*/
;* check-options ... */
;* ------------------------------------------------------------- */
;* Only keywords are checked, symbols are voluntary left unchecked. */
;*---------------------------------------------------------------------*/
(define (check-options eo*::pair-nil m::%markup e::%engine)
(with-debug 6 'check-options
(debug-item "markup=" (%markup-markup m))
(debug-item "options=" (%markup-options m))
(debug-item "eo*=" eo*)
(for-each (lambda (o2)
(for-each (lambda (o)
(if (and (keyword? o)
(not (eq? o :&skribe-eval-location))
(not (memq o eo*)))
(skribe-warning/ast
3
m
'verify
(format "Engine `~a' does not support markup `~a' option `~a' -- ~a"
(%engine-ident e)
(%markup-markup m)
o
(markup-option m o)))))
o2))
(%markup-options m))))
;*---------------------------------------------------------------------*/
;* verify :: ... */
;*---------------------------------------------------------------------*/
(define-generic (verify node e)
(if (pair? node)
(for-each (lambda (n) (verify n e)) node))
node)
;*---------------------------------------------------------------------*/
;* verify ::%processor ... */
;*---------------------------------------------------------------------*/
(define-method (verify n::%processor e)
(with-access::%processor n (combinator engine body)
(verify body (processor-get-engine combinator engine e))
n))
;*---------------------------------------------------------------------*/
;* verify ::%node ... */
;*---------------------------------------------------------------------*/
(define-method (verify node::%node e)
(with-access::%node node (body options)
(verify body e)
(for-each (lambda (o) (verify (cadr o) e)) options)
node))
;*---------------------------------------------------------------------*/
;* verify ::%markup ... */
;*---------------------------------------------------------------------*/
(define-method (verify node::%markup e)
(with-debug 5 'verify::%markup
(debug-item "node=" (%markup-markup node))
(debug-item "options=" (%markup-options node))
(debug-item "e=" (%engine-ident e))
(call-next-method)
(let ((w (lookup-markup-writer node e)))
(if (%writer? w)
(begin
(check-required-options node w e)
(if (pair? (%writer-options w))
(check-options (%writer-options w) node e))
(let ((validate (%writer-validate w)))
(when (procedure? validate)
(unless (validate node e)
(skribe-warning
1
node
(format "Node `~a' forbidden here by ~a engine"
(markup-markup node)
(engine-ident e))
node)))))))
;; return the node
node))
;*---------------------------------------------------------------------*/
;* verify ::%document ... */
;*---------------------------------------------------------------------*/
(define-method (verify node::%document e)
(call-next-method)
;; verify the engine custom
(for-each (lambda (c)
(let ((i (car c))
(a (cadr c)))
(set-car! (cdr c) (verify a e))))
(%engine-customs e))
;; return the node
node)
;*---------------------------------------------------------------------*/
;* verify ::%handle ... */
;*---------------------------------------------------------------------*/
(define-method (verify node::%handle e)
node)
|
