Changeset 25552 in project


Ignore:
Timestamp:
11/22/11 17:23:57 (9 years ago)
Author:
Ivan Raikov
Message:

9ML-toolkit: additions and fixes to ulp

Location:
release/4/9ML-toolkit/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/9ML-toolkit/trunk/parse.scm

    r25439 r25552  
    375375
    376376
    377 (define nineml-xmlns "http://nineml.org/9ML/0.1")
     377(define nineml-xmlns "http://www.NineML.org/9ML/1.0")
    378378
    379379(define (parse-al-sxml-dynamics sxml)
  • release/4/9ML-toolkit/trunk/ulp.scm

    r25326 r25552  
    2121
    2222
    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)
    2424(require-extension datatype matchable static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
    2525(require-extension signal-diagram ssax sxml-transforms sxpath sxpath-lolevel object-graph uri-generic getopt-long )
    2626(require-extension 9ML-parse 9ML-repr )
    2727
     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))))
    2841
    2942(define (safe-car x) (and (pair? x) (car x)))
     
    5164
    5265
    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))
    5669
    5770
    5871(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))))
    6174
    6275(define (enter-valtype name ty)
    6376  (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)))))
    6679
    6780(define (enter-val name val)
    6881  (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)))))
    7083
    7184(core-initialize enter-typedecl enter-valtype)
     
    7487
    7588(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))))
    7891
    7992
     
    115128    (output-xml         "sets output format to XML")
    116129
    117     (platform        "simulation platform (one of chicken, mlton, octave, octave/mlton)"
     130    (platform        "simulation platform (one of chicken, chicken/cvode, mlton, octave, octave/mlton)"
    118131                     (value (required PLATFORM)
    119132                            (predicate
     
    121134                                (let ((s (string->symbol (string-downcase x))))
    122135                                  (case s
    123                                     ((chicken mlton octave octave/ml) s)
     136                                    ((chicken chicken/cvode mlton octave octave/mlton) s)
    124137                                    (else (error 'ivp "unrecognized platform" x))))))
    125138                            (transformer ,string->symbol)
     
    160173(define simulation-platform (make-parameter #f))
    161174
     175
    162176(define (d fstr . args)
    163177  (let ([port (current-error-port)])
     
    165179        (begin (apply fprintf port fstr args)
    166180               (flush-output port) ) )))
     181
     182
     183(define (sxml-string->uri s)
     184  (let ((ss (string-trim-both s)))
     185    (uri-reference ss)))
    167186
    168187
     
    272291                      (d "requesting ~s ...~%" locn)
    273292                      (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: "*/*")
    275294                       out)
    276295                      (flush-output out)
     
    327346
    328347
    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)))
    333359    ))
    334360
     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      ))
    335368
    336369
     
    345378         (eval-env         (mod-eval-cbv (current-eval-env) scoped-defs))
    346379         (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) ))
    349382         
    350383         )
     
    354387
    355388(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)))
    358392
    359393    (if (null? definition)
    360394        (error 'parse-ul-component "component without definition" x))
    361395
    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     
    365404      (current-scope (car uenv))
    366405      (current-type-env (append (cadr uenv) (current-type-env)))
     
    409448(define (main options operands)
    410449
    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))
    416455              (list Signal:module-initialize   
    417456                    Diagram:module-initialize 
     
    431470         (lambda (operand)
    432471
    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
    440488               
    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             ))
    462517
    463518         operands))))
Note: See TracChangeset for help on using the changeset viewer.