Changeset 23838 in project


Ignore:
Timestamp:
05/30/11 07:47:53 (10 years ago)
Author:
Ivan Raikov
Message:

9ML-toolit: commit octave/mlton platform

Location:
release/4/9ML-toolkit/trunk
Files:
3 added
7 edited

Legend:

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

    r23770 r23838  
    77 ; List here all the files that should be bundled as part of your egg. 
    88
    9  (files "NineMLdiagram.scm" "NineML.grm" "NineMLsignal.scm" "NineMLinterval.scm" "9ML-toolkit.release-info" "expr.grm" "NineMLparse.scm" "expr-parser.scm" "examples/TestMorrisLecar81.9ML" "examples/TestExcInhNetwork.9ML" "examples/Izhikevich03.9ML" "examples/LeakyIAF.9ML" "examples/MorrisLecar81.9ML" "examples/TestLeakyIAF.9ML" "examples/ExcInhNetwork.9ML" "examples/Diagram.9ML" "examples/TestIzhikevich03.9ML" "examples/Destexhe94.9ML" "examples/highlight.css" "9ML-toolkit.setup" "NineML.l" "NineMLivp.scm" "NineMLgraph.scm" "NineMLrepr.scm" "NineMLcore.scm" "9ML-toolkit.meta" "SXML.scm" "shell.scm" "SXML-to-XML.scm" "report.scm" "ivp.scm")
     9 (files "NineMLdiagram.scm" "NineML.grm" "NineMLsignal.scm" "NineMLinterval.scm" "9ML-toolkit.release-info" "expr.grm" "NineMLparse.scm" "expr-parser.scm" "examples/TestMorrisLecar81.9ML" "examples/TestExcInhNetwork.9ML" "examples/Izhikevich03.9ML" "examples/LeakyIAF.9ML" "examples/MorrisLecar81.9ML" "examples/TestLeakyIAF.9ML" "examples/ExcInhNetwork.9ML" "examples/Diagram.9ML" "examples/TestIzhikevich03.9ML" "examples/Destexhe94.9ML" "examples/highlight.css" "9ML-toolkit.setup" "NineML.l" "NineMLivp.scm" "NineMLgraph.scm" "NineMLrepr.scm" "NineMLcore.scm" "9ML-toolkit.meta" "SXML.scm" "shell.scm" "SXML-to-XML.scm" "report.scm" "ivp.scm" "ivp-platforms.scm")
    1010
    1111
     
    2323 (needs matchable datatype static-modules (miniML 1.3) (getopt-long  1.8)
    2424        ssax sxml-transforms sxpath object-graph format-graph
    25         mathh silex lalr setup-helper (signal-diagram 1.3) )
     25        mathh silex lalr setup-helper (signal-diagram 1.5) )
    2626
    2727 (author "Ivan Raikov")
  • release/4/9ML-toolkit/trunk/9ML-toolkit.setup

    r23771 r23838  
    66(required-extension-version 'getopt-long 1.9)
    77(required-extension-version 'miniML 1.3)
    8 (required-extension-version 'signal-diagram 1.3)
     8(required-extension-version 'signal-diagram 1.5)
    99
    1010(define version 1.0)
     
    3939
    4040       ("9ML-ivp"
    41         ("NineMLcore.scm" "NineMLsignal.scm" "NineMLdiagram.scm" "NineMLinterval.scm" "NineMLgraph.scm" "NineMLivp.scm"
     41        ("NineMLcore.scm" "NineMLsignal.scm" "NineMLdiagram.scm" "NineMLinterval.scm" "NineMLgraph.scm" "NineMLivp.scm" "ivp-platforms.scm"
    4242         "ivp.scm" )
    4343        (compile -O -d2 -S ivp.scm -o 9ML-ivp ))
  • release/4/9ML-toolkit/trunk/examples/TestMorrisLecar81.9ML

    r23765 r23838  
    3232  binding V    = Signal.realsig `V    (Signal.realconst -60.899)
    3333  binding W    = Signal.realsig `W    (Signal.realconst 0.0149)
    34   binding Isyn = Signal.realsig `Isyn (Signal.realconst 50.0)
     34  binding Isyn = Signal.realsig `Isyn (Signal.realconst 80.0)
    3535  binding gl   = Signal.realsig `gl   (Signal.realconst 2.0)
    3636  binding gk   = Signal.realsig `gk   (Signal.realconst 8.0)
     
    4848
    4949  binding type1 = MorrisLecar81.construct t V W  gl gk gca vl vk vca v1 v2 v3 v4 phi c Isyn h
    50   binding type1_ivp = IVP.construct type1 `t `h 0.0 100.0
     50  binding type1_ivp = IVP.construct type1 `t `h 0.0 140.0
    5151
    5252end
  • release/4/9ML-toolkit/trunk/ivp.scm

    r23765 r23838  
    2323(require-extension getopt-long ssax sxml-transforms sxpath sxpath-lolevel object-graph signal-diagram)
    2424(require-extension 9ML-parse 9ML-repr )
     25       
    2526
    2627
     
    132133                                (let ((s (string->symbol (string-downcase x))))
    133134                                  (case s
    134                                     ((chicken mlton octave octave/ml) s)
     135                                    ((chicken mlton octave octave/mlton) s)
    135136                                    (else (error 'ivp "unrecognized platform" x))))))
    136137                            (transformer ,string->symbol)
    137138                             ))
    138139
     140    (verbose          "print commands as they are executed"
     141                      (single-char #\v))
    139142
    140143
     
    151154(define opt     (make-option-dispatch opts opt-grammar))
    152155
     156(define simulation-platform (make-parameter #f))
     157(define ivp-verbose (make-parameter 0))
     158
     159(define (d fstr . args)
     160  (let ([port (current-error-port)])
     161    (if (positive? (ivp-verbose))
     162        (begin (apply fprintf port fstr args)
     163               (flush-output port) ) )))
    153164
    154165(define (run:execute explist)
     
    166177            (map smooth explist)))
    167178
    168 
    169179(define-syntax run
    170180  (syntax-rules ()
    171181    ((_ exp ...)
    172      (run:execute* (list `exp ...)))))
     182     (begin
     183       (d "running ~A ...~%" (list `exp ...))
     184       (run:execute* (list `exp ...))))))
    173185
    174186(define-syntax run-
    175187  (syntax-rules ()
    176188    ((_ exp ...)
    177      (run:execute (list `exp ...)))))
     189     (begin
     190       (d "running ~A ...~%" (list `exp ...))
     191       (run:execute (list `exp ...))))))
    178192
    179193
     
    191205(define nl "\n")
    192206
     207(include "ivp-platforms.scm")
     208
    193209(define (generate-ivp-table prefix ivp-id sxml-tuple #!key (platform 'chicken))
    194 
    195   (define chicken-run
    196 #<<EOF
    197 
    198 (define-syntax run
    199   (syntax-rules ()
    200     ((_ f indep dep end input parameters)
    201      (let ((nstate input))
    202        (printf "# ~A " indep)
    203        (for-each (lambda (x) (printf "~A " x)) dep)
    204        (printf "~%")
    205        (let recur ((nstate nstate))
    206          (let ((ival (alist-ref indep nstate)))
    207            (printf "~A " ival)
    208            (for-each (lambda (x)
    209                        (let ((v (alist-ref x nstate)))
    210                          (printf "~A " (if (boolean? v) (or (and v 1) 0) v))))
    211                      dep)
    212            (printf "~%")
    213            (if (> ival end)
    214                (print "# All done!")
    215                (recur (append (f nstate) parameters))))))
    216      )))
    217 EOF
    218 )
    219  
    220   (define mlton-prelude
    221 #<<EOF
    222 
    223 fun putStrLn str =
    224     (TextIO.output (TextIO.stdOut, str);
    225      TextIO.output (TextIO.stdOut, "\n"))
    226    
    227 fun putStr str =
    228     (TextIO.output (TextIO.stdOut, str))
    229    
    230 fun showBoolean b = (if b then "1" else "0")
    231 
    232 fun showReal n =
    233     let open StringCvt
    234         open Real
    235     in
    236         (if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
    237     end
    238 
    239 EOF
    240 )
    241 
    242   (define (mlton-printstate ivar dvars ic)
    243     (string-append
    244       (sprintf
    245 #<<EOF
    246 
    247 fun printstate (input) =
    248     ( (showReal (#~A(input)))
    249 EOF
    250       ivar)
    251     (string-concatenate
    252      (map (lambda (dvar)
    253             (let ((v (alist-ref dvar ic)))
    254               (let ((show (cond ((number? v) "showReal")
    255                                 ((boolean? v) "showBoolean")
    256                                 (else         ""))))
    257                 (sprintf "^ \" \" ^ (~A (#~A(input)))" show dvar)))) dvars))
    258 
    259     ")" ))
    260 
    261   (define (mlton-run ivar dvars ic)
    262     (let* ((states (cons ivar dvars))
    263            (f       (lambda (x) (let ((n (car x)))
    264                                   (sprintf "~A=(#~A(~A))" n n (if (member n states) "nstate" "initial") ))))
    265            (nstate1 (string-append "{" (string-concatenate (intersperse (map f ic) ",")) "}")))
    266       (sprintf
    267 #<<EOF
    268 
    269 fun start (tmax,f,initial) =
    270 let
    271   fun run (input) =
    272     let val nstate = f input
    273         val nstate1 = ~A
    274     in putStrLn (printstate nstate1);
    275        if (#~A nstate)  > tmax
    276        then (putStrLn "# All done!"; nstate)
    277        else (run nstate1)
    278     end
    279 in
    280   run (initial)
    281 end
    282  
    283 EOF
    284    nstate1 ivar)))
    285 
    286 
    287     (define (mlton-initial ic)
    288       (let ((mlvalue (lambda (v)
    289                        (cond ((and (number? v) (negative? v)) (string-append "~" (sprintf "~A" (abs v))))
    290                              ((boolean? v)  (if v "true" "false"))
    291                              (else (sprintf "~A" v))))))
    292         (let ((ic (map (lambda (x) (let ((v (cdr x))) (cons (car x) (mlvalue v)))) ic)))
    293           (string-append "val initial = {" (string-concatenate (intersperse (map (lambda (x) (sprintf "~A=(~A)" (car x) (cdr x))) ic) ",")) "}"))))
    294210
    295211  (let ((sexpr
     
    324240                 (case platform
    325241
     242                   ((octave/mlton)
     243                    (let ((N (+ 1 (length dvars))))
     244
     245                      (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml"))
     246                        (lambda () (codegen/ML ivp-id sd solver: 'rk3)))
     247                     
     248                      (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_clib.sml"))
     249                        (lambda ()
     250                          (print-fragments
     251                           `(
     252                             (,mlton-clib-prelude)
     253                             ,(sprintf "val N = ~A~%~%" N)
     254                             (,(mlton-coutputstate ivar dvars ic) ,nl)
     255                             (,(mlton-clib-start ivar dvars ic) ,nl)
     256                             (,(mlton-initial ic) ,nl ,nl)
     257                             ,(sprintf "val e = _export \"~A_clib_run\" public: ((real * MLton.Pointer.t) -> unit) -> unit;~%~%" ivp-id)
     258                             ,(sprintf "val _ = e (fn(tmax,p) => (start(tmax,Model.~A,initial,(coutputstate p)); ()))~%~%" ivp-id)
     259                             ))))
     260                     
     261                      (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_clib.mlb"))
     262                        (lambda ()
     263                          (print-fragments
     264                           `(("$(SML_LIB)/basis/basis.mlb" ,nl )
     265                             ("$(SML_LIB)/basis/mlton.mlb" ,nl)
     266                             ("$(RK_LIB)/rk.mlb" ,nl )
     267                             ("local " ,nl)
     268                             (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
     269                             ("in" ,nl)
     270                             ("    structure Model" ,nl)
     271                             ("end" ,nl)
     272                             ,(sprintf "~A_clib.sml" ivp-id) ,nl))
     273                          ))
     274                     
     275                      (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.cc"))
     276                        (lambda ()
     277                          (print-fragments
     278                           `(,(mlton-clib-oct-cc ivp-id N end)))))
     279                     
     280                      (let* ((dir        (pathname-directory prefix))
     281                             (adir       (if (absolute-pathname? dir) dir
     282                                             (make-pathname (current-directory) dir)))
     283                             (shared-dir (chicken-home))
     284                             (flsim-dir  (make-pathname shared-dir "flsim"))
     285                             (h-path     (make-pathname dir (sprintf "~A_clib.h" ivp-id)))
     286                             (mlb-path   (make-pathname dir (sprintf "~A_clib.mlb" ivp-id)))
     287                             (so-path    (make-pathname dir (sprintf "~A_clib.so" ivp-id)))
     288                             (octcc-path (make-pathname dir (sprintf "~A_run.cc" ivp-id)))
     289                             (oct-path   (make-pathname dir (sprintf "~A_run.oct" ivp-id)))
     290                             (log-path   (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
     291                             (mlton-path      "mlton")
     292                             (mkoctfile-path  "mkoctfile")
     293                             (octave-path     "octave"))
     294                       
     295                        (run (,mlton-path -format library -export-header ,h-path -default-ann "'allowFFI true'" -link-opt -s
     296                                          -mlb-path-var ,(string-append "'RK_LIB " flsim-dir "/sml-lib/rk'") ,mlb-path))
     297                        (run (ln -sf ,(sprintf "~A_clib.so" ivp-id) ,(make-pathname dir (sprintf "lib~A_clib.so" ivp-id))))
     298                        (run (,mkoctfile-path ,octcc-path  -o ,oct-path
     299                                              ,(sprintf "-l~A_clib" ivp-id) ,(sprintf "-L~A" dir)
     300                                              ,(sprintf "\"-Wl,-rpath=~A\"" adir)))
     301                        (run (octave -p ,adir --eval
     302                                     #\'
     303                                     ,(sprintf "~A_run" ivp-id) #\;
     304                                     log0 = ,(sprintf "~A_run(~A)" ivp-id end) #\;
     305                                     log1 = "transpose(log0)" #\;
     306                                      save ,(intersperse `("\"-ascii\"" ,(sprintf "~C~A~C" #\" log-path #\") "\"log1\"") ",") #\;
     307                                     #\'))
     308                        (list ivp-id ivar dvars)
     309                        )))
     310                   
     311                   ((mlton)
     312                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml"))
     313                      (lambda () (codegen/ML ivp-id sd solver: 'rk3)))
     314
     315                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.sml"))
     316                      (lambda ()
     317                        (print-fragments
     318                         `(
     319                           (,mlton-run-prelude)
     320                           (,(mlton-printstate ivar dvars ic) ,nl)
     321                           (,(mlton-run-start ivar dvars ic) ,nl)
     322                           (,(mlton-initial ic) ,nl)
     323                           ,(sprintf "val _ = (printstate initial; start (~A, Model.~A, initial))~%~%" end ivp-id)
     324                          ))))
     325
     326                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.mlb"))
     327                      (lambda ()
     328                        (print-fragments
     329                         `(("$(SML_LIB)/basis/basis.mlb" ,nl )
     330                           ("$(RK_LIB)/rk.mlb" ,nl )
     331                           ("local " ,nl)
     332                           (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
     333                           ("in" ,nl)
     334                           ("    structure Model" ,nl)
     335                           ("end" ,nl)
     336                           ,(sprintf "~A_run.sml" ivp-id) ,nl))
     337                        ))
     338
     339                    (let* ((dir (pathname-directory prefix))
     340                           (shared-dir (chicken-home))
     341                           (flsim-dir (make-pathname shared-dir "flsim"))
     342                           (mlb-path  (make-pathname dir (sprintf "~A_run.mlb" ivp-id)))
     343                           (exec-path (make-pathname dir (sprintf "~A_run" ivp-id)))
     344                           (log-path  (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
     345                           (mlton-path  "mlton"))
     346
     347                      (run (,mlton-path -link-opt -s -mlb-path-var ,(string-append "'RK_LIB " flsim-dir "/sml-lib/rk'") ,mlb-path))
     348                      (run (,exec-path > ,log-path))
     349                      (list ivp-id ivar dvars)
     350                      ))
     351
    326352                   ((chicken)
    327353                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.scm"))
     
    347373                      (list ivp-id ivar dvars)
    348374                      ))
    349                    
    350                    ((mlton)
    351                     (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml"))
    352                       (lambda () (codegen/ML ivp-id sd solver: 'rk3)))
    353 
    354                     (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.sml"))
    355                       (lambda ()
    356                         (print-fragments
    357                          `(
    358                            (,mlton-prelude)
    359                            (,(mlton-printstate ivar dvars ic) ,nl)
    360                            (,(mlton-run ivar dvars ic) ,nl)
    361                            (,(mlton-initial ic) ,nl)
    362                            ,(sprintf "val _ = (printstate initial; start (~A, Model.~A, initial))~%~%" end ivp-id)
    363                           ))))
    364 
    365                     (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.mlb"))
    366                       (lambda ()
    367                         (print-fragments
    368                          `(("$(SML_LIB)/basis/basis.mlb" ,nl )
    369                            ("$(RK_LIB)/rk.mlb" ,nl )
    370                            ("local " ,nl)
    371                            (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
    372                            ("in" ,nl)
    373                            ("    structure Model" ,nl)
    374                            ("end" ,nl)
    375                            ,(sprintf "~A_run.sml" ivp-id) ,nl))
    376                         ))
    377 
    378                     (let* ((dir (pathname-directory prefix))
    379                            (shared-dir (chicken-home))
    380                            (flsim-dir (make-pathname shared-dir "flsim"))
    381                            (mlb-path  (make-pathname dir (sprintf "~A_run.mlb" ivp-id)))
    382                            (exec-path (make-pathname dir (sprintf "~A_run" ivp-id)))
    383                            (log-path  (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
    384                            (mlton-path  "mlton"))
    385 
    386                       (run (,mlton-path -link-opt -s -mlb-path-var ,(string-append "'RK_LIB " flsim-dir "/sml-lib/rk'") ,mlb-path))
    387                       (run (,exec-path > ,log-path))
    388                       (list ivp-id ivar dvars)
    389                       ))
     375
     376                   (else (error 'generate-ivp-table "unknown platform"  platform))
    390377                   
    391378                   ))
     
    403390           (png-path (make-pathname dir (sprintf "~A_~A.png" (pathname-file prefix) ivp-id)))
    404391           )
    405       (run (octave --eval #\'log = load (,(sprintf "\"~A\"" log-path)) #\;
     392      (run (octave --eval
     393                   #\'
     394                   log = load (,(sprintf "\"~A\"" log-path)) #\;
    406395                   h = plot ("log(:,1)" #\, ,(sprintf "log(:,2:~A)" n)) #\;
    407396                   ,@(concatenate (list-tabulate (- n 1) (lambda (i) `(set (h(,(+ 1 i)) #\, "\"linewidth\"" #\, ,linewidth) #\;))))
     
    428417      (let* ((ivp-id (gensym 'ivp))
    429418             (ivp-plot-link `(img (@ (src ,(sprintf "~A_~A.png" (pathname-file prefix) ivp-id)) (alt "NineML IVP plot"))))
    430              (ivp-info (generate-ivp-table prefix ivp-id value platform: (or (opt 'platform) (defopt 'platform) ))))
     419             (ivp-info (generate-ivp-table prefix ivp-id value platform: (simulation-platform))))
    431420        (if ivp-plot (generate-ivp-plot prefix ivp-info))
    432421        (and ivp-plot ivp-plot-link)
     
    477466                               (else #f)))
    478467            (unified-envs (map interpreter operands)))
     468        (if (options 'verbose) (begin (repr-verbose 1) (ivp-verbose 1)))
     469        (simulation-platform (or (options 'platform) (defopt 'platform) ))
    479470        (for-each
    480471         (lambda (operand uenv)
     
    515506         operands unified-envs))))
    516507
     508(width 40)
    517509(main opt (opt '@))
  • release/4/9ML-toolkit/trunk/report.scm

    r23745 r23838  
    105105                        (single-char #\s))
    106106
    107     (nxml            "prints canonical NineML XML representation of the evaluation environment of each operand"
     107    (nxml            "prints canonical NineML XML representation of each operand"
    108108                     (single-char #\n))
    109109
     
    305305          )))
    306306
     307(width 40)
    307308(main opt (opt '@))
  • release/4/9ML-toolkit/trunk/repr.scm

    r23765 r23838  
    2323(module 9ML-repr
    2424
    25         (sxml-value->sexpr sexpr->diagram+initial print-fragments
     25        (repr-verbose
     26         sxml-value->sexpr sexpr->diagram+initial print-fragments
    2627         print-eval-env print-type-env print-source-defs print-nxml
    2728         generate-diagram html-report traverse-definitions)
     
    4647(include "SXML-to-XML.scm")
    4748
     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
    4857
    4958(define (run:execute explist)
     
    6574  (syntax-rules ()
    6675    ((_ exp ...)
    67      (run:execute* (list `exp ...)))))
     76     (begin
     77       (d "running ~A ...~%" (list `exp ...))
     78       (run:execute* (list `exp ...))))))
    6879
    6980(define-syntax run-
    7081  (syntax-rules ()
    7182    ((_ exp ...)
    72      (run:execute (list `exp ...)))))
     83     (begin
     84       (d "running ~A ...~%" (list `exp ...))
     85       (run:execute (list `exp ...))))))
    7386
    7487
  • release/4/9ML-toolkit/trunk/ulp.scm

    r23766 r23838  
    2121
    2222
    23 (require-extension
    24  extras regex posix utils files data-structures tcp srfi-1 srfi-13
    25  tree-rewrite sxml-transforms sxpath uri-generic getopt-long)
     23(require-extension setup-api extras regex posix utils files data-structures tcp srfi-1 srfi-13)
     24(require-extension datatype static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
     25(require-extension signal-diagram tree-rewrite ssax sxml-transforms sxpath sxpath-lolevel object-graph uri-generic getopt-long )
     26(require-extension 9ML-parse 9ML-repr )
     27       
     28(include "SXML.scm")
     29(include "SXML-to-XML.scm")
     30
     31(define-values (env-binding? env-empty env-add-signature env-add-module env-add-type env-add-spec env-add-value
     32                env-find-value env-find-type env-find-module env-find)
     33  (make-mod-env core-syntax))
     34
     35(define-values (scope-typedecl scope-modtype scope-signature scope-modterm scope-moddef)
     36  (make-mod-scoping core-syntax core-scoping))
     37
     38(define-values (check-modtype check-signature type-modterm type-moddef type-definition)
     39  (make-mod-typing core-syntax core-typing))
     40
     41(include "NineMLcore.scm")
     42(include "NineMLsignal.scm")
     43(include "NineMLdiagram.scm")
     44(include "NineMLinterval.scm")
     45(include "NineMLgraph.scm")
     46(include "NineMLivp.scm")
     47
     48
     49(define init-scope      (make-parameter st-empty))
     50(define init-type-env   (make-parameter env-empty))
     51(define init-eval-env   (make-parameter env-empty))
     52
     53
     54(define (enter-typedecl id decl)
     55  (init-scope (st-enter-type id (init-scope)))
     56  (init-type-env   (env-add-type id decl (init-type-env))))
     57
     58(define (enter-valtype name ty)
     59  (let ((id (ident-create name)))
     60    (init-scope (st-enter-value id (init-scope)))
     61    (init-type-env   (env-add-value id ty (init-type-env)))))
     62
     63(define (enter-val name val)
     64  (let ((id (or (and (ident? name) name) (ident-create name))))
     65    (init-eval-env (ident-add id val (init-eval-env)))))
     66
     67(core-initialize enter-typedecl enter-valtype)
     68(eval-cbv-initialize enter-val)
     69
     70
     71(define (enter-module id mty)
     72  (init-scope (st-enter-module id (init-scope)))
     73  (init-type-env (env-add-module id mty (init-type-env))))
     74
    2675
    2776
     
    3685(define opt-grammar
    3786  `(
     87
     88    (print-type-env  "prints the type environment of each operand"
     89                     (single-char #\t)
     90                     (value (optional COMPONENT-LIST)
     91                            (default all)
     92                            (transformer
     93                             ,(lambda (x)
     94                                (if (string=? x "all") x
     95                                    (list (string-split x ",")))))))
     96
     97    (print-eval-env  "prints the evaluation environment of each operand"
     98                     (single-char #\e)
     99                     (value (optional COMPONENT-LIST)
     100                            (default all)
     101                            (transformer
     102                             ,(lambda (x)
     103                                (if (string=? x "all") x
     104                                    (list (string-split x ",")))))))
     105
     106    (print-source-defs  "prints the source definitions of each operand"
     107                        (single-char #\s))
     108
     109    (output-sxml        "sets output format to SXML")
     110
     111    (output-xml         "sets output format to XML")
     112
     113    (platform        "simulation platform (one of chicken, mlton, octave, octave/mlton)"
     114                     (value (required PLATFORM)
     115                            (predicate
     116                             ,(lambda (x)
     117                                (let ((s (string->symbol (string-downcase x))))
     118                                  (case s
     119                                    ((chicken mlton octave octave/ml) s)
     120                                    (else (error 'ivp "unrecognized platform" x))))))
     121                            (transformer ,string->symbol)
     122                             ))
     123
     124    (verbose          "print commands as they are executed"
     125                      (single-char #\v))
    38126
    39127    (help  "Print help"
     
    64152(define opt     (make-option-dispatch opts opt-grammar))
    65153
    66 
     154(define ulp-verbose (make-parameter 0))
    67155(define data-dir (make-parameter #f))
     156(define simulation-platform (make-parameter #f))
     157
     158(define (d fstr . args)
     159  (let ([port (current-error-port)])
     160    (if (positive? (ulp-verbose))
     161        (begin (apply fprintf port fstr args)
     162               (flush-output port) ) )))
     163
    68164
    69165(define (get-data-dir)
     
    73169            (data-dir dir)
    74170            dir ) ) ))
     171
     172
     173(define (run:execute explist)
     174  (define (smooth lst)
     175    (let ((slst (map ->string lst)))
     176      (string-intersperse (cons (car slst) (cdr slst)) " ")))
     177  (for-each (lambda (cmd) (system (->string cmd)))
     178            (map smooth explist)))
     179
     180
     181(define (run:execute* explist)
     182  (define (smooth lst)
     183    (let ((slst (map ->string lst)))
     184      (string-intersperse (cons (car slst) (cdr slst)) " ")))
     185  (for-each (lambda (cmd) (system* "~a" cmd))
     186            (map smooth explist)))
     187
     188
     189(define-syntax run
     190  (syntax-rules ()
     191    ((_ exp ...)
     192     (begin
     193       (d "running ~A ...~%" (list `exp ...))
     194       (run:execute* (list `exp ...))))))
     195
     196
     197(define-syntax run-
     198  (syntax-rules ()
     199    ((_ exp ...)
     200     (begin
     201       (d "running ~A ...~%" (list `exp ...))
     202       (run:execute (list `exp ...))))))
    75203
    76204
     
    202330
    203331
    204 (define rule-user-layer
     332(define rule-user-layer-component
    205333  `(
    206334
     
    209337
    210338     ( (M component (eval-env $eval-env) $properties) =>
    211        (M component (main-module (eval-env-last-entry $eval-env)) $properties) )
     339       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
    212340
    213341     ( (M component (eval-env $eval-env) $properties) =>
    214        (M component (main-module (eval-env-last-entry $eval-env)) $properties) )
    215 
    216      ( (M component (main-module $main-module) $properties) =>
    217        (eval-term (M apply-terms (Longid (Pdot (entry-name $main-module) "main")) $properties)) )
     342       (M component (model-module (eval-env-last-entry $eval-env)) $properties) )
     343
     344     ( (M component (model-module $model-module) $properties) =>
     345       (eval-term (M apply-terms (Longid (Pdot (entry-name $model-module) "construct")) $properties)) )
    218346
    219347     ( (M eval-definition $url ) =>
    220        (eval-source (fetch (uri-reference $url)) interpreter current-scope current-type-env current-eval-env ) )
     348       (eval-source (fetch (uri-reference $url)) current-scope current-type-env current-eval-env ) )
    221349
    222350     ( (M apply-terms $operator (seq $term $rest)) =>
     
    224352       
    225353     ( (M apply-terms $operator (seq-empty)) => $operator )
    226      
    227      
    228      
    229354       
    230355     ))
    231356
    232357
     358(define (eval-source def current-scope current-type-env current-eval-env)
     359  (let* ((scoped-defs      (scope-moddef (current-scope) defs))
     360         (mty              (type-moddef (current-type-env) '() scoped-defs))
     361         (type-env         (map (lambda (x) (cases modspec x
     362                                                   (Value_sig (id vty) (cons id x))
     363                                                   (Type_sig (id decl) (cons id x))
     364                                                   (Module_sig (id mty) (cons id x))
     365                                                   )) mty))
     366         (eval-env         (mod-eval-cbv (current-eval-env) scoped-defs))
     367         (unified-env      (list scoped-defs
     368                                 (filter (lambda (x) (not (assoc (car x) (init-type-env)))) type-env)
     369                                 (filter (lambda (x) (not (assoc (car x) (init-eval-env)))) eval-env) ))
     370         
     371         )
     372    unified-env
     373    ))
     374
     375
     376(define rewrite-ul-components (rewrite-map-tree rule-user-layer-component))
     377
     378(define (main options operands)
     379
     380  (if (options 'help) (ivp:usage))
     381
     382
     383  (let ((find-module (lambda (x) (env-find-module x (init-type-env)))))
     384    (for-each (lambda (init name) (init name enter-module find-module init-eval-env))
     385              (list Signal:module-initialize   
     386                    Diagram:module-initialize 
     387                    Interval:module-initialize
     388                    Graph:module-initialize
     389                    IVP:module-initialize )
     390              (list "Signal" "Diagram" "Interval" "Graph" "IVP" )) )
     391
     392  (if (null? operands)
     393      (ulp:usage)
     394      (let ((output-type (cond ((options 'output-xml)  'xml)
     395                               ((options 'output-sxml) 'sxml)
     396                               (else #f))))
     397        (if (options 'verbose) (begin (repr-verbose 1) (ivp-verbose 1)))
     398        (simulation-platform (or (options 'platform) (defopt 'platform) ))
     399        (for-each
     400         (lambda (operand)
     401
     402           (let* ((ul-sxml (parse-sxml operand))
     403                  (ul-components ((sxpath `(// component))  ul-sxml))
     404                  (ul-terms (rewrite-ul-components ul-components)))
     405
     406             
     407
     408             (let ((source-defs (car uenv))
     409                   (mty         (cadr uenv))
     410                   (eval-env    (caddr uenv)))
     411               
     412               (let ((type-env-opt (options 'print-type-env)))
     413                 (if type-env-opt
     414                     (if (and (string? type-env-opt) (string=?  type-env-opt "all"))
     415                         (print-type-env mty output-type)
     416                         (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x))))
     417                           (print-type-env mty output-type fc)))
     418                     ))
     419               
     420               (let ((eval-env-opt (options 'print-eval-env)))
     421                 (if eval-env-opt
     422                     (if (and (string? eval-env-opt) (string=? eval-env-opt "all"))
     423                         (print-eval-env eval-env output-eval)
     424                         (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x))))
     425                           (print-eval-env eval-env output-type fc)))
     426                     ))
     427               
     428               (if (options 'print-source-defs)
     429                   (print-source-defs source-defs output-type))
     430               
     431               
     432               )))
     433
     434         operands))))
     435
     436(main opt (opt '@))
     437
     438
    233439)
    234        
    235 
    236 
    237 
     440
Note: See TracChangeset for help on using the changeset viewer.