Changeset 25552 in project
- Timestamp:
- 11/22/11 17:23:57 (9 years ago)
- Location:
- release/4/9ML-toolkit/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/9ML-toolkit/trunk/parse.scm
r25439 r25552 375 375 376 376 377 (define nineml-xmlns "http:// nineml.org/9ML/0.1")377 (define nineml-xmlns "http://www.NineML.org/9ML/1.0") 378 378 379 379 (define (parse-al-sxml-dynamics sxml) -
release/4/9ML-toolkit/trunk/ulp.scm
r25326 r25552 21 21 22 22 23 (require-extension setup-api extras posix utils files data-structures tcp srfi-1 srfi-13 )23 (require-extension setup-api extras posix utils files data-structures tcp srfi-1 srfi-13 irregex) 24 24 (require-extension datatype matchable static-modules miniML miniMLsyntax miniMLvalue miniMLeval) 25 25 (require-extension signal-diagram ssax sxml-transforms sxpath sxpath-lolevel object-graph uri-generic getopt-long ) 26 26 (require-extension 9ML-parse 9ML-repr ) 27 27 28 (define (string-match rx str) 29 (and-let* ((m (irregex-match rx str))) 30 (let loop ((i (irregex-match-num-submatches m)) 31 (res '())) 32 (if (fx<= i 0) 33 (cons str res) 34 (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))) 35 36 37 (define lookup-def 38 (lambda (k lst . rest) 39 (let-optionals rest ((default #f)) 40 (alist-ref k lst eq? default)))) 28 41 29 42 (define (safe-car x) (and (pair? x) (car x))) … … 51 64 52 65 53 (define init-scope (make-parameter st-empty))54 (define init-type-env (make-parameter env-empty))55 (define init-eval-env (make-parameter env-empty))66 (define current-scope (make-parameter st-empty)) 67 (define current-type-env (make-parameter env-empty)) 68 (define current-eval-env (make-parameter env-empty)) 56 69 57 70 58 71 (define (enter-typedecl id decl) 59 ( init-scope (st-enter-type id (init-scope)))60 ( init-type-env (env-add-type id decl (init-type-env))))72 (current-scope (st-enter-type id (current-scope))) 73 (current-type-env (env-add-type id decl (current-type-env)))) 61 74 62 75 (define (enter-valtype name ty) 63 76 (let ((id (ident-create name))) 64 ( init-scope (st-enter-value id (init-scope)))65 ( init-type-env (env-add-value id ty (init-type-env)))))77 (current-scope (st-enter-value id (current-scope))) 78 (current-type-env (env-add-value id ty (current-type-env))))) 66 79 67 80 (define (enter-val name val) 68 81 (let ((id (or (and (ident? name) name) (ident-create name)))) 69 ( init-eval-env (ident-add id val (init-eval-env)))))82 (current-eval-env (ident-add id val (current-eval-env))))) 70 83 71 84 (core-initialize enter-typedecl enter-valtype) … … 74 87 75 88 (define (enter-module id mty) 76 ( init-scope (st-enter-module id (init-scope)))77 ( init-type-env (env-add-module id mty (init-type-env))))89 (current-scope (st-enter-module id (current-scope))) 90 (current-type-env (env-add-module id mty (current-type-env)))) 78 91 79 92 … … 115 128 (output-xml "sets output format to XML") 116 129 117 (platform "simulation platform (one of chicken, mlton, octave, octave/mlton)"130 (platform "simulation platform (one of chicken, chicken/cvode, mlton, octave, octave/mlton)" 118 131 (value (required PLATFORM) 119 132 (predicate … … 121 134 (let ((s (string->symbol (string-downcase x)))) 122 135 (case s 123 ((chicken mlton octave octave/ml) s)136 ((chicken chicken/cvode mlton octave octave/mlton) s) 124 137 (else (error 'ivp "unrecognized platform" x)))))) 125 138 (transformer ,string->symbol) … … 160 173 (define simulation-platform (make-parameter #f)) 161 174 175 162 176 (define (d fstr . args) 163 177 (let ([port (current-error-port)]) … … 165 179 (begin (apply fprintf port fstr args) 166 180 (flush-output port) ) ))) 181 182 183 (define (sxml-string->uri s) 184 (let ((ss (string-trim-both s))) 185 (uri-reference ss))) 167 186 168 187 … … 272 291 (d "requesting ~s ...~%" locn) 273 292 (display 274 (make-HTTP-GET/1.1 locn *user-agent*host port: port accept: "*/*")293 (make-HTTP-GET/1.1 locn "NineML" host port: port accept: "*/*") 275 294 out) 276 295 (flush-output out) … … 327 346 328 347 329 330 (define (parse-xml fpath) 331 (with-input-from-file fpath 332 (lambda () (cons '*TOP* (ssax:xml->sxml (current-input-port) `()))) 348 (define (fetch uri) 349 (case (uri-scheme uri) 350 ((http) 351 (let-values (((fd temp-path) (file-mkstemp "/tmp/9ML.XXXXXX"))) 352 (let ((data (and (http-fetch uri temp-path) (read-all temp-path)))) 353 (file-close fd) 354 data))) 355 ((file) 356 (let ((data (read-all (string-concatenate (map ->string (uri-path uri)))))) 357 data)) 358 (else (error 'fetch "unknown scheme" (uri-scheme uri))) 333 359 )) 334 360 361 362 363 (define (parse-xml str) 364 (call-with-input-string str 365 (lambda (in) 366 (ssax:xml->sxml in `((nml . ,nineml-xmlns)))) 367 )) 335 368 336 369 … … 345 378 (eval-env (mod-eval-cbv (current-eval-env) scoped-defs)) 346 379 (unified-env (list scoped-defs 347 (filter (lambda (x) (not (assoc (car x) ( init-type-env)))) type-env)348 (filter (lambda (x) (not (assoc (car x) ( init-eval-env)))) eval-env) ))380 (filter (lambda (x) (not (assoc (car x) (current-type-env)))) type-env) 381 (filter (lambda (x) (not (assoc (car x) (current-eval-env)))) eval-env) )) 349 382 350 383 ) … … 354 387 355 388 (define (parse-ul-component x) 356 (let ((definition ((sxpath `(// definition)) x)) 357 (properties ((sxpath `(// property)) x))) 389 390 (let ((definition ((sxpath `(// nml:definition)) x)) 391 (properties ((sxpath `(// nml:properties nml:quantity nml:value)) x))) 358 392 359 393 (if (null? definition) 360 394 (error 'parse-ul-component "component without definition" x)) 361 395 362 (let* ((url (sxml:text (safe-car definition))) 363 (uenv (eval-source (fetch (uri-reference url)) current-scope current-type-env current-eval-env ) )) 364 396 (let* ((uri (sxml-string->uri (sxml:text (safe-car definition)))) 397 (src (fetch uri)) 398 (uenv (if (not src) 399 (error 'parse-ul-component "resource not found" (uri->string uri)) 400 (eval-source (parse 'parse-ul-component src) 401 current-scope current-type-env current-eval-env))) 402 ) 403 365 404 (current-scope (car uenv)) 366 405 (current-type-env (append (cadr uenv) (current-type-env))) … … 409 448 (define (main options operands) 410 449 411 (if (options 'help) ( ivp:usage))412 413 414 (let ((find-module (lambda (x) (env-find-module x ( init-type-env)))))415 (for-each (lambda (init name) (init name enter-module find-module init-eval-env))450 (if (options 'help) (ulp:usage)) 451 452 453 (let ((find-module (lambda (x) (env-find-module x (current-type-env))))) 454 (for-each (lambda (init name) (init name enter-module find-module current-eval-env)) 416 455 (list Signal:module-initialize 417 456 Diagram:module-initialize … … 431 470 (lambda (operand) 432 471 433 (let* ((ul-sxml (parse-xml operand)) 434 (ul-components ((sxpath `(// component)) ul-sxml)) 435 (ul-terms (map parse-ul-components ul-components))) 436 437 (let ((source-defs (car uenv)) 438 (mty (cadr uenv)) 439 (eval-env (caddr uenv))) 472 (let* ((ul-sxml (parse-xml (read-all operand))) 473 (ul-imports ((sxpath `(// nml:nineml nml:import)) ul-sxml)) 474 (ul-import-sxmls (map (lambda (x) (parse-xml (fetch (sxml-string->uri (sxml:text x))))) ul-imports))) 475 476 (let* ((ul-sxml (fold append ul-sxml ul-import-sxmls)) 477 (ul-parameters ((sxpath `(// nml:nineml nml:quantity)) ul-sxml)) 478 479 (ul-components ((sxpath `(// nml:nineml nml:component)) ul-sxml)) 480 (ul-component-uenvs (map parse-ul-component ul-components)) 481 482 (ul-groups ((sxpath `(// nml:nineml nml:group)) ul-sxml)) 483 ) 484 485 (for-each 486 (lambda (uenv) 487 440 488 441 (let ((type-env-opt (options 'print-type-env))) 442 (if type-env-opt 443 (if (and (string? type-env-opt) (string=? type-env-opt "all")) 444 (print-type-env mty output-type) 445 (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x)))) 446 (print-type-env mty output-type fc))) 447 )) 448 449 (let ((eval-env-opt (options 'print-eval-env))) 450 (if eval-env-opt 451 (if (and (string? eval-env-opt) (string=? eval-env-opt "all")) 452 (print-eval-env eval-env output-eval) 453 (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x)))) 454 (print-eval-env eval-env output-type fc))) 455 )) 456 457 (if (options 'print-source-defs) 458 (print-source-defs source-defs output-type)) 459 460 461 ))) 489 (let ((source-defs (car uenv)) 490 (mty (cadr uenv)) 491 (eval-env (caddr uenv))) 492 493 (let ((type-env-opt (options 'print-type-env))) 494 (if type-env-opt 495 (if (and (string? type-env-opt) (string=? type-env-opt "all")) 496 (print-type-env mty output-type) 497 (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x)))) 498 (print-type-env mty output-type fc))) 499 )) 500 501 (let ((eval-env-opt (options 'print-eval-env))) 502 (if eval-env-opt 503 (if (and (string? eval-env-opt) (string=? eval-env-opt "all")) 504 (print-eval-env eval-env output-eval) 505 (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x)))) 506 (print-eval-env eval-env output-type fc))) 507 )) 508 509 (if (options 'print-source-defs) 510 (print-source-defs source-defs output-type)) 511 512 )) 513 ul-component-uenvs 514 515 )) 516 )) 462 517 463 518 operands))))
Note: See TracChangeset
for help on using the changeset viewer.
