Mercurial > urweb

comparison src/jscomp.sml @ 591:8f8771f32909

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Injecting a float
author Adam Chlipala <adamc@hcoop.net>
date Thu, 01 Jan 2009 15:59:02 -0500
parents 57f476c934da
children a8be5a2068a5
comparison
equal deleted inserted replaced
590:57f476c934da 591:8f8771f32909
94 | EJavaScript _ => 0 94 | EJavaScript _ => 0
95 | ESignalReturn e => varDepth e 95 | ESignalReturn e => varDepth e
96 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) 96 | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
97 | ESignalSource e => varDepth e 97 | ESignalSource e => varDepth e
98 98
99 fun closedUpto d =
100 let
101 fun cu inner (e, _) =
102 case e of
103 EPrim _ => true
104 | ERel n => n < inner orelse n - inner >= d
105 | ENamed _ => true
106 | ECon (_, _, NONE) => true
107 | ECon (_, _, SOME e) => cu inner e
108 | ENone _ => true
109 | ESome (_, e) => cu inner e
110 | EFfi _ => true
111 | EFfiApp (_, _, es) => List.all (cu inner) es
112 | EApp (e1, e2) => cu inner e1 andalso cu inner e2
113 | EAbs (_, _, _, e) => cu (inner + 1) e
114 | EUnop (_, e) => cu inner e
115 | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
116 | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
117 | EField (e, _) => cu inner e
118 | ECase (e, pes, _) =>
119 cu inner e
120 andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
121 | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
122 | EError (e, _) => cu inner e
123 | EWrite e => cu inner e
124 | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
125 | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
126 | EClosure (_, es) => List.all (cu inner) es
127 | EQuery {query, body, initial, ...} =>
128 cu inner query
129 andalso cu (inner + 2) body
130 andalso cu inner initial
131 | EDml e => cu inner e
132 | ENextval e => cu inner e
133 | EUnurlify (e, _) => cu inner e
134 | EJavaScript (_, e, _) => cu inner e
135 | ESignalReturn e => cu inner e
136 | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
137 | ESignalSource e => cu inner e
138 in
139 cu 0
140 end
141
99 fun strcat loc es = 142 fun strcat loc es =
100 case es of 143 case es of
101 [] => (EPrim (Prim.String ""), loc) 144 [] => (EPrim (Prim.String ""), loc)
102 | [x] => x 145 | [x] => x
103 | x :: es' => (EStrcat (x, strcat loc es'), loc) 146 | x :: es' => (EStrcat (x, strcat loc es'), loc)
104
105 exception Unsupported of string * EM.span
106 147
107 fun process file = 148 fun process file =
108 let 149 let
109 val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) 150 val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
110 | ((DValRec vis, _), nameds) => 151 | ((DValRec vis, _), nameds) =>
121 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] 162 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
122 | TRecord [] => str loc "null" 163 | TRecord [] => str loc "null"
123 164
124 | TFfi ("Basis", "string") => e 165 | TFfi ("Basis", "string") => e
125 | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) 166 | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc)
167 | TFfi ("Basis", "float") => (EFfiApp ("Basis", "htmlifyFloat", [e]), loc)
126 168
127 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; 169 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
128 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; 170 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
129 str loc "ERROR") 171 str loc "ERROR")
130 172
149 case t of 191 case t of
150 TOption _ => true 192 TOption _ => true
151 | TRecord [] => true 193 | TRecord [] => true
152 | _ => false 194 | _ => false
153 195
154 fun unsupported s = raise Unsupported (s, loc) 196 fun unsupported s =
197 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
198 (str "ERROR", st))
155 199
156 val strcat = strcat loc 200 val strcat = strcat loc
157 201
158 fun jsPrim p = 202 fun jsPrim p =
159 case p of 203 case p of
445 in 489 in
446 (strcat [e, 490 (strcat [e,
447 str ("._" ^ x)], st) 491 str ("._" ^ x)], st)
448 end 492 end
449 493
450 | ECase (e, pes, _) => 494 | ECase (e', pes, {result, ...}) =>
451 let 495 if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
452 val plen = length pes 496 ((ELet ("js", result, e, quoteExp result (ERel 0, loc)), loc),
453 497 st)
454 val (cases, st) = ListUtil.foldliMap 498 else
455 (fn (i, (p, e), st) => 499 let
456 let 500 val plen = length pes
457 val (e, st) = jsE (inner + E.patBindsN p) (e, st) 501
458 val fail = 502 val (cases, st) = ListUtil.foldliMap
459 if i = plen - 1 then 503 (fn (i, (p, e), st) =>
460 str "pf()" 504 let
461 else 505 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
462 str ("c" ^ Int.toString (i+1) ^ "()") 506 val fail =
463 val c = jsPat 0 inner p e fail 507 if i = plen - 1 then
464 in 508 str "pf()"
465 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), 509 else
466 c, 510 str ("c" ^ Int.toString (i+1) ^ "()")
467 str "},"], 511 val c = jsPat 0 inner p e fail
468 st) 512 in
469 end) 513 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
470 st pes 514 c,
471 515 str "},"],
472 val (e, st) = jsE inner (e, st) 516 st)
473 in 517 end)
474 (strcat (str "(" 518 st pes
475 :: List.revAppend (cases, 519
476 [str "d0=", 520 val (e, st) = jsE inner (e', st)
477 e, 521 in
478 str ",c0())"])), st) 522 (strcat (str "("
479 end 523 :: List.revAppend (cases,
524 [str "d0=",
525 e,
526 str ",c0())"])), st)
527 end
480 528
481 | EStrcat (e1, e2) => 529 | EStrcat (e1, e2) =>
482 let 530 let
483 val (e1, st) = jsE inner (e1, st) 531 val (e1, st) = jsE inner (e1, st)
484 val (e2, st) = jsE inner (e2, st) 532 val (e2, st) = jsE inner (e2, st)
520 str ",", 568 str ",",
521 e2, 569 e2,
522 str ")"], st) 570 str ")"], st)
523 end 571 end
524 572
525 | EJavaScript (_, _, SOME e) => (e, st) 573 | EJavaScript (_, _, SOME _) => (e, st)
526 574
527 | EClosure _ => unsupported "EClosure" 575 | EClosure _ => unsupported "EClosure"
528 | EQuery _ => unsupported "Query" 576 | EQuery _ => unsupported "Query"
529 | EDml _ => unsupported "DML" 577 | EDml _ => unsupported "DML"
530 | ENextval _ => unsupported "Nextval" 578 | ENextval _ => unsupported "Nextval"
582 in 630 in
583 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) 631 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
584 end 632 end
585 in 633 in
586 case e of 634 case e of
587 EJavaScript (m as Source t, orig, _) => 635 EJavaScript (m, orig as (EAbs (_, t, _, e), _), NONE) =>
588 (doCode m 0 env orig orig 636 doCode m 1 (t :: env) orig e
589 handle Unsupported (s, loc) => 637 | EJavaScript (m, orig, NONE) =>
590 let 638 doCode m 0 env orig orig
591 val e = ELet ("js", t, orig, quoteExp (#2 orig) t
592 (ERel 0, #2 orig))
593 in
594 (EJavaScript (m, orig, SOME (e, #2 orig)), st)
595 end)
596
597 | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
598 (doCode m 1 (t :: env) orig e
599 handle Unsupported (s, loc) =>
600 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
601 (EPrim (Prim.String "ERROR"), st)))
602
603 | EJavaScript (m, orig, _) =>
604 (doCode m 0 env orig orig
605 handle Unsupported (s, loc) =>
606 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
607 (EPrim (Prim.String "ERROR"), st)))
608
609 | _ => (e, st) 639 | _ => (e, st)
610 end, 640 end,
611 decl = fn (_, e, st) => (e, st), 641 decl = fn (_, e, st) => (e, st),
612 bind = fn (env, U.Decl.RelE (_, t)) => t :: env 642 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
613 | (env, _) => env} 643 | (env, _) => env}