source: project/release/4/9ML-toolkit/trunk/repr.scm @ 23838

Last change on this file since 23838 was 23838, checked in by Ivan Raikov, 10 years ago

9ML-toolit: commit octave/mlton platform

File size: 39.5 KB
Line 
1
2;;
3;; Different external representations of NineML.
4;;
5;; Copyright 2010-2011 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23(module 9ML-repr
24
25        (repr-verbose
26         sxml-value->sexpr sexpr->diagram+initial print-fragments 
27         print-eval-env print-type-env print-source-defs print-nxml 
28         generate-diagram html-report traverse-definitions)
29
30        (import scheme chicken )
31
32        (require-library srfi-1 srfi-13 data-structures extras utils files irregex mathh)
33        (import (only srfi-1 fold combine every zip unzip2 filter-map partition delete-duplicates)
34                (only srfi-13 string-downcase )
35                (only data-structures conc compose identity atom? intersperse string-intersperse ->string )
36                (only extras fprintf pp)
37                (only utils system*)
38                (only files make-pathname pathname-directory)
39                (only mathh cosh tanh log10)
40                )
41
42        (require-extension datatype static-modules miniML miniMLvalue miniMLeval signal-diagram signal-diagram-dynamics
43                           regex ssax sxml-transforms sxpath sxpath-lolevel object-graph)
44
45
46(include "SXML.scm")
47(include "SXML-to-XML.scm")
48
49(define repr-verbose (make-parameter 0))
50
51(define (d fstr . args)
52  (let ([port (current-error-port)])
53    (if (positive? (repr-verbose)) 
54        (begin (apply fprintf port fstr args)
55               (flush-output port) ) )))
56
57
58(define (run:execute explist)
59  (define (smooth lst)
60    (let ((slst (map ->string lst)))
61      (string-intersperse (cons (car slst) (cdr slst)) " ")))
62  (for-each (lambda (cmd) (system (->string cmd)))
63            (map smooth explist)))
64
65(define (run:execute* explist)
66  (define (smooth lst)
67    (let ((slst (map ->string lst)))
68      (string-intersperse (cons (car slst) (cdr slst)) " ")))
69  (for-each (lambda (cmd) (system* "~a" cmd))
70            (map smooth explist)))
71
72
73(define-syntax run
74  (syntax-rules ()
75    ((_ exp ...)
76     (begin
77       (d "running ~A ...~%" (list `exp ...))
78       (run:execute* (list `exp ...))))))
79
80(define-syntax run-
81  (syntax-rules ()
82    ((_ exp ...)
83     (begin
84       (d "running ~A ...~%" (list `exp ...))
85       (run:execute (list `exp ...))))))
86
87
88(define (enumvars expr ax)
89  (if (pair? expr)
90      (case (car expr)
91        ((cond)  (fold (lambda (x ax) (enumvars x ax)) ax (cdr expr)))
92        (else  (if (symbol? (car expr))  (fold (lambda (x ax) (enumvars x ax)) ax (cdr expr)) ax)))
93      (if (symbol? expr) (cons expr ax) ax)))
94
95(define (sexpr->function sexpr)  (make-function (enumvars sexpr '()) sexpr))
96
97
98(define (sxml-value->sexpr tree)
99    (let* ((tree 
100            (pre-post-order* 
101            tree
102            `(
103              (Tuple *macro* .
104                     ,(lambda (tag elems) 
105                        (let ((node (cons tag elems)))
106                          (let ((left (sxml:kidn-cadr 'left node))
107                                (right (sxml:kidn-cdr 'right node)))
108                            (cons left right)))))
109             
110              (Const . ,(lambda (tag elems) (car elems)))
111             
112              (label . ,(lambda (tag elems) (string->symbol (car elems))))
113             
114              (real . ,(lambda (tag elems) (car elems)))
115             
116              (nat  . ,(lambda (tag elems) (car elems)))
117             
118              (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f)))
119             
120              (null . ,(lambda (tag elems) '()))
121             
122              (*text* . ,(lambda (trigger str) str))
123             
124              (*default* . ,(lambda (tag elems) (cons tag elems)))
125              )))
126
127           (tree
128            (pre-post-order* 
129             tree
130             `(
131               (signal . ,(lambda (tag elems) (caar elems)))
132               
133               (sigfun . ,(lambda (tag elems) (car elems)))
134
135               (*text* . ,(lambda (trigger str) str))
136               
137               (*default* . ,(lambda (tag elems) (cons tag elems)))
138               )))
139
140           (tree
141            (let flatten ((tree tree))
142              (cond ((atom? tree) tree)
143                    (else (cons (flatten (car tree)) (flatten (cadr tree))))))))
144      tree))
145
146
147;; based on SRV:send-reply by Oleg Kiselyov
148(define (print-fragments b)
149  (let loop ((fragments b) (result #f))
150    (cond
151      ((null? fragments) result)
152      ((not (car fragments)) (loop (cdr fragments) result))
153      ((null? (car fragments)) (loop (cdr fragments) result))
154      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
155      ((pair? (car fragments))
156        (loop (cdr fragments) (loop (car fragments) result)))
157      ((procedure? (car fragments))
158        ((car fragments))
159        (loop (cdr fragments) #t))
160      (else
161       (display (car fragments))
162       (loop (cdr fragments) #t)))))
163
164     
165(define (print-eval-env env . rest)
166  (let-optionals rest ((output-type #f)  (component-filter identity))
167          (let ((env (filter-map component-filter env)))
168
169                 (case output-type
170                   ((sxml )
171                    (pp (eval-env->sxml env)))
172
173
174                   ((xml )
175                    (let* ((doc1   `(Toplevel ,@(eval-env->sxml env)))
176                           (doc2  (ensure-xmlns  doc1))
177                           (doc3  (ensure-xmlver doc2)))
178                      (print-fragments (generate-XML `(begin ,doc3)))))
179                       
180                   
181                   (else
182                    (for-each
183                     (lambda (x) 
184                       (let ((id (car x))
185                             (v  (cdr x)))
186                         (pp `(,id ,v))
187                         ))
188                     env))
189                   ))))
190
191
192     
193(define (print-type-env env . rest)
194  (let-optionals rest ((output-type #f) (component-filter identity))
195          (let ((env (filter-map component-filter env)))
196            (case output-type
197              ((sxml )
198               (pp (map (compose modspec->sxml cdr) env)))
199             
200              ((xml )
201               (let* ((doc1   `(Toplevel ,@(map (compose modspec->sxml cdr) env)))
202                      (doc2  (ensure-xmlns doc1))
203                      (doc3  (ensure-xmlver doc2)))
204                 (print-fragments (generate-XML `(begin ,doc3)))))
205             
206              (else  (pp env))
207             
208              ))))
209     
210(define (print-source-defs defs . rest)
211  (let-optionals rest ((output-type #f))
212
213                 (case output-type
214                   ((sxml )
215                    (pp (map moddef->sxml defs)))
216
217                   ((xml )
218                    (let* ((doc1   `(Toplevel ,@(map moddef->sxml defs)))
219                           (doc2  (ensure-xmlns doc1))
220                           (doc3  (ensure-xmlver doc2)))
221                      (print-fragments (generate-XML `(begin ,doc3)))))
222                       
223                   (else  (pp defs))
224
225                   )))
226
227(define (signal-op->mathml op)
228  (case op
229    ((add) 'plus)
230    ((sub) 'minus)
231    ((mul) 'multiply)
232    ((div) 'divide)
233    (else op)))
234
235
236(define (function->nxml f)
237  `(lambda ,(map (lambda (x) `(bvar ,x)) (function-formals f))
238     ,(signal->nxml (function-body f))))
239
240
241(define (signal->nxml tree)
242    (let recur ((sexpr tree))
243      (or (and (pair? sexpr)
244               (case (car sexpr)
245
246                 ((signal) 
247                  (let ((sexpr (cdr sexpr)))
248                   
249                    (case (car sexpr)
250                     
251                      ((signal)   
252                       (let ((name (cadr sexpr)))
253                         `(ci ,name)))
254                     
255                      ((realsig)   
256                       (let ((name (cadr sexpr))
257                             (value (caddr sexpr)))
258                         `(ci (@ (type real)) ,name)))
259                     
260                      ((boolsig)   
261                       (let ((name (cadr sexpr))
262                             (value (caddr sexpr)))
263                         `(ci (@ (type real)) ,name)))
264
265                      ((if)
266                       `(if ,(recur (cadr sexpr)) 
267                            ,(recur (caddr sexpr))
268                            ,(recur (cadddr sexpr))))
269                     
270                      ((add sub mul div gte lte gt lt)
271                       (let ((name (signal-op->mathml (car sexpr))))
272                         `(apply (,name) ,(recur (cadr sexpr)) 
273                                 ,(recur (caddr sexpr)))))
274                       
275                      ((neg log ln cosh tanh)
276                       (let ((name (signal-op->mathml (car sexpr))))
277                         `(apply (,name) ,(recur (cadr sexpr)) )))
278
279                      (else (error 'signal->nxml "invalid signal function constructor" sexpr))
280
281                      )))
282
283                 (else (map recur sexpr))
284                 )))
285
286             sexpr))
287
288
289(define (diagram->nxml sexpr)
290
291    (let recur ((sexpr sexpr))
292      (or (and (pair? sexpr)
293               (case (car sexpr)
294                 ((diagram) 
295                  (let ((sexpr (cdr sexpr)))
296                   
297                    (case (car sexpr)
298                     
299                      ((RTRANSITION) 
300                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
301                             (e (cadddr sexpr)) (ek (car (cddddr sexpr))))
302                         `(DiagramLib:Rtransition 
303                           (@ (e ,e) (e ,ek) ,(recur f) ,(recur fk)))
304                         ))
305                     
306                      ((TRANSITION) 
307                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
308                             (e (cadddr sexpr))) 
309                         `(DiagramLib:Transition 
310                           (@ (e ,e) ,(recur f) ,(recur fk)))
311                         ))
312                     
313                      ((TRANSIENT) 
314                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
315                             (e (cadddr sexpr))) 
316                         `(DiagramLib:Transient 
317                           (@ (e ,e) ,(recur f) ,(recur fk)))
318                         ))
319
320                      ((IDENTITY)       
321                       (let ((f (cadr sexpr)))
322                         `(DiagramLib:Identity ,(recur f))))
323
324                      ((RELATION)           
325                       (let ((n (cadr sexpr)) (x (caddr sexpr))
326                             (f (sexpr->function (cadddr sexpr)))
327                             (d (car (cddddr sexpr))))
328                         `(DiagramLib:Relation (@ (name ,n) (arg ,x))
329                                               ,(function->nxml f)
330                                               ,(recur d))))
331                         
332                      ((PURE)           
333                       (let ((f (sexpr->function (cadr sexpr))))
334                         `(DiagramLib:Function
335                           ,(function->nxml f))))
336
337                      ((SEQUENCE)       
338                       (let ((n1  (cadr sexpr))
339                             (n2  (caddr sexpr)))
340                         `(DiagramLib:Sequence ,(recur n1) ,(recur n2))
341                         ))
342
343                      ((UNION)         
344                       (let ((n1 (cadr sexpr))
345                             (n2 (caddr sexpr)))
346                         `(DiagramLib:Regime ,(recur n1) ,(recur n2))
347                         ))
348
349                      ((SENSE)         
350                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
351                         `(DiagramLib:Sense ,(map (lambda (s) `(signal ,s)) sns) 
352                                            ,(recur n))
353                         ))
354                                                   
355                      ((ACTUATE)       
356                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
357                         `(DiagramLib:Actuate ,(map (lambda (s) `(signal ,s)) sns) 
358                                              ,(recur n))))
359                     
360                      ((LOOP)           
361                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
362                         `(DiagramLib:Loop ,(map (lambda (s) `(signal ,s)) sns) 
363                                           ,(recur n))))
364
365                      ((ODE)           
366                       (let ((ivar (cadr sexpr)) (dvar (caddr sexpr))
367                             (rhs (cadddr sexpr)))
368                         `(DiagramLib:ODE `(independent_variable ,ivar)
369                                          `(dependent_variable ,dvar)
370                                           ,(recur rhs))))
371
372                      ((ASSIGN)         
373                       (let ((var (cadr sexpr)) 
374                             (rhs (recur (caddr sexpr))))
375                         `(DiagramLib:Assign `(variable ,var)
376                                             ,(recur rhs))))
377
378                     
379                      (else (error 'diagram->nxml "invalid diagram constructor" sexpr))
380                      )))
381
382                 (else (map recur sexpr))
383                 ))
384
385             sexpr)))
386
387
388(define (print-nxml prefix uenv)
389
390    (let (
391          (path-ss
392           `(
393             (path
394              *macro*
395              . ,(lambda (tag elems) elems))
396             
397            (Pident
398             *macro*
399             . ,(lambda (tag elems)
400                  (let ((node (cons tag elems)))
401                    (let ((name (sxml:text node)))
402                      (if (not name) (error 'print-nxml "Pident element requires text content" node))
403                      name))))
404             
405             (Pdot
406              *macro*
407              . ,(lambda (tag elems)
408                   (let ((node (cons tag elems)))
409                     (let ((name (sxml:attr node 'name)))
410                       (if (not name) (error 'print-nxml "Pdot element requires name attribute"))
411                       `(,(sxml:kids node) "." ,name)))))
412
413             
414             ,@alist-conv-rules*
415             ))
416
417
418          (moddef-ss
419           
420           `(
421             (Type_def
422              *macro*
423              . ,(lambda (tag elems)
424                   (let ((node (cons tag elems)))
425                     (let ((name (sxml:attr node 'name))
426                           (deftype (sxml:kidn* 'deftype node)))
427                       `(Type (@ (name ,name)) ,deftype)))
428                   ))
429
430             (Component
431              *macro*
432              . ,(lambda (tag elems)
433                   (let ((node (cons tag elems)))
434                       (let ((name (sxml:attr node 'name))
435                             (members ((sxpath '(Component (*or* Val Component))) `(*TOP* ,node))))
436                         `(Namespace (@ (name ,name)) . ,members)
437                         ))
438                   ))
439
440             (Val
441              *macro*
442              . ,(lambda (tag elems)
443                   (let ((node (cons tag elems)))
444                     (let* ((name (sxml:attr node 'name))
445                            (value (sxml:kid node))
446                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
447
448                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
449
450                       (cond ((and (pair? tuple-label) (equal? (car tuple-label) "diagram")) ;; value is a diagram
451                              (let* ((diagram-id (gensym 'diagram)))
452                                `(Binding (@ (name ,name)) ,(diagram->nxml (sxml-value->sexpr value)))))
453
454                             (else
455                              `(Binding (@ (name ,name))  ,value)))
456                       ))))
457             
458          ,@alist-conv-rules*
459
460          ))
461
462
463          (term-ss
464           `(
465
466             (Longid 
467              *macro*
468              . ,(lambda (tag elems)
469                   (let ((node (cons tag elems)))
470                     (sxml:kids node)
471                     )))
472
473             (Function
474              *macro*
475              . ,(lambda (tag elems)
476                   (let ((node (cons tag elems)))
477                     (let ((formal (sxml:attr node 'formal))
478                           (body   (sxml:kid node)))
479                       `(Term:Function (@ (x ,formal)) ,body)
480                       ))))
481
482
483             (Let0 
484              *macro*
485              . ,(lambda (tag elems)
486                   (let ((node (cons tag elems)))
487                     (let ((name (sxml:attr node 'name))
488                           (value (sxml:kidn-cadr 'value node))
489                           (body (sxml:kidn-cadr 'body node)))
490                       `(Term:Let (@ (name ,name)) (value ,value) (body ,body))
491                       ))))
492
493             (Apply 
494              *macro*
495              . ,(lambda (tag elems)
496                   (let ((node (cons tag elems)))
497                     (let ((left (sxml:kidn-cdr 'left node))
498                           (right (sxml:kidn-cdr 'right node)))
499                       `(Term:Apply (left ,left) (right ,right))
500                       ))))
501             
502             ,@alist-conv-rules*
503             ))
504
505
506          )
507
508  (let ( 
509        (filename    (string-append prefix ".xml"))
510        (source-defs (car uenv))
511        (type-env    (cadr uenv))
512        (eval-env    (caddr uenv)))
513
514    (let ((eval-env-sxml (eval-env->sxml eval-env))
515          (eval-env-rulesets `(,moddef-ss
516                               ,term-ss
517                               ,path-ss
518                               )))
519     
520      (let* (
521             (eval-env-sxml  (sxml-transform eval-env-sxml eval-env-rulesets))
522             (content        `(Toplevel ,eval-env-sxml))
523             )
524       
525        (with-output-to-file filename
526          (lambda () (print-fragments (generate-XML content))))
527           
528        )))
529  ))
530
531
532(define (sexpr->diagram+initial h sexpr)
533
534    (define initenv  (make-parameter '()))
535
536    (define (realsig-value x)
537      (cond ((number? x) x)
538            ((equal? 'realsig (car x)) (caddr x))
539            (else (error 'realsig-value "invalid real signal" x))))
540    (define (realsig-name x)
541      (if (and (pair? x) (equal? 'realsig (car x))) (cadr x)
542          (error 'realsig-name "invalid real signal" x)))
543    (define (boolsig-value x)
544      (cond ((boolean? x) x)
545            ((equal? 'boolsig (car x)) (caddr x))
546            (else (error 'boolsig-value "invalid boolean signal" x))))
547    (define (boolsig-name x)
548      (if (and (pair? x) (equal? 'boolsig (car x))) (cadr x)
549          (error 'boolsig-value "invalid boolean signal" x)))
550
551    (define (sigfun-eval sexpr)
552      (let recur ((sexpr sexpr))
553        (if (pair? sexpr)
554            (case (car sexpr)
555              ((realconst)   (let ((value (cadr sexpr))) value))
556              ((boolconst)   (let ((value (cadr sexpr))) value))
557              ((realsig)     (let ((name (cadr sexpr))
558                                   (value (recur (caddr sexpr))))
559                               (if (not (number? value)) (error 'realsig "real signal value is not a real" name value))
560                               (initenv (cons (cons name value) (initenv)))
561                               `(realsig ,name ,value)))
562              ((boolsig)   (let ((name (cadr sexpr))
563                                 (value0 (recur (caddr sexpr))))
564                             (let ((value (if (boolean? value0) value0
565                                              (else (error 'boolsig "boolean signal value is not a boolean" name value0)))))
566                               (initenv (cons (cons name value) (initenv)))
567                               `(boolsig ,name ,value))))
568              ((neg)       (let ((x (recur (cadr sexpr))))
569                             (- (realsig-value x))))
570              ((log)       (let ((x (recur (cadr sexpr))))
571                             (log10 (realsig-value x))))
572              ((ln)        (let ((x (recur (cadr sexpr))))
573                             (log (realsig-value x))))
574              ((cosh)      (let ((x (recur (cadr sexpr))))
575                             (cosh (realsig-value x))))
576              ((tanh)      (let ((x (recur (cadr sexpr))))
577                             (tanh (realsig-value x))))
578              ((+)       (let ((x (recur (cadr sexpr)))
579                               (y (recur (caddr sexpr))))
580                           (+ (realsig-value x) (realsig-value y))))
581              ((-)       (let ((x (recur (cadr sexpr))) 
582                               (y (recur (caddr sexpr))))
583                           (- (realsig-value x) (realsig-value y))))
584              ((*)       (let ((x (recur (cadr sexpr))) 
585                               (y (recur (caddr sexpr))))
586                           (* (realsig-value x) (realsig-value y))))
587              ((/)       (let ((x (recur (cadr sexpr))) 
588                               (y (recur (caddr sexpr))))
589                           (/ (realsig-value x) (realsig-value y))))
590              ((>=)       (let ((x (recur (cadr sexpr))) 
591                                (y (recur (caddr sexpr))))
592                            (>= (realsig-value x) (realsig-value y))))
593              ((<=)       (let ((x (recur (cadr sexpr))) 
594                                (y (recur (caddr sexpr))))
595                            (<= (realsig-value x) (realsig-value y))))
596              ((>)        (let ((x (recur (cadr sexpr))) 
597                                (y (recur (caddr sexpr))))
598                            (> (realsig-value x) (realsig-value y))))
599              ((<)        (let ((x (recur (cadr sexpr))) 
600                                (y (recur (caddr sexpr))))
601                            (< (realsig-value x) (realsig-value y))))
602              (else (map recur sexpr))
603              ) sexpr)))
604
605
606    (let ((diagram
607           (let recur ((sexpr sexpr))
608             (if (pair? sexpr)
609                 (case (car sexpr)
610                   
611                   ((diagram) 
612                    (let ((sexpr (cdr sexpr)))
613                      (case (car sexpr)
614                       
615                        ((IDENTITY)       (IDENTITY (recur (cadr sexpr))))
616                        ((PURE)           (let ((f  (sexpr->function (cadr sexpr))))  (PURE f)))
617                        ((SEQUENCE)       (SEQUENCE (recur (cadr sexpr)) (recur (caddr sexpr))))
618                        ((UNION)          (UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
619                        ((SENSE)          (SENSE (cadr sexpr) (recur (caddr sexpr))))
620                        ((ACTUATE)        (ACTUATE (cadr sexpr) (recur (caddr sexpr))))
621                        ((LOOP)           (LOOP (cadr sexpr) (recur (caddr sexpr))))
622                       
623                        ((TRANSIENT)      (TRANSIENT (recur (cadr sexpr)) (recur (caddr sexpr))
624                                                     (recur (cadddr sexpr))))
625                        ((TRANSITION)     (TRANSITION (recur (cadr sexpr)) (recur (caddr sexpr))
626                                                      (recur (cadddr sexpr))))
627                        ((RTRANSITION)    (RTRANSITION (recur (cadr sexpr)) (recur (caddr sexpr))
628                                                       (recur (cadddr sexpr))
629                                                       (recur (cadddr (cdr sexpr)))))
630                       
631                        ((ODE)            (let ((deps  (map recur (cadr sexpr)))
632                                                (indep (recur (caddr sexpr)))
633                                                (tstep (recur (cadddr sexpr)))
634                                                (rhs   (cadddr (cdr sexpr))))
635                                           
636                                            (if (not (equal? tstep h))
637                                                (error 'sexpr->diagram "mismatch between independent variable step of ODE and IVP" h tstep))
638                                           
639                                            (let-values (((rhs-list relation-list)
640                                                          (let rhs-recur ((rhs-list '()) (relation-list '()) (rhs rhs))
641                                                            (case (car rhs)
642                                                              ((diagram)
643                                                               (let ((d (cdr rhs)))
644                                                                 (case (car d)
645                                                                   ((UNION) 
646                                                                    (let-values (((rhs-list1 relation-list1) 
647                                                                                  (rhs-recur rhs-list relation-list (cadr d))))
648                                                                      (rhs-recur rhs-list1 relation-list1 (caddr d))))
649                                                                   ((PURE)     
650                                                                    (let ((expr (recur (cadr d))))
651                                                                      (values (cons expr rhs-list) relation-list)))
652                                                                   ((RELATION) 
653                                                                    (let ((r (cdr d)))
654                                                                      (rhs-recur rhs-list (cons (list (car r) (list (cadr r)) (recur (caddr r))) relation-list) (cadddr r))))
655                                                                   (else (error 'sexpr->diagram "invalid ODE subelement" d)))))
656                                                              (else
657                                                               (error 'sexpr->diagram "invalid ODE subelement" rhs))))))
658                                              (make-dae-system h indep (append (reverse relation-list) (zip deps (reverse rhs-list))))
659                                              )))
660                       
661                        ((ASSIGN)         (let ((vars  (cadr sexpr))
662                                                (rhs   (caddr sexpr)))
663                                            (let ((rhs-list
664                                                   (let rhs-recur ((rhs-list '()) (rhs rhs))
665                                                     (case (car rhs)
666                                                       ((diagram)
667                                                        (let ((d (cdr rhs)))
668                                                          (case (car d)
669                                                            ((UNION)  (rhs-recur (rhs-recur rhs-list  (cadr d)) (caddr d)))
670                                                            ((PURE)   (cons (recur (cadr d)) rhs-list))
671                                                            (else (error 'sexpr->diagram "invalid ASSIGN subelement" d)))))
672                                                       (else (error 'sexpr->diagram "invalid ASSIGN subelement" rhs))))))
673                                             
674                                              (make-assign-system (zip vars (reverse rhs-list))))))
675                       
676                        ((RELATION)      (let ((n (cadr sexpr)) (x (caddr sexpr))
677                                               (f (sexpr->function (recur (cadddr sexpr)))))
678                                           (RELATION (list n x f) (recur (cadddr (cdr sexpr))))))
679                       
680                        (else             (error 'sexpr->diagram "invalid diagram constructor" sexpr))
681                        )))
682                   
683                   ((relation)    (let ((op (cadr sexpr))) (cons op (map recur (cddr sexpr)))))
684                   
685                   ((realsig)     (let ((name (cadr sexpr))
686                                        (value (sigfun-eval (caddr sexpr))))
687                                    (if (not (number? value)) (error 'realsig "real signal value is not a real" name value))
688                                    (initenv (cons (cons name value) (initenv)))
689                                    name))
690
691                   ((realconst)   (cadr sexpr))
692                   
693                   ((boolsig)   (let ((name (cadr sexpr))
694                                      (value0 (sigfun-eval (caddr sexpr))))
695                                  (let ((value (if (boolean? value0) value0
696                                                   (case (car value0) 
697                                                     ((boolconst) (cadr value0))
698                                                     (else (error 'boolsig "boolean signal value is not a boolean" name value0))))))
699                                    (initenv (cons (cons name value) (initenv)))
700                                    name)))
701
702                   ((boolconst)   (if (cadr sexpr) 'true 'false))
703                   
704                   (else (map recur sexpr)))
705                 sexpr)
706          )))
707    (initenv (delete-duplicates (initenv) (lambda (x y) (equal? (car x) (car y)))))
708    (list diagram (initenv))))
709
710
711(define (generate-diagram prefix diagram-id tree)
712
713    (let ((sexpr (sxml-value->sexpr tree)))
714
715      (reset-graph)
716      (let recur ((sexpr sexpr))
717        (or (and (pair? sexpr)
718                 (case (car sexpr)
719                        ((diagram) 
720                         (let ((sexpr (cdr sexpr)))
721
722                            (case (car sexpr)
723
724                              ((RTRANSITION) 
725                                (let ((f (cadr sexpr)) (fk (caddr sexpr))
726                                      (e (recur (cadddr sexpr))) (ek (recur (car (cddddr sexpr)))))
727                                  (let ((node (register-node (gensym 'rtransition)))
728                                        (fnode (recur f))
729                                        (fknode (recur fk)))
730                                    (set-label node "RTRANSITION")
731                                    (let ((edge1  (register-edge node fnode))
732                                          (edge2  (register-edge node fknode)))
733                                      (set-label edge1 e)
734                                      (set-label edge2 ek)
735                                      node
736                                      ))))
737                               
738                              ((TRANSITION) 
739                                (let ((f (cadr sexpr)) (fk (caddr sexpr))
740                                      (e (recur (cadddr sexpr))) )
741                                  (let ((node (register-node (gensym 'transition)))
742                                        (fnode (recur f))
743                                        (fknode (recur fk)))
744                                    (set-label node "TRANSITION")
745                                    (let ((edge1  (register-edge node fnode)))
746                                      (set-label edge1 e)
747                                      node
748                                      ))))
749                               
750                              ((TRANSIENT) 
751                                (let ((f (cadr sexpr)) (fk (caddr sexpr))
752                                      (e (recur (cadddr sexpr))) )
753                                  (let ((node (register-node (gensym 'transient)))
754                                        (fnode (recur f))
755                                        (fknode (recur fk)))
756                                    (set-label node "TRANSIENT")
757                                    (let ((edge1  (register-edge node fnode)))
758                                      (set-label edge1 e)
759                                      node
760                                      ))))
761                               
762                               ((IDENTITY)       (let ((n1 (recur (cadr sexpr))))
763                                                   (let ((node (register-node (gensym 'IDENTITY))))
764                                                     (set-label node "IDENTITY")
765                                                     (let ((edge1 (register-edge node n1)))
766                                                       (set-label edge1 "n1")
767                                                       node))))
768                               ((PURE)           (let ((f (sexpr->function (cadr sexpr))))
769                                                   (let ((node (register-node (gensym 'function))))
770                                                     (set-label node (sprintf "fn ~A => ~A" 
771                                                                              (function-formals f) 
772                                                                              (function-body f)))
773                                                     node)))
774                               ((SEQUENCE)       (let ((n1 (recur (cadr sexpr))) 
775                                                       (n2 (recur (caddr sexpr))))
776                                                   (let ((node (register-node (gensym 'sequence))))
777                                                     (set-label node "SEQUENCE")
778                                                     (let ((edge1 (register-edge node n1))
779                                                           (edge2 (register-edge node n2)))
780                                                       (set-label edge1 "n1")
781                                                       (set-label edge1 "n2")
782                                                       node
783                                                       ))))
784                               ((UNION)          (let ((n1 (recur (cadr sexpr))) 
785                                                       (n2 (recur (caddr sexpr))))
786                                                   (let ((node (register-node (gensym 'UNION))))
787                                                     (set-label node "UNION")
788                                                     (let ((edge1 (register-edge node n1))
789                                                           (edge2 (register-edge node n2)))
790                                                       (set-label edge1 "n1")
791                                                       (set-label edge1 "n2")
792                                                       node
793                                                       ))))
794                               ((SENSE)          (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
795                                                   (let ((node (register-node (gensym 'SENSE))))
796                                                     (set-label node (sprintf "SENSE ~A" sns))
797                                                     (let ((edge (register-edge node n)))
798                                                       node
799                                                       ))))
800                                                   
801                               ((ACTUATE)        (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
802                                                   (let ((node (register-node (gensym 'ACTUATE))))
803                                                     (set-label node (sprintf "ACTUATE ~A" sns))
804                                                     (let ((edge (register-edge node n)))
805                                                       node
806                                                       ))))
807                               ((LOOP)           (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
808                                                   (let ((node (register-node (gensym 'LOOP))))
809                                                     (set-label node (sprintf "LOOP ~A" sns))
810                                                     (let ((edge (register-edge node n)))
811                                                       node
812                                                       ))))
813                               ((ODE)            (let ((ivar (cadr sexpr)) (dvar (caddr sexpr))
814                                                       (rhs (recur (cadddr sexpr))))
815                                                   (let ((node (register-node (gensym 'ODE))))
816                                                     (set-label node (sprintf "D (~A ~A) = ~A" dvar ivar rhs))
817                                                     node
818                                                     )))
819                               ((ASSIGN)         (let ((var (cadr sexpr)) 
820                                                       (rhs (recur (caddr sexpr))))
821                                                   (let ((node (register-node (gensym 'ASSGIN))))
822                                                     (set-label node (sprintf "~A = ~A" var rhs))
823                                                     node
824                                                     )))
825
826                               (else (error 'generate-diagram "invalid diagram constructor" sexpr)))))
827
828                        ((realsig)   (let ((name (cadr sexpr))
829                                           (value (caddr sexpr)))
830                                       name))
831
832                        ((boolsig)   (let ((name (cadr sexpr))
833                                           (value (caddr sexpr)))
834                                       name))
835
836                        (else (map recur sexpr))
837                        ))
838             sexpr))
839
840      (let* ((dir (pathname-directory prefix))
841             (dot-path (make-pathname dir (string-append (->string diagram-id) ".dot")))
842             (png-path (make-pathname dir (string-append (->string diagram-id) ".png"))))
843        (with-output-to-file  dot-path
844          (lambda ()
845            (render-graph/dot (current-output-port))
846            ))
847       
848        (run (dot -Tpng ,dot-path > ,png-path))
849        )
850       
851      ))
852
853
854(define variable-names (make-parameter '()))
855
856
857(define (html-report prefix uenv #!key (value-hook #f))
858
859  (let-syntax
860      (
861       (line (syntax-rules ()
862               ((_ x ...) (list (list 'span '(@ (class "hl_line")) `x ...) nl))))
863       (code (syntax-rules ()
864               ((_ x ...) (list 'code '(@ (class "hl_code")) `x ...))))
865       )
866
867    (let (
868          (path-ss
869           `(
870             (path
871              *macro*
872              . ,(lambda (tag elems) elems))
873             
874            (Pident
875             *macro*
876             . ,(lambda (tag elems)
877                  (let ((node (cons tag elems)))
878                    (let ((name (sxml:text node)))
879                      (if (not name) (error 'html-report "Pident element requires text content" node))
880                      name))))
881             
882             (Pdot
883              *macro*
884              . ,(lambda (tag elems)
885                   (let ((node (cons tag elems)))
886                     (let ((name (sxml:attr node 'name)))
887                       (if (not name) (error 'html-report "Pdot element requires name attribute"))
888                       `(,(sxml:kids node) "." ,name)))))
889
890             
891             ,@alist-conv-rules*
892             ))
893
894          (simple-type-ss
895           `(
896             (Tcon
897              *macro*
898              . ,(lambda (tag elems)
899                   (let ((node (cons tag elems)))
900                     (let ((path (sxml:kidn-cadr 'path node))
901                           (ts (map cdr (sxml:kidsn 't node))))
902                       (cond
903                        ((equal? path `(pident (@ (name "->"))))
904                         `(,(car ts) " -> " ,(cadr ts)))
905                        ((pair? ts)
906                         `("(" ,@(intersperse ts " ") ") " ,path))
907                        (else path))))))
908             
909             
910             (Tvar
911              *macro*
912              . ,(lambda (tag elems)
913                   (let ((node (cons tag elems)))
914                     (let ((repres (sxml:kidn 'repres node)))
915                       (cond
916                        (repres (cdr repres))
917                        (else (let* ((name (or (assq elems (variable-names))))
918                                     (name (if (not name)
919                                               (let* ((n  (+ 1 (length (variable-names))))
920                                                     (s  (string-append "'t" (number->string n))))
921                                                 (variable-names (cons (list n s) (variable-names)))
922                                                 s))))
923                                name)))))))
924             
925             ,@alist-conv-rules*
926             ))
927
928          (const-ss
929           `(
930
931             (Const
932              *macro*
933              . ,(lambda (tag elems) 
934                   (let ((node (cons tag elems)))
935                     (sxml:kids node))))
936
937             (label 
938              *macro*
939              . ,(lambda (tag elems)
940                   (let ((node (cons tag elems)))
941                     (code ,(sxml:text node)))))
942                   
943             ,@alist-conv-rules*
944             ))
945           
946          (typedef-ss
947           `(
948             (Valtype
949              *macro* 
950              . ,(lambda (tag elems)
951                   (let ((body (sxml:kidn-cdr 'body elems)))
952                     body)
953                   ))
954
955             (Deftype 
956               *macro*
957               . ,(lambda (tag elems)
958                    (let ((node (cons tag elems)))
959                      (let ((b (sxml:kidn-cdr 'body node)))
960                        b)
961                      )))
962
963             ,@alist-conv-rules*
964
965             ))
966         
967          (modspec-ss
968           `(
969             (Value_sig 
970              *macro*
971              . ,(lambda (tag elems)
972                   (let ((node (cons tag elems)))
973                     (let ((name (sxml:attr node 'name)))
974                       (if (not name) (error 'type-env-report "value_sig element requires name attribute"))
975                       (line "Value " (b ,name) " : " ,(sxml:kids node))))))
976             
977             
978             (Type_sig 
979              *macro*
980              . ,(lambda (tag elems)
981                   (let ((node (cons tag elems)))
982                     (let ((name (sxml:attr node 'name)))
983                       (if (not name) (error 'type-env-report "type_sig element requires name attribute"))
984                       (line "Type " (b ,name) " = " ,(sxml:kids node))))))
985             
986             (Typedecl
987              *macro* 
988              . ,(lambda (tag elems)
989                   (let ((node (cons tag elems)))
990                     (let ((m (sxml:kidn* 'manifest node)))
991                       m)
992                     )))
993             
994             (manifest 
995              *macro*
996              . ,(lambda (tag elems)
997                   (let ((node (cons tag elems)))
998                     (let ((dt (sxml:kidn* 'deftype node)))
999                       dt)
1000                     )))
1001             
1002             (Module_sig 
1003              *macro*
1004              . ,(lambda (tag elems)
1005                   (let ((node (cons tag elems)))
1006                     (let ((name (sxml:attr node 'name)))
1007                       (if (not name) (error 'type-env-report "module_sig element requires name attribute"))
1008                       `(,(line "Component signature " (b ,name) " : ") 
1009                         ,(sxml:kids node))))))
1010             
1011             (Signature
1012              *macro* 
1013              . ,(lambda (tag elems)
1014                   (let ((node (cons tag elems)))
1015                     `(ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))
1016             
1017             
1018             (Functorty
1019              *macro* 
1020              . ,(lambda (tag elems)
1021                   (let ((node (cons tag elems)))
1022                     (let ((name (sxml:attr node 'name)))
1023                       (if (not name) (error 'type-env-report "functorty elements requires name attribute"))
1024                       `("Functor " (b ,name)
1025                         (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))))
1026             
1027             
1028             ,@alist-conv-rules*
1029             ))
1030
1031          (moddef-ss
1032           
1033           `(
1034             (Type_def
1035              *macro*
1036              . ,(lambda (tag elems)
1037                   (let ((node (cons tag elems)))
1038                     (let ((name (sxml:attr node 'name))
1039                           (deftype (sxml:kidn* 'deftype node)))
1040                       (code  "type " ,name " = " ,deftype)
1041                   ))))
1042
1043             (Component
1044              *macro*
1045              . ,(lambda (tag elems)
1046                   (let ((node (cons tag elems)))
1047                     (let ((name (sxml:attr node 'name)))
1048                       (if (not name) (error 'type-env-report "component element requires name attribute"))
1049                       `(,(line "Component " (b ,name) " = ") (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node))))))))
1050
1051             (Val
1052              *macro*
1053              . ,(lambda (tag elems)
1054                   (let ((node (cons tag elems)))
1055                     (let* ((name (sxml:attr node 'name))
1056                            (value (sxml:kid node))
1057                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
1058
1059                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
1060
1061                       (cond ((and value-hook (pair? tuple-label) (value-hook prefix name (car tuple-label) value)) =>
1062                              (lambda (x) `(,(line "binding " (b ,name) " = ") (p ,x))))
1063
1064                             (else
1065                              `(,(line "binding " (b ,name) " = ") ,value)))
1066                       ))))
1067
1068             (Prim
1069              *macro*
1070              . ,(lambda (tag elems) 
1071                  (code "primitive procedure")))
1072             
1073             (null
1074              *macro*
1075              . ,(lambda (tag elems) 
1076                  (code "null")))
1077             
1078             (Tuple
1079              *macro*
1080              . ,(lambda (tag elems)
1081                   (let ((node (cons tag elems)))
1082                     (let ((left (sxml:kidn-cadr 'left node))
1083                           (right (sxml:kidn-cdr 'right node)))
1084                        `( " ( "  ,left " " ,@right " ) " )
1085                        ))))
1086             
1087             (Closure
1088              *macro*
1089              . ,(lambda (tag elems)
1090                   (let ((node (cons tag elems)))
1091                     (let ((body (sxml:kidn-cdr 'body node))
1092                           (env (sxml:kidn-cdr 'env node)))
1093                       `(,(line "Closure: ") ,@body ,(line "where ") ,env)))))
1094
1095             
1096             
1097          ,@alist-conv-rules*
1098
1099          ))
1100
1101
1102          (term-ss
1103           `(
1104
1105             (Longid 
1106              *macro*
1107              . ,(lambda (tag elems)
1108                   (let ((node (cons tag elems)))
1109                     (sxml:kids node))))
1110
1111             (Function
1112              *macro*
1113              . ,(lambda (tag elems)
1114                   (let ((node (cons tag elems)))
1115                     (let ((formal (sxml:attr node 'formal)))
1116                       (let-values (((formals body)
1117                                     (let recur ((formals (list formal)) 
1118                                                 (body (sxml:kid node)))
1119                                       (case (car body) 
1120                                         ((function)
1121                                          (recur 
1122                                           (cons (sxml:attr body 'formal) formals)
1123                                           (sxml:kid body)))
1124                                         (else (values (reverse formals) body))))))
1125                         `(,(line (code "Function " ,(intersperse formals " ") " => ")) 
1126                           ,body))
1127                       ))))
1128
1129
1130             (Let0 
1131              *macro*
1132              . ,(lambda (tag elems)
1133                   (let ((node (cons tag elems)))
1134                     (let ((name (sxml:attr node 'name))
1135                           (value (sxml:kidn-cadr 'value node))
1136                           (body (sxml:kidn-cadr 'body node)))
1137                       `(,(line (code "binding " (b ,name) " = ") ,value)
1138                         ,body)))))
1139             
1140             (Apply 
1141              *macro*
1142              . ,(lambda (tag elems)
1143                   (let ((node (cons tag elems)))
1144                     (let ((left (sxml:kidn-cdr 'left node))
1145                           (right (sxml:kidn-cdr 'right node)))
1146                       (code ,left " (" ,right ") ")))))
1147             
1148             ,@alist-conv-rules*
1149             ))
1150
1151
1152          )
1153
1154  (let ((filename (string-append prefix ".html"))
1155        (source-defs (car uenv))
1156        (type-env    (cadr uenv))
1157        (eval-env    (caddr uenv)))
1158
1159
1160    (let ((type-env-sxml (map (compose modspec->sxml cdr) type-env))
1161          (eval-env-sxml (eval-env->sxml eval-env))
1162          (type-env-rulesets `(,modspec-ss
1163                               ,typedef-ss
1164                               ,simple-type-ss
1165                               ,path-ss
1166                               ))
1167          (eval-env-rulesets `(,moddef-ss
1168                               ,modspec-ss
1169                               ,typedef-ss
1170                               ,term-ss
1171                               ,const-ss
1172                               ,simple-type-ss
1173                               ,path-ss
1174                               )))
1175     
1176      (with-output-to-file filename
1177        (lambda ()
1178          (let* ((type-env-shtml (sxml-transform type-env-sxml type-env-rulesets))
1179                 (eval-env-shtml (sxml-transform eval-env-sxml eval-env-rulesets))
1180                 (content        `(html:begin ,prefix (body (section* 1 ,prefix)
1181                                                            (toc)
1182                                                            (section 2 "Type environment") 
1183                                                            ,type-env-shtml 
1184                                                            (section 2 "Value environment")
1185                                                            ,eval-env-shtml
1186                                                            )))
1187                 (internal-link
1188                  (lambda (r)
1189                    (post-order 
1190                     r
1191                     `(
1192                       (*default* . ,(lambda (tag elems) (cons tag elems)))
1193                       
1194                       (*text* . ,(lambda (trigger str) 
1195                                    (string-substitute* (string-downcase str) 
1196                                                        '(("[^A-Za-z0-9_ \t-]" . "")
1197                                                         ("[ \t]+" . "-"))))))
1198                     )))
1199                 )
1200
1201            (print-fragments
1202             (generate-XML content
1203                           rulesets:
1204                           `(((html:begin . ,(lambda (tag elems)
1205                                               (let ((title (car elems))
1206                                                     (elems (cdr elems)))
1207                                                 (list "<HTML><HEAD><TITLE>" title "</TITLE></HEAD>"
1208                                                       "<meta http-equiv=\"Content-Style-Type\" content=\"text/css\" />"
1209                                                       "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />"
1210
1211                                                       "<link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />"
1212                                                       elems
1213                                                       "</HTML>"))))
1214                              (section
1215                               *macro*
1216                               . ,(lambda (tag elems)
1217                                    (let ((level (car elems))
1218                                          (head-word (cadr elems))
1219                                          (contents (cddr elems)))
1220                                      (cond ((and (integer? level) head-word)
1221                                             `((,(string->symbol (string-append "h" (number->string level)))
1222                                                (@ (id ,(internal-link head-word)))
1223                                                ,head-word ) . ,contents))
1224                                            (else
1225                                             (error 'html-transformation-rules
1226                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1227                                           )))
1228
1229                              (section*
1230                               *macro*
1231                               . ,(lambda (tag elems)
1232                                    (let ((level (car elems))
1233                                          (head-word (cadr elems))
1234                                          (contents (cddr elems)))
1235                                      (cond ((and (integer? level) head-word)
1236                                             `((,(string->symbol (string-append "h" (number->string level)))
1237                                                ,head-word ) . ,contents))
1238                                            (else
1239                                             (error 'html-transformation-rules
1240                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1241                                      )))
1242
1243
1244                              (toc ;; Re-scan the content for "section" tags and generate
1245                               *macro*
1246                               . ,(lambda (tag rest) ;; the table of contents
1247                                    `(div (@ (id "toc"))
1248                                          ,rest
1249                                          (ol ,(let find-sections ((content content))
1250                                                 (cond
1251                                                  ((not (pair? content)) '())
1252                                                  ((pair? (car content))
1253                                                   (append (find-sections (car content))
1254                                                           (find-sections (cdr content))))
1255                                                  ((eq? (car content) 'section)
1256                                                   (let* ((level (cadr content))
1257                                                          (head-word (caddr content))
1258                                                          (href (conc "#" (internal-link head-word)))
1259                                                          (subsections (find-sections (cdddr content))))
1260                                                     (cond ((and (integer? level) head-word)
1261                                                            `((li (a (@ (href ,href)) ,head-word)
1262                                                                  ,@(if (null? subsections)
1263                                                                        '()
1264                                                                        `((ol ,subsections))))))
1265                                                           (else
1266                                                            (error 'html-transformation-rules
1267                                                                   "section elements must be of the form (section level head-word . contents)")))))
1268                                                  (else (find-sections (cdr content)))))))))
1269
1270
1271                              ,@alist-conv-rules*
1272                              ))
1273                           protect: #t
1274                           ))
1275           
1276            )))
1277
1278          ;;eval-env-sxml
1279      )))))
1280
1281
1282
1283(define (traverse-definitions prefix uenv #!key (type-hook #f) (component-hook #f) (value-hook #f))
1284
1285  (let (
1286          (moddef-ss
1287           
1288           `(
1289             (Type_def
1290              *macro*
1291              . ,(lambda (tag elems)
1292                   (let ((node (cons tag elems)))
1293                     (let ((name (sxml:attr node 'name))
1294                           (deftype (sxml:kidn* 'deftype node)))
1295                       (and type-hook (type-hook prefix name deftype))
1296                   ))))
1297
1298             (Component
1299              *macro*
1300              . ,(lambda (tag elems)
1301                   (let ((node (cons tag elems)))
1302                     (let ((name (sxml:attr node 'name)))
1303                       (if (not name) (error 'process-definition "component element requires name attribute"))
1304                       (and component-hook (component-hook prefix name (sxml:kid node)))
1305                       ))))
1306
1307             (Val
1308              *macro*
1309              . ,(lambda (tag elems)
1310                   (let ((node (cons tag elems)))
1311                     
1312                     (let* ((name (sxml:attr node 'name))
1313                            (value (sxml:kid node))
1314                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
1315
1316                       (if (not name) (error 'process-definitions "binding element requires name attribute"))
1317
1318                       (cond ((and value-hook (pair? tuple-label) (value-hook prefix name (car tuple-label) value)) =>
1319                              (lambda (x) x))
1320
1321                             (else #f))
1322                       ))))
1323             
1324             ,@alist-conv-rules*
1325         
1326             (*text* . ,(lambda (trigger str) str))
1327             
1328             (*default* . ,(lambda (tag elems) (cons tag elems)))
1329             
1330             ))
1331          )
1332
1333  (let ((source-defs (car uenv))
1334        (type-env    (cadr uenv))
1335        (eval-env    (caddr uenv)))
1336    (let recur ((eval-env eval-env))
1337      (if (pair? eval-env)
1338          (let ((entry (car eval-env)))
1339            (let ((v (cdr entry)))
1340              (cond ((MLvalue? v) 
1341                     (let ((sxml-value (MLvalue->sxml v)))
1342                       (let* ((name (sxml:attr sxml-value 'name))
1343                              (value (sxml:kid sxml-value))
1344                              (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value))))
1345                         (if (pair? tuple-label)
1346                             (value-hook prefix name (car tuple-label) sxml-value)))))
1347                    (else
1348                     (if (modval? v)
1349                         (cases modval v
1350                                (Structure_v (env) (recur env)))))))
1351            (recur (cdr eval-env))
1352            ))
1353      ))
1354  ))
1355
1356     
1357
1358)
Note: See TracBrowser for help on using the repository browser.