Permalink
Browse files

support for inline javascript

git-svn-id: http://ocamljs.googlecode.com/svn/trunk@90 27578800-e353-0410-a23a-a7c9f63c6ccd
  • Loading branch information...
1 parent 344f956 commit aa568d8ae6abb5ec94e16d0e82d3f0e71f43ca26 Jake Donham committed Nov 7, 2008
View
@@ -1,7 +1,7 @@
<emitjs.mli>: pkg_jslib
<emitjs.ml>: pkg_jslib
<jsgen.mli>: pkg_jslib
-<jsgen.ml>: syntax_camlp4o,pkg_jslib
+<jsgen.ml>: syntax_camlp4o,pkg_jslib.quotations
<jscompile.ml>: pkg_jslib
<jslink.ml>: pkg_jslib
View
@@ -272,6 +272,32 @@ let maybe_block ss =
| [s] -> s
| _ -> Jslib_ast.Jblock (_loc, ss)
+let inline_string = function
+ | Lconst (Const_base (Const_string s)) -> s
+ | _ -> raise (Failure "bad inline string")
+
+let inline_bool = function
+ | Lconst (Const_pointer 0) -> false
+ | Lconst (Const_pointer 1) -> true
+ | _ -> raise (Failure "bad inline bool")
+
+let makeblock_of_const = function
+ | Lconst (Const_block (tag, cs)) ->
+ Lprim (Pmakeblock (tag, Asttypes.Mutable), List.map (fun c -> Lconst c) cs)
+ | _ -> assert false
+
+let rec inline_option inline = function
+ | Lconst (Const_block _) as cb -> inline_option inline (makeblock_of_const cb)
+ | Lconst (Const_pointer 0) -> None
+ | Lprim (Pmakeblock (0, _), [v]) -> Some (inline v)
+ | _ -> raise (Failure "bad inline option")
+
+let rec inline_list inline = function
+ | Lconst (Const_block _) as cb -> inline_list inline (makeblock_of_const cb)
+ | Lconst (Const_pointer 0) -> []
+ | Lprim (Pmakeblock (0, _), [h; t]) -> inline h :: inline_list inline t
+ | _ -> raise (Failure "bad inline list")
+
(* compile a lambda as a Js.exp *)
(* tail is true if the expression is in tail position *)
let rec comp_expr tail expr =
@@ -305,6 +331,9 @@ let rec comp_expr tail expr =
| Lsequence (e1, e2) -> << $comp_expr false e1$, $comp_expr tail e2$ >>
| Lassign (i, e) -> << $id:jsident_of_ident i$ = $comp_expr false e$ >> (* XXX *)
+
+ | Lprim (Pccall { prim_name = "$inline_exp" }, [e]) -> inline_exp e
+
| Lprim (p, args) -> comp_prim p (List.map (comp_expr false) args)
| Lsend (_, Lconst(Const_immstring m), o, args) ->
@@ -524,6 +553,75 @@ and comp_letrecs_st tail expr k =
| e -> comp_expr_st tail e k in
cl expr
+(* XXX annoying, would be nice to Camlp4-generate this *)
+and inline_exp = function
+ (* XXX actually we never get these because of the _loc arg *)
+ | Lconst (Const_block _) as cb -> inline_exp (makeblock_of_const cb)
+
+ | Lprim (Pmakeblock (tag, _), args) ->
+ begin
+ match tag, args with
+ | 0, [_] -> Jthis _loc
+ | 1, [_; v] -> Jvar (_loc, inline_string v)
+ | 2, [_; el] -> Jarray (_loc, inline_exp_list el)
+ | 3, [_; kvs] ->
+ let rec inline_kv = function
+ | Lconst (Const_block _) as cb -> inline_kv (makeblock_of_const cb)
+ | Lprim (Pmakeblock (0, _), [k; v]) -> (inline_exp k, inline_exp v)
+ | _ -> raise (Failure "bad inline kv") in
+ Jobject (_loc, inline_list inline_kv kvs)
+ | 4, [_; s; qq] -> Jstring (_loc, inline_string s, inline_bool qq)
+ | 5, [_; s] -> Jnum (_loc, inline_string s)
+ | 6, [_] -> Jnull _loc
+ | 7, [_; b] -> Jbool (_loc, inline_bool b)
+ | 8, [_; so; sl; stl] ->
+ Jfun (_loc,
+ inline_option inline_string so,
+ inline_list inline_string sl,
+ inline_list inline_stmt stl)
+ | 9, [_; e; s] -> Jfieldref (_loc, inline_exp e, inline_string s)
+ | 10, [_; u; e] -> Junop (_loc, inline_unop u, inline_exp e)
+ | 11, [_; b; e1; e2] -> Jbinop (_loc, inline_binop b, inline_exp e1, inline_exp e2)
+ | 12, [_; i; t; e] -> Jite (_loc, inline_exp i, inline_exp t, inline_exp e)
+ | 13, [_; e; el] -> Jcall (_loc, inline_exp e, inline_exp_list el)
+ | 14, [_; e; elo] -> Jnew (_loc, inline_exp e, inline_option inline_exp_list elo)
+ | _ -> raise (Failure "bad inline exp")
+ end
+
+ | Lprim (Pccall { prim_name = "$inline_antiexp" }, [e]) -> comp_expr false e
+
+ | _ -> raise (Failure "bad inline exp")
+
+and inline_exp_list = function
+ | Lconst (Const_block _) as cb -> inline_exp_list (makeblock_of_const cb)
+ | Lprim (Pmakeblock (0, _), [_; el]) -> Jexp_list (_loc, inline_list inline_exp el)
+ | _ -> raise (Failure "bad inline exp_list")
+
+and inline_stmt = function
+ | _ -> raise (Failure "bad inline stmt")
+
+and inline_unop = function
+ | Lconst (Const_pointer tag) ->
+ let unops = [|
+ Jdelete; Jvoid; Jtypeof; Jadd2_pre; Jsub2_pre; Jadd_pre; Jsub_pre; Jtilde; Jnot; Jadd2_post; Jsub2_post
+ |] in
+ if tag < Array.length unops
+ then unops.(tag)
+ else raise (Failure "bad inline unop")
+ | _ -> raise (Failure "bad inline unop")
+
+and inline_binop = function
+ | Lconst (Const_pointer tag) ->
+ let binops = [|
+ Jhashref; Jmul; Jdiv; Jmod; Jadd; Jsub; Jlt; Jgt; Jleq; Jgeq; Jlsr; Jlsl; Jasr; Jeq; Jneq; Jinstanceof; Jseq;
+ Jsneq; Jland; Jlor; Jand; Jxor; Jor; Jcomma; Jassign; Jmul_assign; Jdiv_assign; Jmod_assign; Jadd_assign; Jsub_assign;
+ Jlsl_assign; Jlsr_assign; Jasr_assign; Jand_assign; Jxor_assign; Jor_assign
+ |] in
+ if tag < Array.length binops
+ then binops.(tag)
+ else raise (Failure "bad inline binop")
+ | _ -> raise (Failure "bad inline binop")
+
(**** Compilation of a lambda phrase ****)
let compile_implementation modulename expr =
View
@@ -2,9 +2,19 @@ name = "jslib"
version = "0.1"
description = "Javascript parsing, prettyprinting, tools"
requires = "camlp4.lib,ulex"
-requires(syntax,preprocessor) = "ulex"
-
archive(byte) = "jslib.cma"
archive(native) = "jslib.cmxa"
-archive(syntax,preprocessor) = "ulexing.cma,jslib.cma,pa_js.cma"
-archive(syntax,toploop) = "ulexing.cma,jslib.cma,pa_js.cma"
+
+package "quotations" (
+ description = "Syntax extension: Quotations to create AST nodes"
+ requires = "jslib"
+ requires(syntax,preprocessor) = "ulex"
+ archive(syntax,preprocessor) = "ulexing.cma,jslib.cma,syntax_quotations.cmo"
+ archive(syntax,toploop) = "ulexing.cma,jslib.cma,syntax_quotations.cmo"
+)
+
+package "inline" (
+ description = "Syntax extension: quotations for inline Javascript"
+ requires(syntax,preprocessor) = "ulex"
+ archive(syntax,preprocessor) = "ulexing.cma,jslib.cma,syntax_inline.cmo"
+)
View
@@ -1,14 +1,15 @@
FILES=\
jslib.cma jslib.cmxa jslib.a \
-pa_js.cma \
+syntax_quotations.cmo \
+syntax_inline.cmo \
jslib_ast.mli jslib_ast.cmi \
jslib_parse.mli jslib_parse.cmi \
jslib_pp.mli jslib_pp.cmi \
BFILES=$(addprefix _build/,$(FILES))
all: myocamlbuild.ml
- ocamlbuild jslib.cma jslib.cmxa pa_js.cma
+ ocamlbuild jslib.cma jslib.cmxa syntax_quotations.cmo syntax_inline.cmo
ocamlfind remove -destdir ../../stage jslib
ocamlfind install -destdir ../../stage jslib META $(BFILES)
View
@@ -1,4 +1,5 @@
<jslib_lexer.ml*>: syntax_camlp4o,pkg_camlp4,pkg_ulex
<jslib_parse.ml*>: syntax_camlp4o,pkg_camlp4,pkg_camlp4.extend
-<jslib_ast.ml*> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.foldgenerator,pkg_camlp4.metagenerator
-<pa_js.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
+<jslib_ast.ml*> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.foldgenerator,pkg_camlp4.metagenerator,pkg_camlp4.macro
+<syntax_quotations.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
+<syntax_inline.ml> : syntax_camlp4o,pkg_camlp4,pkg_camlp4.quotations,pkg_camlp4.extend
View
@@ -0,0 +1,94 @@
+type unop =
+ | Jdelete
+ | Jvoid
+ | Jtypeof
+ | Jadd2_pre
+ | Jsub2_pre
+ | Jadd_pre
+ | Jsub_pre
+ | Jtilde
+ | Jnot
+ | Jadd2_post
+ | Jsub2_post
+
+and binop =
+ | Jhashref
+ | Jmul
+ | Jdiv
+ | Jmod
+ | Jadd
+ | Jsub
+ | Jlt
+ | Jgt
+ | Jleq
+ | Jgeq
+ | Jlsr
+ | Jlsl
+ | Jasr
+ | Jeq
+ | Jneq
+ | Jinstanceof
+ | Jseq
+ | Jsneq
+ | Jland
+ | Jlor
+ | Jand
+ | Jxor
+ | Jor
+ | Jcomma
+ | Jassign
+ | Jmul_assign
+ | Jdiv_assign
+ | Jmod_assign
+ | Jadd_assign
+ | Jsub_assign
+ | Jlsl_assign
+ | Jlsr_assign
+ | Jasr_assign
+ | Jand_assign
+ | Jxor_assign
+ | Jor_assign
+
+and exp_list =
+ | Jexp_list of loc * exp list
+ | Jexp_list_Ant of loc * string
+
+and exp =
+ | Jthis of loc
+ | Jvar of loc * string
+ | Jarray of loc * exp_list
+ | Jobject of loc * (exp * exp) list
+ | Jstring of loc * string * bool (* true if double-quoted *)
+ | Jnum of loc * string
+ | Jnull of loc
+ | Jbool of loc * bool
+ | Jfun of loc * string option * string list * stmt list
+ | Jfieldref of loc * exp * string
+ | Junop of loc * unop * exp
+ | Jbinop of loc * binop * exp * exp
+ | Jite of loc * exp * exp * exp
+ | Jcall of loc * exp * exp_list
+ | Jnew of loc * exp * exp_list option
+ | Jexp_Ant of loc * string
+
+and stmt =
+ | Jempty of loc
+ | Jvars of loc * (string * exp option) list
+ | Jfuns of loc * string * string list * stmt list
+ | Jreturn of loc * exp option
+ | Jcontinue of loc * string option
+ | Jbreak of loc * string option
+ | Jswitch of loc * exp * (exp * stmt list) list * stmt list option
+ | Jites of loc * exp * stmt * stmt option
+ | Jthrow of loc * exp
+ | Jexps of loc * exp
+ | Jtrycatch of loc * stmt list * string * stmt list
+ | Jtryfinally of loc * stmt list * stmt list
+ | Jtrycatchfinally of loc * stmt list * string * stmt list * stmt list
+ | Jfor of loc * exp option * exp option * exp option * stmt
+ | Jdowhile of loc * stmt * exp
+ | Jwhile of loc * exp * stmt
+ | Jblock of loc * stmt list
+ | Jwith of loc * exp * stmt
+ | Jlabel of loc * string * stmt
+ | Jstmt_Ant of loc * string
View
@@ -16,100 +16,7 @@ struct
type loc = Loc.t
- and unop =
- | Jdelete
- | Jvoid
- | Jtypeof
- | Jadd2_pre
- | Jsub2_pre
- | Jadd_pre
- | Jsub_pre
- | Jtilde
- | Jnot
- | Jadd2_post
- | Jsub2_post
-
- and binop =
- | Jhashref
- | Jmul
- | Jdiv
- | Jmod
- | Jadd
- | Jsub
- | Jlt
- | Jgt
- | Jleq
- | Jgeq
- | Jlsr
- | Jlsl
- | Jasr
- | Jeq
- | Jneq
- | Jinstanceof
- | Jseq
- | Jsneq
- | Jland
- | Jlor
- | Jand
- | Jxor
- | Jor
- | Jcomma
- | Jassign
- | Jmul_assign
- | Jdiv_assign
- | Jmod_assign
- | Jadd_assign
- | Jsub_assign
- | Jlsl_assign
- | Jlsr_assign
- | Jasr_assign
- | Jand_assign
- | Jxor_assign
- | Jor_assign
-
- and exp_list =
- | Jexp_list of loc * exp list
- | Jexp_list_Ant of loc * string
-
- and exp =
- | Jthis of loc
- | Jvar of loc * string
- | Jarray of loc * exp_list
- | Jobject of loc * (exp * exp) list
- | Jstring of loc * string * bool (* true if double-quoted *)
- | Jnum of loc * string
- | Jnull of loc
- | Jbool of loc * bool
- | Jfun of loc * string option * string list * stmt list
- | Jfieldref of loc * exp * string
- | Junop of loc * unop * exp
- | Jbinop of loc * binop * exp * exp
- | Jite of loc * exp * exp * exp
- | Jcall of loc * exp * exp_list
- | Jnew of loc * exp * exp_list option
- | Jexp_Ant of loc * string
-
- and stmt =
- | Jempty of loc
- | Jvars of loc * (string * exp option) list
- | Jfuns of loc * string * string list * stmt list
- | Jreturn of loc * exp option
- | Jcontinue of loc * string option
- | Jbreak of loc * string option
- | Jswitch of loc * exp * (exp * stmt list) list * stmt list option
- | Jites of loc * exp * stmt * stmt option
- | Jthrow of loc * exp
- | Jexps of loc * exp
- | Jtrycatch of loc * stmt list * string * stmt list
- | Jtryfinally of loc * stmt list * stmt list
- | Jtrycatchfinally of loc * stmt list * string * stmt list * stmt list
- | Jfor of loc * exp option * exp option * exp option * stmt
- | Jdowhile of loc * stmt * exp
- | Jwhile of loc * exp * stmt
- | Jblock of loc * stmt list
- | Jwith of loc * exp * stmt
- | Jlabel of loc * string * stmt
- | Jstmt_Ant of loc * string
+ INCLUDE "../jslib_ast.incl"
end
Oops, something went wrong.

0 comments on commit aa568d8

Please sign in to comment.