Changeset 20450 in project


Ignore:
Timestamp:
09/22/10 07:13:38 (10 years ago)
Author:
Ivan Raikov
Message:

signal-diagram: some cleaning up of the ML codegen

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/signal-diagram/trunk/signal-diagram.scm

    r19566 r20450  
    10641064
    10651065
     1066(define (prelude/ML)
     1067  (print #<<EOF
     1068structure Model =
     1069struct
     1070
     1071open Real
     1072open Math
     1073open RungeKutta
     1074
     1075datatype ('b,'c) trs = TRSA of 'b | TRSB of 'c
     1076datatype ('a,'b,'c) trc = TRC of ((('a -> (('b,'c) trs)) ref) *
     1077                                  (('a -> (('b,'c) trs)) ref) *
     1078                                  ((('b,'c) trs) -> bool))
     1079         
     1080fun tsCase (fa,fb,x) = case x of TRSA a => (fa a) | TRSB b => (fb b)
     1081fun trfOf x = case x of TRC (f,fk,e) => f
     1082fun trfkOf x = case x of TRC (f,fk,e) => fk
     1083fun treOf x = case x of TRC (f,fk,e) => e
     1084fun trfSet (x,f') = case x of TRC (f,fk,e) => f := f'
     1085fun trfkSet (x,fk') = case x of TRC (f,fk,e) => fk := fk'
     1086
     1087fun putStrLn str =
     1088  (TextIO.output (TextIO.stdOut, str);
     1089   TextIO.output (TextIO.stdOut, "\n"))
     1090
     1091fun putStr str = (TextIO.output (TextIO.stdOut, str))
     1092
     1093fun showReal n =
     1094let open StringCvt
     1095in
     1096(if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
     1097end
     1098
     1099exception EmptySignal
     1100val swap = fn (x,v) => (case v of NONE => x | SOME v => v)
     1101val equal = fn (x,y) => (x = y)
     1102val signalOf = fn (v) => (case v of NONE => raise EmptySignal | SOME v => v)
     1103
     1104val scaler = op *
     1105val summer = op +
     1106
     1107val rk4b: real stepper1 = make_rk4b()
     1108fun make_stepper (deriv) = rk4b (scaler,summer,deriv)
     1109EOF
     1110))
     1111
    10661112(define (codegen/ML name f input . fundecls)
    10671113  (let ((dfe (sfarrow-dfe f)))
     
    10691115           (fcodegen ((sfarrow-codegen f) input fenv dfe )))
    10701116
    1071       (print-fragments
    1072        `(
    1073          ("structure Model = " ,nl)
    1074          ("struct" ,nl)
    1075          ,nl))
    1076        
    1077 
    1078       (print-fragments
    1079        `(
    1080          ("open Real" ,nl)
    1081          ("open Math" ,nl)
    1082          ("open RungeKutta" ,nl)
    1083          ,nl
    1084          ("datatype ('b,'c) trs = TRSA of 'b | TRSB of 'c" ,nl)
    1085          ("datatype ('a,'b,'c) trc = TRC of ((('a -> (('b,'c) trs)) ref) * " ,nl
    1086           "                                  (('a -> (('b,'c) trs)) ref) * " ,nl
    1087           "                                  ((('b,'c) trs) -> bool))" ,nl
    1088           )
    1089          
    1090          ("fun tsCase (fa,fb,x) = case x of TRSA a => (fa a) | TRSB b => (fb b)" ,nl)
    1091          ("fun trfOf x = case x of TRC (f,fk,e) => f" ,nl)
    1092          ("fun trfkOf x = case x of TRC (f,fk,e) => fk" ,nl)
    1093          ("fun treOf x = case x of TRC (f,fk,e) => e" ,nl)
    1094          ("fun trfSet (x,f') = case x of TRC (f,fk,e) => f := f'" ,nl)
    1095          ("fun trfkSet (x,fk') = case x of TRC (f,fk,e) => fk := fk'" ,nl)
    1096 
    1097          ,nl
    1098          ("fun putStrLn str = " ,nl)
    1099          ("  (TextIO.output (TextIO.stdOut, str);" ,nl)
    1100          ("  TextIO.output (TextIO.stdOut, \"\\n\"))" ,nl)
    1101          ,nl
    1102          ("fun putStr str = " ,nl)
    1103          ("(TextIO.output (TextIO.stdOut, str))" ,nl)
    1104          ,nl
    1105          ("fun showReal n = " ,nl)
    1106          ("let open StringCvt" ,nl)
    1107          ("in" ,nl)
    1108          ("(if n < 0.0 then \"-\" else \"\") ^ (fmt (FIX (SOME 12)) (abs n))" ,nl)
    1109          ("end" ,nl)
    1110          ,nl
    1111          ("exception EmptySignal" ,nl)
    1112          ("val swap = fn (x,v) => (case v of NONE => x | SOME v => v) " ,nl)
    1113          ("val equal = fn (x,y) => (x = y) " ,nl)
    1114          ("val signalOf = fn (v) => (case v of NONE => raise EmptySignal | SOME v => v) " ,nl)
    1115          ,nl
    1116         ))
    1117 
    1118       (print-fragments
    1119        `(
    1120          ("val scaler = op *" ,nl)
    1121          ("val summer = op +" ,nl)
    1122 
    1123          ("val rk4b: real stepper1 = make_rk4b()" ,nl)
    1124          ("fun make_stepper (deriv) = rk4b (scaler,summer,deriv)" ,nl)
    1125          
    1126          ,nl
    1127          ))
     1117      (prelude/ML)
    11281118
    11291119      (if (pair? fundecls)
Note: See TracChangeset for help on using the changeset viewer.