PREFIX:=/usr/local
.PHONY: clean all
-.SUBDIRS: scm xml driver
+.SUBDIRS: scm xml driver base
habc-scm: scm/src/habc-scm
cp $^ .
-########################################################################
-# Permission is hereby granted, free of charge, to any person
-# obtaining a copy of this file, to deal in the File without
-# restriction, including without limitation the rights to use,
-# copy, modify, merge, publish, distribute, sublicense, and/or
-# sell copies of the File, and to permit persons to whom the
-# File is furnished to do so, subject to the following condition:
-#
-# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
-# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
-# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
-# THE USE OR OTHER DEALINGS IN THE FILE.
-
-########################################################################
-# Phony targets are scoped, so you probably want to declare them first.
-#
-
.PHONY: all install clean
-########################################################################
-# Subdirectories.
-# You may want to include some subdirectories in this project.
-# If so, define the subdirectory targets and uncomment this section.
-#
-
-# .SUBDIRS:
-
-########################################################################
-# C configuration.
-# Delete this section if you are not building C files.
-#
-
-################################################
-# Configuration. You might want to modify any of these
-# configuration variables.
-#
-
-# CFLAGS +=
-# ASFLAGS +=
-# LDFLAGS +=
-# INCLUDES +=
-
-################################################
-# Uncomment the following section if you want
-# to build a C program in the current directory.
-#
-
-# CFILES[] =
-# file1
-# main
-#
-# MAIN = main
-#
-# .DEFAULT: $(CProgram $(MAIN), $(CFILES))
-
-################################################
-# Uncomment the following section if you want to build a C library
-# in the current directory.
-#
-
-# LIBFILES[] =
-# file1
-# file2
-#
-# LIB = libxxx
-#
-# .DEFAULT: $(StaticCLibrary $(LIB), $(LIBFILES))
-
-########################################################################
-# OCaml configuration.
-# Delete this section if you are not building OCaml files.
-#
-
################################################
# Configuration. You may want to modify any of these configuration
# variables.
# This project requires ocamlfind (default - false).
#
USE_OCAMLFIND = true
-#
OCAMLPACKS[] =
extlib
#
# Include path
#
-# OCAMLINCLUDES +=
+OCAMLINCLUDES += ../base
#
-# Compile native or byte code?
+# Compile native or byte code?
#
# The default values are defined as follows:
#
-# NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-# BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS))
+NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
+BYTE_ENABLED = true
#
# Various options
# OCAML_BYTE_LINK_FLAGS +=
# OCAML_NATIVE_LINK_FLAGS +=
-################################################
-# Generated files
-#
-# Workaround for the fact that ocamldep does not pay attention to .mll
-# and .mly files.
-#
-# OCamlGeneratedFiles(parser.ml lexer.ml)
-
-################################################
-# Build an OCaml library
-#
-
-# FILES[] =
-# file1
-# file2
-#
-# LIB = main
-#
-# .DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-################################################
+####################################################
# Build an OCaml program
#
FILES[] =
- main
+ main
PROGRAM = habc
-# OCAML_LIBS += unix
-# OCAML_CLIBS +=
+OCAML_LIBS += ../base/base
OCAML_OTHER_LIBS += unix
-# OCAML_LIB_FLAGS +=
-#
+
.DEFAULT: $(OCamlProgram $(PROGRAM), $(FILES))
let flip f x y = f y x
let tee f x = try ignore (f x); x with _ -> x
-(* options *)
-let opt_parser =
- OptParser.make ~version:"<VERSION>" ~usage:"habc [options] <file>" ()
-
let default_template =
let base =
Filename.dirname Sys.executable_name in
else
Filename.concat base "../share/habc/template.xml"
+
+(* options *)
+let opt_parser =
+ OptParser.make ~version:Config.version ~usage:"habc [options] <file>" ()
+
let template =
StdOpt.str_option
~default:default_template
#
# Include path
#
-# OCAMLINCLUDES +=
+
#
# Compile native or byte code?
tuple
varResolve
+OCAMLINCLUDES += ../../base/
+OCAML_LIBS += ../../base/base
+
PROGRAM = habc-scm
# OCAML_OTHER_LIBS +=
.DEFAULT: $(OCamlProgram $(PROGRAM), main $(FILES))
-
OCamlLibrary($(PROGRAM), $(FILES))
doc :
let main () =
let opt =
- OptParser.make ~version:"0.1.0" () in
+ OptParser.make ~version:Config.version () in
let output =
StdOpt.str_option ~default:"a.abc" ~metavar:"<output>" () in
let _ =
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 32
-/svn/!svn/ver/2115/ocaml/abc2xml
-END
-.gitignore
-K 25
-svn:wc:ra_dav:version-url
-V 43
-/svn/!svn/ver/1590/ocaml/abc2xml/.gitignore
-END
-.ocamlinit
-K 25
-svn:wc:ra_dav:version-url
-V 43
-/svn/!svn/ver/1738/ocaml/abc2xml/.ocamlinit
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml
-http://www.libspark.org/svn
-
-
-
-2009-01-01T03:45:39.943606Z
-2115
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-test
-dir
-\f
-camlp4
-dir
-\f
-trunk
-dir
-\f
-branches
-dir
-\f
-.gitignore
-file
-
-
-
-
-2009-01-03T13:12:28.000000Z
-35139acfe64f7d74ffae5b097f0e9b0e
-2008-10-12T00:57:44.911926Z
-1590
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-93
-\f
-example
-dir
-\f
-.ocamlinit
-file
-
-
-
-
-2009-01-03T13:12:28.000000Z
-3146d283b86fd7cf21e58e872399bc85
-2008-10-28T11:08:30.933551Z
-1738
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-271
-\f
-tags
-dir
-\f
+++ /dev/null
-.omakedb
-.omakedb.lock
-*.omc
-*~
-*.cm[iox]
-*.o
-abc2xml
-runner
-*.opt
-*.run
-*.cm[ax]
-*.cmxa
-*.a
+++ /dev/null
-#use "topfind";;
-#load "camlp4o.cma";;
-#load "camlp4/pa_oo.cmo";;
-
-#require "oUnit";;
-#require "extlib";;
-#require "xml-light";;
-
-#load "base.cmo";;
-#load "parsec.cmo";;
-#load "byte.cmo";;
-#load "easyXml.cmo";;
-#load "disasm.cmo";;
-#load "abc.cmo";;
-#load "action.cmo";;
.PHONY: check clean
-.SUBDIRS: test camlp4 swflib utils xml classdump
+.SUBDIRS: test camlp4 src
-habc-xml: xml/habc-xml
- cp $^ $@
-
-
-.DEFAULT: habc-xml
+.DEFAULT: src/habc-xml
clean:
- rm -f habc-xml habc-xml.opt habc-xml.run *.omc .omakedb .omakedb.lock
\ No newline at end of file
+ rm -f habc-xml habc-xml.opt habc-xml.run *.omc .omakedb .omakedb.lock
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 45
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/camlp4
-END
-pa_oo.ml
-K 25
-svn:wc:ra_dav:version-url
-V 54
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/camlp4/pa_oo.ml
-END
-pa_monad.ml
-K 25
-svn:wc:ra_dav:version-url
-V 57
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/camlp4/pa_monad.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/camlp4/OMakefile
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/camlp4
-http://www.libspark.org/svn
-
-
-
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-pa_oo.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-baa41fb5f5a5d274564103f6802dc9e7
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-4342
-\f
-pa_monad.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-2a51d91eae8e4995a30d931e09b1aa6e
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-24465
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-904fc9bce5e43fe3c34e6b7c4d2d03e5
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-906
-\f
+++ /dev/null
-########################################################################
-# Phony targets are scoped, so you probably want to declare them first.
-#
-.PHONY: clean
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc
-
-########################################################################
-# OCaml configuration.
-# Delete this section if you are not building OCaml files.
-#
-
-USE_OCAMLFIND = false
-
-#
-# Include path
-#
-OCAMLINCLUDES += -I +camlp4
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-OCAMLPPFLAGS += -pp camlp4orf
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-
-################################################
-# Build an OCaml program
-#
-OCamlProgram(pa_oo,pa_oo)
-
-OCamlProgram(pa_monad,pa_monad)
+++ /dev/null
-(* name: pa_monad.ml
- * synopsis: Haskell-like "do" for monads
- * authors: Jacques Carette and Oleg Kiselyov,
- * based in part of work of Lydia E. Van Dijk
- * last revision: Sat Aug 11 06:21:17 UTC 2007
- * ocaml version: 3.10.0
- *
- * Copyright (C) 2006, 2007 J. Carette, L. E. van Dijk, O. Kiselyov
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Library General Public
- * License as published by the Free Software Foundation; either
- * version 2 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Library General Public License for more details.
- *
- * You should have received a copy of the GNU Library General Public
- * License along with this library; if not, write to the Free
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- *)
-
-
-(** {2 Syntax Extension to Support Monads}
-
-This module extends OCaml's syntax by a Haskell-like "do"-notation
-particularly suited for the work with monads.
-
-By the nature of the translation process (at pre-processing time,
-before compilation) it cannot be guaranteed that the result code
-actually obeys the three fundamental laws for all monads:
-+ [bind (return x) f] is identical to [f x]
-+ [bind m return] is identical to [m]
-+ [bind (bind m f) g] is identical to [bind m (fun x -> bind (f x) g)]
-
-where [bind] and [return] are user defined functions. Incidentally, in
-Haskell, too, it is entirely the responsibility of the programmer to
-make sure that [bind] and [return] implemented for a particular Monad
-do indeed obey the above laws.
-
-
-{2 Conversion Rules}
-
-{3 Grammar informally}
-We support four different constructs to introduce a monadic
-expressions.
-- [perform exp]
-- [perform exp1; exp2]
-- [perform x <-- exp1; exp2]
-- [perform let x = foo in exp]
-
-which is almost literally the grammar of the Haskell's "do"-notation,
-with the differences that Haskell uses "do" and "<-" where we use
-"[perform]" and "[<--]".
-
-We support not only [let x = foo in ...] expressions but arbitrarily
-complex [let]-expressions, including [let rec] and [let module].
-
-
-{4 Extended Forms}
-The actual bind function of the monad defaults to "[bind]" and the
-match-failure function to "[failwith]" (only used for refutable
-patterns; see below). To select a different function, use the
-extended forms of "[perform]".
-
-{b Expression:} Use the given expression as bind-function and apply
-the default match-failure function ([failwith]) where necessary.
-{[
- perform with exp1 in exp2
- perform with exp1 in exp3; exp4
- perform with exp1 in x <-- exp2; exp3
- perform with exp in let x = foo in exp
-]}
-Use the first given expression ([exp1]) as bind-function and the
-second ([exp2]) as match-failure function.
-{[
- perform with exp1 and exp2 in exp3
- perform with exp1 and exp2 in exp3; exp4
- perform with exp1 and exp2 in x <-- exp3; exp4
- perform with exp1 and exp2 in let x = foo in exp1
-]}
-
-{b Module:} Use the function named "[bind]" from module "[Mod]". In
-addition use the module's "[failwith]"-function in refutable patterns.
-{[
- perform with module Mod in exp2
- perform with module Mod in exp3; exp4
- perform with module Mod in x <-- exp2; exp3
- perform with module Mod in let x = foo in exp
-]}
-
-
-{4 Refutable Patterns}
-An irrefutable pattern is either:
-- A variable,
-- The wildcard "[_]",
-- The constructor "[()]",
-- A tuple with irrefutable patterns,
-- A record with irrefutable patterns, or
-- An irrefutable pattern with a type constraint.
-Any other pattern is refutable.
-
-Why do we need this distinction? Well, the expression
-{[
- perform x <-- exp1; exp2
-]}
-expands to
-{[
- bind exp2 (fun x -> exp1)
-]}
-where pattern match can never fail as "[x]" can take any value. This
-is an example of an irrefutable pattern. No catch-all branch is
-required here. Compare this with
-{[
- perform 1 <-- exp1; exp2
-]}
-which expands to
-{[
- bind exp2 (fun 1 -> exp1 | _ -> failwith "pattern match")
-]}
-As the match can fail -- "[1]" being a refutable pattern in this
-position -- we must add a second branch that catches the remaining
-values. The user is free to override the "[failwith]" function with
-her own version.
-
-Refer to the thread on the Haskell mailing list concerning the topic
-of {{:http://www.haskell.org/pipermail/haskell/2006-January/017237.html}
-refutable patterns} and an excerpt from an earlier
-{{:http://www.cs.chalmers.se/~rjmh/Haskell/Messages/Decision.cgi?id=2}
-discussion} on the same issue.
-
-
-{3 Grammar formally}
-Formally the grammar of [pa_monad] can be specified as follows.
-{[
- "perform" ["with" <user-function-spec> "in"] <perform-body>
- <user-function-spec> ::=
- EXPR ["and" EXPR]
- | "module" MODULE-NAME
- <binding> ::=
- PATTERN "<--" EXPR
- <perform-body> ::=
- <LET-FORM> <perform-body>
- | EXPR
- | <binding> ";" <perform-body>
- | "rec" <binding> ["and" <binding> [...]] ";" <perform-body>
-]}
-where [EXPR] is an OCaml expression {i expr} as defined in Section 6.7
-of the OCaml manual, [MODULE-NAME] a {i module-name} (Sec. 6.3),
-[LET-FORM] is any of the [let], [let rec], or [let module] {i let-forms}
-(Sec. 6.7), and [PATTERN] a {i pattern} (Sec. 6.6).
-
-The "[rec]" keyword allows for a recursive binding in
-{[
- "rec" PATTERN "<--" EXPR
- "and" PATTERN "<--" EXPR
- ...
- "and" PATTERN "<--" EXPR ";"
-]}
-The syntax extension groups all bindings in a "[rec]"-"[and]", but
-it does not group consecutive "[rec]"-bindings. This grouping is
-sometimes called segmentation.
-
-Example:
-Define a recursive group of bindings consisting of three patterns
-(PATTERN1-PATTERN3) and expressions (EXPR1-EXPR3), a non-recursive
-binding PATTERN4/EXPR4, and finally a single recursive binding
-PATTERN5/EXPR5:
-{[
- "rec" PATTERN1 "<--" EXPR1
- "and" PATTERN2 "<--" EXPR2
- "and" PATTERN3 "<--" EXPR3 ";"
- PATTERN4 "<--" EXPR4 ";"
- "rec" PATTERN5 "<--" EXPR5 ";"
-]}
-Please consult Section 7.3 of the Manual for valid recursive
-definitions of values, as the only allowed [PATTERN] in the recursive
-case is a [NAME], similarly stringent restrictions apply to [EXPR].
-The theoretical aspects of recursive monadic bindings can be found in
-Levent Erkök, John Launchbury: "{i A Recursive do for Haskell}".
-
-
-For any ['a monad] the expansion uses the functions "[bind]" and
-"[failwith]" with the signatures
-{[
- val bind: 'a monad -> ('a -> 'b monad) -> 'b monad
- val failwith: string -> 'a monad
-]}
-unless overridden by the user. Analogously, the signatures of modules
-used in the "[with module]"-form must enclose
-{[
- sig
- type 'a monad
- val bind: 'a monad -> ('a -> 'b monad) -> 'b monad
- val failwith: string -> 'a monad
- end
-]}
-
-
-{3 Semantics (as re-writing into the core language)}
-In this section, we abbreviate irrefutable patterns with [ipat] and
-refutable patterns with [rpat].
-{[
- perform exp1 ===> exp1
- perform ipat <-- exp; rest ===> bind exp (fun ipat -> perform rest)
- perform rpat <-- exp; rest ===> bind exp (fun rpat -> perform rest
- | _ -> failwith "pattern match")
- perform let ... in rest ===> let ... in perform rest
- perform exp; rest ===> bind exp (fun _ -> perform rest)
-
- perform with bexp in body
- ===> perform body
- where bind is substituted with bexp
-
- perform with bexp and fexp in body
- ===> perform body
- where bind is substituted with bexp and
- failwith is substituted with fexp
-
- perform with module Mod in body
- ===> perform body
- where bind is substituted with Mod.bind and
- failwith with Mod.failwith
-]}
-
-
-{4 Implementation Notes And Design Decisions}
-It is be possible to use "[<-]" instead of "[<--]". In that case, the
-similarity to the "[do]" notation of Haskell will be complete.
-However, if the program has [_ <- exp] outside of [perform], this will
-be accepted by the parser (and create an (incomprehensible) error
-later on. It is better to use a dedicated symbol "[<--]", so if the
-user abuses it, the error should be clear right away.
-
-The major difficulty with the [perform] notation is that it cannot
-truly be parsed by an LR-grammar. Indeed, to figure out if we should
-start parsing <perform-body> as an expression or a pattern, we have to
-parse it as a pattern and check for the "[<--]" delimiter. If it is
-not there, we should {e backtrack} and parse it again as an
-expression. Furthermore, [a <-- b] (or [a <- b]) can also be parsed
-as an expression. However, some patterns, for example ([_ <-- exp]),
-cannot be parsed as an expression.
-
-It is possible (via some kind of flag) to avoid parsing [_ <-- exp]
-outside of perform. But this becomes quite complex and unreliable. To
-record a particular expression [patt <-- exp] in AST, we use the node
-{[
- <:expr< let [(patt, exp)] in $lid:"<--"$ >>
-]}
-If the construction [_ <-- exp] is used by mistake, we get an error
-message about an unbound identifier "<--", which is our intention.
-
-
-{2 Known Issues}
-
-- Sum types are assumed to have more than one constructor, thus always
- yield refutable patterns. This is, if you define
- {[
- type t = T
- ]}
- and later use
- {[
- perform T <- T; ...
- ]}
- you get "Warning U: this match case is unused." which is not deserved.
-
-- Aliases in patterns are not supported yet. Code like
- {[
- perform
- ((x, y, z) as tuple) <-- 1, 2, 3;
- ...
- ]}
- blows the extension out of the water. As a matter of fact, it is
- not clear that this should be supported at all: patterns with
- aliases are not "simple patterns" (see {i pa_o.ml}). For example,
- patterns with aliases cannot be used in [fun pattern -> ...]. Thus,
- at present monadic bindings should include only those patterns that
- are permissible in [fun]. And perhaps this is the optimal decision.
-
-- The recursive form "[rec ... <-- ...]" is not implemented completely.
- It lacks support for a (user-sepecified) fix-point function. See
- for example Erkök and Launchbury's
- {{:http://www.cse.ogi.edu/PacSoft/projects/rmb/recdo.ps.gz} "A
- Recursive do for Haskell"}.
- *)
-
-
-open Camlp4.PreCast
-open Syntax
-
-
-(** [failure_text]
-
- This is the text that accompanies a match failure of a refutable
- pattern. *)
-let failure_text = "pattern match"
-
-
-(** [default_bind_expr _loc]
-
- This is the default expression for the "bind" function. *)
-let default_bind_expr (_loc: Ast.Loc.t): Ast.expr =
- <:expr< bind >>
-
-
-(** [default_failure_fun_expr _loc]
-
- This is the expression for the default "failwith" function. *)
-let default_failure_fun_expr (_loc: Ast.Loc.t): Ast.expr =
- <:expr< failwith >>
-
-
-(** [default_failure_expr _loc]
-
- This is the expression for the default "failwith" function
- ({!Pa_monad.default_failure_fun_expr}) after the
- {!Pa_monad.failure_text} has been applied. *)
-let default_failure_expr (_loc: Ast.Loc.t): Ast.expr =
- let fun_expr = default_failure_fun_expr _loc
- and text_expr = <:expr< $str:failure_text$ >> in
- <:expr< $fun_expr$ $text_expr$ >>
-
-
-(** [exp_to_patt _loc an_expression]
-
- Convert [an_expression] to a (simple) pattern, if we "accidentally" parse
- a pattern as an expression. *)
-(* The code is based on [pattern_eq_expression] in {i pa_fstream.ml}. *)
-let rec exp_to_patt (_loc: Ast.Loc.t) (an_expression: Ast.expr): Ast.patt =
- match an_expression with
- <:expr< $int:s$ >> -> <:patt< $int:s$ >> (* integer constant *)
- | <:expr< $chr:c$ >> -> <:patt< $chr:c$ >> (* character constant *)
- | <:expr< $str:s$ >> -> <:patt< $str:s$ >> (* string constant *)
- | <:expr< $lid:b$ >> -> <:patt< $lid:b$ >> (* local variable *)
- | <:expr< $uid:b$ >> -> <:patt< $uid:b$ >> (* variable of other module *)
- | <:expr< $e1$ $e2$ >> -> (* function application *)
- let p1 = exp_to_patt _loc e1
- and p2 = exp_to_patt _loc e2 in
- <:patt< $p1$ $p2$ >>
- | <:expr< ($tup:e$) >> -> (* tuple *)
- let p = exp_to_patt _loc e in
- <:patt< ($tup:p$) >>
- | <:expr< $e1$, $e2$ >> ->
- let p1 = exp_to_patt _loc e1
- and p2 = exp_to_patt _loc e2 in
- <:patt< $p1$, $p2$ >>
- | <:expr< { $rec_binding:r$ } >> -> (* record *)
- let p = recbinding_to_patt _loc r in
- <:patt< { $p$ } >>
- | <:expr< ($e$ : $t$) >> -> (* type restriction *)
- let p = exp_to_patt _loc e in
- <:patt< ($p$ : $t$) >>
- | _ -> Loc.raise _loc
- (Stream.Error "exp_to_patt: this pattern is not yet supported")
-(** [recbinding_to_pattrec _loc an_exp_record]
-
- Convert [an_exp_record] to a pattern matching a record. *)
-and recbinding_to_patt (_loc: Ast.Loc.t) (an_exp_record: Ast.rec_binding): Ast.patt =
- match an_exp_record with
- <:rec_binding< >> -> <:patt< >>
- | <:rec_binding< $i$ = $e$ >> ->
- let p = exp_to_patt _loc e in
- <:patt< $i$ = $p$ >>
- | <:rec_binding< $b1$ ; $b2$ >> ->
- let p1 = recbinding_to_patt _loc b1
- and p2 = recbinding_to_patt _loc b2 in
- <:patt< $p1$; $p2$ >>
- | <:rec_binding< $anti:_$ >> ->
- Loc.raise _loc
- (Stream.Error "recbinding_to_patt: antiquotations are not yet supported")
-
-
-(** [patt_to_exp _loc a_pattern]
-
- Convert [a_pattern] to an expression, if we must reuse it an a
- different semantic position. *)
-let rec patt_to_exp (_loc: Ast.Loc.t) (a_pattern: Ast.patt): Ast.expr =
- match a_pattern with
- <:patt< $int:s$ >> -> <:expr< $int:s$ >> (* integer constant *)
- | <:patt< $chr:c$ >> -> <:expr< $chr:c$ >> (* character constant *)
- | <:patt< $str:s$ >> -> <:expr< $str:s$ >> (* string constant *)
- | <:patt< $lid:b$ >> -> <:expr< $lid:b$ >> (* local variable *)
- | <:patt< $uid:b$ >> -> <:expr< $uid:b$ >> (* variable of other module *)
- | <:patt< $e1$ $e2$ >> -> (* function application *)
- let p1 = patt_to_exp _loc e1
- and p2 = patt_to_exp _loc e2 in
- <:expr< $p1$ $p2$ >>
- | <:patt< ($tup:p$) >> -> (* tuple *)
- let e = patt_to_exp _loc p in
- <:expr< ($tup:e$) >>
- | <:patt< $p1$, $p2$ >> ->
- let e1 = patt_to_exp _loc p1
- and e2 = patt_to_exp _loc p2 in
- <:expr< $e1$, $e2$ >>
- | <:patt< { $r$ } >> ->
- <:expr< { $rec_binding:patt_to_recbinding _loc r$ } >>
- | <:patt< ($e$ : $t$) >> -> (* type restriction *)
- let p = patt_to_exp _loc e in
- <:expr< ($p$ : $t$) >>
- | _ ->
- Loc.raise _loc
- (Stream.Error "patt_to_exp: this expression is not yet supported")
-and patt_to_recbinding (_loc: Ast.Loc.t) (a_pattern: Ast.patt): Ast.rec_binding =
- match a_pattern with
- <:patt< >> -> <:rec_binding< >>
- | <:patt< $i$ = $p$ >> ->
- let p = patt_to_exp _loc p in
- <:rec_binding< $i$ = $p$ >>
- | <:patt< $p1$ ; $p2$ >> ->
- let b1 = patt_to_recbinding _loc p1
- and b2 = patt_to_recbinding _loc p2 in
- <:rec_binding< $b1$; $b2$ >>
- | <:patt< $anti:_$ >> ->
- Loc.raise _loc
- (Stream.Error "patt_to_recbinding: antiquotation are not yet supported")
- | _ -> Loc.raise _loc (Stream.Error "patt_to_recbinding: not reached")
-
-
-(** [is_irrefutable_pattern a_pattern]
-
- Answer whether [a_pattern] is irrefutable.
-
- Implementation Note: In OCaml 3.10.0 the function
- [Ast.is_irrefut_patt] is buggy. Thus, we must use our own
- implementation. *)
-let rec is_irrefutable_pattern (a_pattern: Ast.patt): bool =
- match a_pattern with
- <:patt< () >> -> true (* unit *)
- | <:patt< ( $p$ : $_$ ) >> -> (* type constraint *)
- is_irrefutable_pattern p
- | <:patt< ( $p1$ as $_p2$ ) >> -> (* alias *)
- is_irrefutable_pattern p1
- | <:patt< { $r$ } >> -> (* record *)
- is_irrefutable_pattern r
- | <:patt< $_$ = $p$ >> -> (* field in a record *)
- is_irrefutable_pattern p
- | <:patt< $r1$; $r2$ >> -> (* sum of fields *)
- is_irrefutable_pattern r1 && is_irrefutable_pattern r2
- | <:patt< $t1$, $t2$ >> -> (* sum in a tuple *)
- is_irrefutable_pattern t1 && is_irrefutable_pattern t2
- | <:patt< ($tup:t$) >> -> (* tuple *)
- is_irrefutable_pattern t
- | <:patt< $lid:_$ >> -> true (* variable *)
- | <:patt< _ >> -> true (* wildcard *)
- | _ -> false
-
-
-(** [tuplify_expr _loc an_expression_list]
-
- Convert [an_expression_list] to a tuple of expressions. *)
-let tuplify_expr (_loc: Ast.Loc.t) (an_expression_list: Ast.expr list): Ast.expr =
- match an_expression_list with
- [] -> Loc.raise _loc (Stream.Error "tuplify_expr: empty expression list")
- | x :: [] -> x
- | _ -> <:expr< ($tup:Ast.exCom_of_list an_expression_list$) >>
-
-
-(** [tuplify_patt _loc a_pattern_list]
-
- Convert [a_pattern_list] to a tuple of patterns. *)
-let tuplify_patt (_loc: Ast.Loc.t) (a_pattern_list: Ast.patt list): Ast.patt =
- match a_pattern_list with
- [] -> Loc.raise _loc (Stream.Error "tuplify_patt: empty pattern list")
- | x :: [] -> x
- | _ -> <:patt< ($tup:Ast.paCom_of_list a_pattern_list$) >>
-
-
-(** [convert _loc a_perform_body a_bind_function a_fail_function]
-
- Convert all expressions of [a_perform_body] inside [perform] into
- core OCaml. Use [a_bind_function] as the monad's "bind"-function,
- and [a_fail_function] as the "failure"-function. *)
-let convert
- (_loc: Ast.Loc.t)
- (a_perform_body: Ast.expr)
- (a_bind_function: Ast.expr)
- (a_fail_function: Ast.expr): Ast.expr =
- let rec loop _loc a_perform_body =
- match a_perform_body with
- <:expr< let $rec:_$ $_$ in $lid:"<--"$ >> ->
- Loc.raise _loc
- (Stream.Error "convert: monadic binding cannot be last a \"perform\" body")
- | <:expr< let $rec:r$ $binding:bs$ in $body$ >> ->
- let body' = loop _loc body in
- <:expr< let $rec:r$ $binding:bs$ in $body'$ >>
- | <:expr< let module $m$ = $mb$ in $body$ >> ->
- let body' = loop _loc body in
- <:expr< let module $m$ = $mb$ in $body'$ >>
- | <:expr< do { $e$ } >> ->
- let b1, b2, bs =
- match Ast.list_of_expr e [] with
- b1 :: b2 :: bs -> b1, b2, bs
- | _ -> assert false in
- let do_rest () =
- loop _loc
- (match bs with
- [] -> b2
- | _ -> <:expr< do { $list:(b2 :: bs)$ } >>)
- and do_merge a_body =
- loop _loc <:expr< do { $list:(a_body :: b2 :: bs)$ } >> in
- begin
- match b1 with
- (* monadic binding *)
- <:expr< let $p$ = $e$ in $lid:"<--"$ >> ->
- if is_irrefutable_pattern p then
- <:expr< $a_bind_function$ $e$ (fun $p$ -> $do_rest ()$) >>
- else
- <:expr< $a_bind_function$
- $e$
- (fun [$p$ -> $do_rest ()$
- | _ -> $a_fail_function$ ]) >>
- (* recursive monadic binding *)
- | <:expr< let rec $binding:b$ in $lid:"<--"$ >> ->
- let pattern_list = List.map fst (Ast.pel_of_binding b) in
- let patterns = tuplify_patt _loc pattern_list
- and patt_as_exp =
- tuplify_expr
- _loc
- (List.map (fun x -> patt_to_exp _loc x) pattern_list)
- in
- List.iter
- (fun p ->
- if not (is_irrefutable_pattern p) then
- Loc.raise _loc
- (Stream.Error
- ("convert: refutable patterns and " ^
- "recursive bindings do not go together")))
- pattern_list;
- <:expr< let rec $binding:b$ in
- $a_bind_function$
- $patt_as_exp$
- (fun $patterns$ -> $do_rest ()$) >>
- | (* map through the regular let *)
- <:expr< let $rec:r$ $binding:bs$ in $body$ >> ->
- <:expr< let $rec:r$ $binding:bs$ in $do_merge body$ >>
- | <:expr< let module $m$ = $mb$ in $body$ >> ->
- <:expr< let module $m$ = $mb$ in $do_merge body$ >>
- | _ -> <:expr< $a_bind_function$ $b1$ (fun _ -> $do_rest ()$) >>
- end
- | any_body -> any_body
- in loop _loc a_perform_body
-
-
-(** [qualify _loc a_module_expression a_function_expression]
-
- Append [a_function_expression] to the module name given in
- [a_module_expression], this is, qualify [a_function_expression] by
- [a_module_expression]. Fail if [a_module_expression] is not a valid
- module name. *)
-let qualify
- (_loc: Ast.Loc.t)
- (a_module_ident: Ast.ident)
- (a_function_expression: Ast.expr): Ast.expr =
- let me = <:expr< $id:a_module_ident$ >> in
- <:expr< $me$ . $a_function_expression$ >>
-
-
-(* Here we have to do the same nasty trick that Camlp4 uses and even
- * mentions in its documentation (viz. 'horrible hack' in pa_o.ml). We
- * see if we can expect [patt <--] succeed. Here [patt] is a simple
- * pattern and it definitely does not parse as an expression.
- * Rather than resorting to unlimited lookahead and emulating the
- * Pcaml.patt LEVEL simple grammar, we do it the other way around: We
- * make sure that a pattern can always be parsed as an expression and
- * declare "[_]" a valid identifier! If you attempt to use it,
- * you will get an undefined identifier anyway, so it is safe. *)
-
-EXTEND Gram
- GLOBAL: expr;
-
- expr: LEVEL "top"
- [
- [ "perform"; "with"; "module"; monad_module = uid; "in";
- perform_body = expr LEVEL ";" ->
- let qualified_fail_expr =
- qualify _loc monad_module (default_failure_fun_expr _loc) in
- convert _loc
- perform_body
- (qualify _loc monad_module (default_bind_expr _loc))
- <:expr< $qualified_fail_expr$ $str:failure_text$ >> ]
- |
- [ "perform"; "with"; bind_fun = expr;
- fail_fun = OPT opt_failure_expr; "in";
- perform_body = expr LEVEL ";" ->
- convert _loc
- perform_body
- bind_fun
- (match fail_fun with
- None -> default_failure_expr _loc
- | Some f -> <:expr< $f$ $str:failure_text$ >>) ]
- |
- [ "perform";
- perform_body = expr LEVEL ";" ->
- convert _loc
- perform_body
- (default_bind_expr _loc)
- (default_failure_expr _loc) ]
- ] ;
-
- uid:
- [
- [i = LIST1 a_UIDENT SEP "." ->
- let rec uid_to_ident = function
- [a]-> <:ident< $uid:a$ >>
- | a :: b -> <:ident< $uid:a$.$uid_to_ident b$ >>
- | [] -> assert false
- in
- uid_to_ident i]
- ];
-
- opt_failure_expr:
- [
- [ "and"; fail_fun = expr -> fail_fun ]
- ] ;
-
- recursive_monadic_binding:
- [
- [ e1 = expr LEVEL "simple"; "<--"; e2 = expr LEVEL "top" ->
- <:binding< $exp_to_patt _loc e1$ = $e2$ >>
- ]
- ] ;
-
- expr: BEFORE "apply"
- [ NONA
- [ "rec"; binding_list = LIST1 recursive_monadic_binding SEP "and" ->
- let bind = Ast.biAnd_of_list binding_list in
- <:expr< let rec $binding:bind$ in $lid:"<--"$ >> ]
- |
- [ e1 = SELF; "<--"; e2 = expr LEVEL "top" ->
- let p1 = exp_to_patt _loc e1 in
- <:expr< let $p1$ = $exp:e2$ in $lid:"<--"$ >> ]
- ] ;
-
- (* The difference between the expression and patterns is just [_].
- * So, we make [_] identifier. *)
- expr: LEVEL "simple"
- [
- [ "_" -> <:expr< $lid:"_"$ >> ]
- ] ;
-
-END;
+++ /dev/null
-(*
- Copyright (c) 2008, Jacques Garrigue
- All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
-
- 1 Redistributions of source code must retain the above copyright notice, this
- list of conditions and the following disclaimer.
-
- 2 Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
-
- 3 The name of the author may not be used to endorse or promote products
- derived from this software without specific prior written permission.
-
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *)
-
-(* $Id: pa_oo.ml,v 1.6 2008/05/02 06:03:23 garrigue Exp $ *)
-
-(*
- To compile:
- ocamlc -I +camlp4 -c -pp camlp4orf pa_oo.ml
- To use:
- ocaml camlp4o.cma pa_oo.cmo
- or
- ocamlc -pp 'camlp4o -I . pa_oo.cmo'
-*)
-
-open Camlp4.PreCast
-
-module Caml = Syntax
-
-let expand_access _loc mut id e kind =
- let id' = id^"'" in
- let reader = <:class_str_item< method $id$ = $lid:id$ >>
- and writer =
- <:class_str_item< method $"set_"^id$ $lid:id'$ = $lid:id$ := $lid:id'$ >>
- in
- let accessors =
- match kind with None -> <:class_str_item<>>
- | Some k -> match k with
- | `R -> reader
- | `W -> writer
- | `RW -> <:class_str_item< $reader$; $writer$ >>
- in
- <:class_str_item< value $mutable:mut$ $lid:id$ = $e$; $accessors$ >>
-
-(* Copied from camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml *)
-let bigarray_set _loc var newval =
- match var with
- | <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
- Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
- | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
- Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
- | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
- Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
- | <:expr< Bigarray.Genarray.get $arr$ [| $coords$ |] >> ->
- Some <:expr< Bigarray.Genarray.set $arr$ [| $coords$ |] $newval$ >>
- | _ -> None
-
-let expand_set _loc e1 e2 =
- match bigarray_set _loc e1 e2 with
- | Some e -> e
- | None -> match e1 with
- | <:expr< $o$ # $x$ >> -> <:expr< $o$ # $"set_"^x$ $e2$ >>
- | _ -> <:expr< $e1$ := $e2$ >>
-
-DELETE_RULE Caml.Gram Caml.expr: SELF; "<-"; Caml.expr LEVEL "top" END;;
-
-EXTEND Caml.Gram
- GLOBAL: Caml.class_str_item Caml.expr Caml.opt_mutable Caml.ctyp;
- Caml.class_str_item: [
- [ "val"; "mutable"; `LIDENT lab; e = cvalue_binding; kind = cvalue_kind ->
- expand_access _loc Ast.BTrue lab e kind
- | "val"; `LIDENT lab; e = cvalue_binding; kind = cvalue_kind ->
- expand_access _loc Ast.BFalse lab e kind ]
- ];
- cvalue_kind: [
- [ kind = OPT [ "with"; k =
- [ "reader" -> `R | "writer" -> `W | "accessor" -> `RW ] -> k] ->
- kind ]
- ];
- cvalue_binding: [
- [ "="; e = Caml.expr -> e
- | ":"; t = Caml.ctyp; "="; e = Caml.expr -> <:expr< ($e$ : $t$) >> ]
- ];
- Caml.expr: LEVEL ":=" [
- [ e1 = SELF; "<-"; e2 = Caml.expr LEVEL "top" -> expand_set _loc e1 e2 ]
- ];
- Caml.expr: LEVEL "simple" [
- [ "{|"; cf = LIST1 obj_record SEP ";"; "|}" ->
- <:expr< object $Ast.crSem_of_list cf$ end >> ]
- ];
- obj_record: [
- [ "inherit"; ce = Caml.class_expr -> <:class_str_item< inherit $ce$ >>
- | mf = Caml.opt_mutable; `LIDENT lab; ty = OPT [ ":"; t = Caml.ctyp -> t];
- "="; e = Caml.expr LEVEL "top" ->
- expand_access _loc mf lab e
- (Some(if mf = Ast.BFalse then `R else `RW)) ]
- ];
-END;;
+++ /dev/null
-#use "topfind";;
-#require "extlib";;
-#require "xml-light";;
-
-#directory "../utils";;
-#directory "../swflib";;
-
-#load "../utils/utils.cma";;
-#load "../swflib/swflib.cma";;
\ No newline at end of file
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 48
-/svn/!svn/ver/1965/ocaml/abc2xml/trunk/classdump
-END
-main.ml
-K 25
-svn:wc:ra_dav:version-url
-V 56
-/svn/!svn/ver/1965/ocaml/abc2xml/trunk/classdump/main.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 58
-/svn/!svn/ver/1958/ocaml/abc2xml/trunk/classdump/OMakefile
-END
-.ocamlinit
-K 25
-svn:wc:ra_dav:version-url
-V 59
-/svn/!svn/ver/1958/ocaml/abc2xml/trunk/classdump/.ocamlinit
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/classdump
-http://www.libspark.org/svn
-
-
-
-2008-12-05T01:37:43.194966Z
-1965
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-main.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-7b2eab8f0b60696ec21aec4c25ab6e50
-2008-12-05T01:37:43.194966Z
-1965
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-2020
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-af6f34e3a838e589eb1f92c17f5a4c98
-2008-12-04T02:29:51.490846Z
-1958
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1353
-\f
-.ocamlinit
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-e19035b388689892179f40a62927ff1f
-2008-12-04T02:29:51.490846Z
-1958
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-170
-\f
+++ /dev/null
-#use "topfind";;
-#require "extlib";;
-#require "xml-light";;
-
-#directory "../utils";;
-#directory "../swflib";;
-
-#load "../utils/utils.cma";;
-#load "../swflib/swflib.cma";;
\ No newline at end of file
+++ /dev/null
-.PHONY: clean
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-#
-# This project requires ocamlfind
-#
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- xml-light
- extlib
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln(This project requires ocamlfind, but is was not found.)
- eprintln(You need to install ocamlfind and run "omake --configure".)
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-OCAMLFLAGS += -g
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-
-################################################
-#
-# Camlp4 flags
-#
-
-CAMLP4FILES[] =
- ../camlp4/pa_oo.cmo
-
-OCAMLPPFLAGS += -pp 'camlp4o ../camlp4/pa_oo.cmo'
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-.SCANNER: scan-ocaml-%.ml: %.ml $(CAMLP4FILES)
-
-################################################
-# Build an OCaml program
-#
-
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
-
-FILES[] =
- main
-
-PROGRAM = habc-dump
-
-OCamlProgram($(PROGRAM), $(FILES))
-OCamlLibrary($(PROGRAM), $(FILES))
-
-.DEFAULT: $(PROGRAM)
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(PROGRAM) *.opt *.run *.cma *.cmxa *.a
+++ /dev/null
-open Base
-
-let string cpool i =
- List.nth cpool#string @@ Int32.to_int i - 1
-
-let namespace cpool i =
- match List.nth cpool#namespace @@ (Int32.to_int i - 1) with
- `ExplicitNamespace i ->
- Printf.sprintf "[explicit %s]" @@ string cpool i
- | `Namespace i ->
- Printf.sprintf "%s" @@ string cpool i
- | `PackageInternaNs i ->
- Printf.sprintf "[internal %s]" @@ string cpool i
- | `PackageNamespace i ->
- Printf.sprintf "%s" @@ string cpool i
- | `PrivateNs i ->
- Printf.sprintf "[private %s]" @@ string cpool i
- | `ProtectedNamespace i ->
- Printf.sprintf "[protected %s]" @@ string cpool i
- | `StaticProtectedNs i ->
- Printf.sprintf "[static protected %s]" @@ string cpool i
-
-let namespace_set cpool i =
- string_of_list @@ List.map (namespace cpool) @@
- (List.nth cpool#ns_set @@ Int32.to_int i - 1)#ns
-
-let multiname cpool i =
- let ns,name =
- match List.nth cpool#multiname @@ Int32.to_int i - 1 with
- `QName obj ->
- (namespace cpool obj#ns),(string cpool obj#name)
- | `Multiname obj ->
- (namespace_set cpool obj#ns_set),(string cpool obj#name)
- | _ ->
- failwith "not yet" in
- if ns = "" then
- name
- else
- ns ^ "." ^name
-
-let method_info abc i =
- let m =
- List.nth abc#methods @@ Int32.to_int i in
- multiname abc#constant_pool m#name
-
-let method_trait trait =
- match trait#data with
- `Method obj
- | `Getter obj
- | `Setter obj ->
- [obj#methodi]
- | _ ->
- []
-
-
-let instance_list abc =
- let cpool =
- abc#constant_pool in
- List.map (fun i -> (multiname cpool i#name,
- List.map (fun t -> multiname cpool t#name) i#traits))
- abc#instances
-
-let dump file =
- let abc =
- Abc.of_stream @@ Byte.of_channel @@ open_in_bin file in
- instance_list abc
-
-let _ =
- let argv =
- Array.to_list Sys.argv in
- match argv with
- _::xs ->
- List.iter (List.iter (fun (klass,methods)->
- Printf.printf "(external-class %s (%s))\n" klass @@ String.concat " " methods) $ dump) xs
- | [] ->
- failwith "must not happen"
-
+++ /dev/null
-.PHONY: clean
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-#
-# This project requires ocamlfind
-#
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- xml-light
- extlib
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln(This project requires ocamlfind, but is was not found.)
- eprintln(You need to install ocamlfind and run "omake --configure".)
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-OCAMLFLAGS += -g
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-
-################################################
-#
-# Camlp4 flags
-#
-
-CAMLP4FILES[] =
- ../camlp4/pa_oo.cmo
-
-OCAMLPPFLAGS += -pp 'camlp4o ../camlp4/pa_oo.cmo'
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-.SCANNER: scan-ocaml-%.ml: %.ml $(CAMLP4FILES)
-
-################################################
-# Build an OCaml program
-#
-
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
-
-FILES[] =
- main
-
-PROGRAM = habc-dump
-
-OCamlProgram($(PROGRAM), $(FILES))
-OCamlLibrary($(PROGRAM), $(FILES))
-
-.DEFAULT: $(PROGRAM)
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(PROGRAM) *.opt *.run *.cma *.cmxa *.a
+++ /dev/null
-open Base
-
-let string cpool i =
- List.nth cpool#string @@ Int32.to_int i - 1
-
-let namespace cpool i =
- match List.nth cpool#namespace @@ (Int32.to_int i - 1) with
- `ExplicitNamespace i ->
- Printf.sprintf "[explicit %s]" @@ string cpool i
- | `Namespace i ->
- Printf.sprintf "%s" @@ string cpool i
- | `PackageInternaNs i ->
- Printf.sprintf "[internal %s]" @@ string cpool i
- | `PackageNamespace i ->
- Printf.sprintf "%s" @@ string cpool i
- | `PrivateNs i ->
- Printf.sprintf "[private %s]" @@ string cpool i
- | `ProtectedNamespace i ->
- Printf.sprintf "[protected %s]" @@ string cpool i
- | `StaticProtectedNs i ->
- Printf.sprintf "[static protected %s]" @@ string cpool i
-
-let namespace_set cpool i =
- string_of_list @@ List.map (namespace cpool) @@
- (List.nth cpool#ns_set @@ Int32.to_int i - 1)#ns
-
-let multiname cpool i =
- let ns,name =
- match List.nth cpool#multiname @@ Int32.to_int i - 1 with
- `QName obj ->
- (namespace cpool obj#ns),(string cpool obj#name)
- | `Multiname obj ->
- (namespace_set cpool obj#ns_set),(string cpool obj#name)
- | _ ->
- failwith "not yet" in
- if ns = "" then
- name
- else
- ns ^ "." ^name
-
-let method_info abc i =
- let m =
- List.nth abc#methods @@ Int32.to_int i in
- multiname abc#constant_pool m#name
-
-let method_trait trait =
- match trait#data with
- `Method obj
- | `Getter obj
- | `Setter obj ->
- [obj#methodi]
- | _ ->
- []
-
-
-let instance_list abc =
- let cpool =
- abc#constant_pool in
- List.map (fun i -> (multiname cpool i#name,
- List.map (fun t -> multiname cpool t#name) i#traits))
- abc#instances
-
-let dump file =
- let abc =
- Abc.of_stream @@ Byte.of_channel @@ open_in_bin file in
- instance_list abc
-
-let _ =
- let argv =
- Array.to_list Sys.argv in
- match argv with
- _::xs ->
- List.iter (List.iter (fun (klass,methods)->
- Printf.printf "(external-class %s (%s))\n" klass @@ String.concat " " methods) $ dump) xs
- | [] ->
- failwith "must not happen"
-
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 46
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/example
-END
-hello.abc
-K 25
-svn:wc:ra_dav:version-url
-V 56
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/example/hello.abc
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/example
-http://www.libspark.org/svn
-
-
-
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-hello.abc
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-5a3975970b268dfba59656dc0392408d
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-70
-\f
########################################################################
# OCaml configuration.
-#
+#
#
#
extlib
if $(not $(OCAMLFIND_EXISTS))
- eprintln(This project requires ocamlfind, but is was not found.)
- eprintln(You need to install ocamlfind and run "omake --configure".)
+ eprintln('This project requires ocamlfind, but is was not found.')
+ eprintln('You need to install ocamlfind and run "omake --configure".')
exit 1
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-#
-# Compile native or byte code?
+OCAMLINCLUDES += ../../base/
+
+
+# Compile native or byte code?
#
# The default values are defined as follows:
#
# Build an OCaml program
#
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
+OCAMLINCLUDES += ../../base/
+OCAML_LIBS += ../../base/base
FILES[] =
+ abc
+ byte
+ code
+ disasm
easyXml
swfmill
+ parsec
code
PROGRAM = habc-xml
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 45
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib
-END
-byte.mli
-K 25
-svn:wc:ra_dav:version-url
-V 54
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/byte.mli
-END
-parsec.ml
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/parsec.ml
-END
-disasm.ml
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/disasm.ml
-END
-byte.ml
-K 25
-svn:wc:ra_dav:version-url
-V 53
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/byte.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/OMakefile
-END
-abc.ml
-K 25
-svn:wc:ra_dav:version-url
-V 52
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/swflib/abc.ml
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/swflib
-http://www.libspark.org/svn
-
-
-
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-byte.mli
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-2c2719621b9a1467f2de0031edb60771
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-260
-\f
-parsec.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-f8101cb38b5285dc0eb30559f86d1cbb
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-2014
-\f
-disasm.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-a765c593bd5c6fed8883cfcdd0c9ce67
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-7574
-\f
-byte.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-12242dfa12c159eace00bbec88f734dc
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1138
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-aa4fa7673cbc16498d48eb91e52d0e75
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1814
-\f
-abc.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-7cbfece3474265786664172880c6158e
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-7392
-\f
+++ /dev/null
-########################################################################
-# Phony targets are scoped, so you probably want to declare them first.
-#
-
-.PHONY: clean
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-################################################
-# Configuration. You may want to modify any of these configuration
-# variables.
-#
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-#
-# This project requires ocamlfind
-#
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- extlib
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln('This project requires ocamlfind, but is was not found.')
- eprintln('You need to install ocamlfind and run "omake --configure".')
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-################################################
-#
-# Camlp4 flags
-#
-
-CAMLP4FILES[] =
- ../camlp4/pa_oo.cmo
-
-OCAMLPPFLAGS += -pp 'camlp4o ../camlp4/pa_oo.cmo'
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-.SCANNER: scan-ocaml-%.ml: %.ml $(CAMLP4FILES)
-
-################################################
-# Generated files
-#
-# Workaround for the fact that ocamldep does not pay attention to .mll
-# and .mly files.
-#
-# OCamlGeneratedFiles(parser.ml lexer.ml)
-
-################################################
-# Build an OCaml library
-#
-
-FILES[] =
- abc
- byte
- disasm
- parsec
-
-LIB = swflib
-
-.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(LIB) *.opt *.run *.cma *.cmxa *.a
+++ /dev/null
-open Base
-open Byte
-open ExtString
-
-let array f stream =
- let n =
- u30 stream in
- Parsec.repeat_l n f stream
-
-let carray f stream =
- let n =
- u30 stream in
- Parsec.repeat_l (Int32.sub n 1l) f stream
-
-(* constant pool *)
-let string_info stream =
- let cs =
- List.map char_of_int @@ array u8 stream in
- String.implode cs
-
-let namespace_info stream =
- let kind =
- u8 stream in
- let name =
- u30 stream in
- match kind with
- 0x08 ->
- `Namespace name
- | 0x16 ->
- `PackageNamespace name
- | 0x17 ->
- `PackageInternaNs name
- | 0x18 ->
- `ProtectedNamespace name
- | 0x19 ->
- `ExplicitNamespace name
- | 0x1A ->
- `StaticProtectedNs name
- | 0x05 ->
- `PrivateNs name
- | _ ->
- failwith "must not happen"
-
-let ns_set_info stream =
- {| ns = array u30 stream |}
-
-let multiname_info stream =
- let kind =
- u8 stream in
- match kind with
- 0x07 ->
- `QName {| ns=u30 stream; name=u30 stream |}
- | 0x0D ->
- `QNameA {| ns=u30 stream; name=u30 stream |}
- | 0x0F ->
- `RTQName {| name=u30 stream |}
- | 0x10 ->
- `RTQNameA {| name=u30 stream |}
- | 0x11 ->
- `RTQNameL
- | 0x12 ->
- `RTQNameLA
- | 0x09 ->
- `Multiname {|name=u30 stream; ns_set=u30 stream|}
- | 0x0E ->
- `MultinameA {|name=u30 stream; ns_set=u30 stream|}
- | 0x1B ->
- `MultinameL {|ns_set=u30 stream|}
- | 0x1C ->
- `MultinameLA {|ns_set=u30 stream|}
- | _ ->
- failwith "invalid format"
-
-let constant_pool stream =
- {| integer =carray s32 stream;
- uinteger =carray u32 stream;
- double =carray d64 stream;
- string =carray string_info stream;
- namespace=carray namespace_info stream;
- ns_set =carray ns_set_info stream;
- multiname=carray multiname_info stream
- |}
-
-(* method info *)
-let option_detail stream =
- let value =
- u30 stream in
- match u8 stream with
- 0x03 ->
- `Int value
- | 0x04 ->
- `UInt value
- | 0x06 ->
- `Double value
- | 0x01 ->
- `String value
- | 0x0B ->
- `Bool true
- | 0x0A ->
- `Bool false
- | 0x0C ->
- `Null
- | 0x00 ->
- `Undefined
- | 0x08 | 0x16 | 0x17 | 0x18 | 0x19 | 0x1A | 0x05 ->
- `Namespace value
- | _ ->
- failwith "invalid format"
-
-let option_info stream =
- array option_detail stream
-
-let has x y =
- x land y = y
-
-let method_info stream =
- let param_count =
- u30 stream in
- let return_type =
- u30 stream in
- let param_types =
- Parsec.repeat_l param_count u30 stream in
- let name =
- u30 stream in
- let flags =
- u8 stream in
- let options =
- if has flags 0x08 then
- Some (option_info stream )
- else
- None in
- let param_names =
- if has flags 0x80 then
- Some (Parsec.repeat_l param_count u30 stream)
- else
- None in
- {| param_types = param_types;
- return_type = return_type;
- name = name;
- need_arguments = has flags 0x01;
- need_activation = has flags 0x02;
- need_rest = has flags 0x04;
- set_dxns = has flags 0x40;
- options = options;
- param_names = param_names
- |}
-
-(* metadata *)
-let item_info stream =
- {| key=u30 stream;
- value=u30 stream |}
-
-let metadata_info stream =
- {| name = u30 stream;
- items = array item_info stream
- |}
-
-(* 4.8 Traits *)
-let trait_info stream =
- let name =
- u30 stream in
- let kind =
- u8 stream in
- let data =
- match kind land 0x0F with
- 0 | 6 ->
- let slot_id = u30 stream in
- let type_name =
- u30 stream in
- let vindex =
- u30 stream in
- let vkind =
- if vindex = 0l then
- None
- else
- Some (u8 stream) in
- let body =
- {| slot_id=slot_id; type_name=type_name; vindex=vindex; vkind=vkind|} in
- if kind = 0 then
- `Slot body
- else
- `Const body
- | 4 ->
- `Class {| slot_id=u30 stream; classi=u30 stream |}
- | 5 ->
- `Function {| slot_id=u30 stream; functioni=u30 stream |}
- | 1 | 2 | 3 as k ->
- let body =
- {| disp_id=u30 stream; methodi=u30 stream |} in
- begin match k with
- 1 -> `Method body
- | 2 -> `Getter body
- | 3 -> `Setter body
- | _ -> failwith "must not happen"
- end
- | _ ->
- failwith "invalid format" in
- let attr =
- kind lsr 4 in
- let metadata =
- if has attr 0x4 then
- Some (array u30 stream)
- else
- None in
- {| name = name;
- data = data;
- metadata = metadata;
- attr_final = has attr 0x01;
- attr_override = has attr 0x02
- |}
-
-(* 4.7 Instance *)
-let instance_info stream =
- let name =
- u30 stream in
- let super_name =
- u30 stream in
- let flags =
- u8 stream in
- let protectedNs =
- if has flags 0x08 then
- Some (u30 stream)
- else
- None in
- let interface =
- array u30 stream in
- let iinit =
- u30 stream in
- let traits =
- array trait_info stream in
- {| name = name;
- super_name = super_name;
- is_sealed = has flags 0x01;
- is_final = has flags 0x02;
- is_interface = has flags 0x04;
- is_protected = has flags 0x08;
- protectedNs = protectedNs;
- interface = interface;
- iinit = iinit;
- traits = traits
- |}
-
-(* 4.9 Class *)
-let class_info stream =
- {| cinit = u30 stream; traits = array trait_info stream|}
-
-(* 4.10 Script*)
-let script_info stream =
- {| init = u30 stream; traits = array trait_info stream |}
-
-(* 4.12 Exception *)
-let exception_info stream =
- {| from_pos = u30 stream;
- to_pos = u30 stream;
- target = u30 stream;
- exc_type = u30 stream;
- var_name = u30 stream
- |}
-
-(* 4.11 Method body *)
-let method_body_info stream =
- let methodi =
- u30 stream in
- let max_stack =
- u30 stream in
- let local_count =
- u30 stream in
- let init_scope_depth =
- u30 stream in
- let max_scope_depth =
- u30 stream in
- let code =
- array u8 stream in
- let exceptions =
- array exception_info stream in
- let traits =
- array trait_info stream in
- {| methodi = methodi;
- max_stack = max_stack;
- local_count = local_count;
- init_scope_depth = init_scope_depth;
- max_scope_depth = max_scope_depth;
- code = Parsec.many Disasm.code @@ Stream.of_list code;
- exceptions = exceptions;
- traits = traits
- |}
-
-(* 4.2 ABC File *)
-let abcFile stream =
- let minor_version =
- u16 stream in
- let major_version =
- u16 stream in
- let constant_pool =
- constant_pool stream in
- let methods =
- array method_info stream in
- let metadata =
- array metadata_info stream in
- let class_count =
- u30 stream in
- let instances =
- Parsec.repeat_l class_count instance_info stream in
- let classes =
- Parsec.repeat_l class_count class_info stream in
- let script =
- array script_info stream in
- let method_body =
- array method_body_info stream in
- {| minor_version = minor_version;
- major_version = major_version;
- constant_pool = constant_pool;
- methods = methods;
- metadata = metadata;
- instances = instances;
- classes = classes;
- script = script;
- method_body = method_body
- |}
-
-let of_stream =
- abcFile
-
-let sample () =
- let ch =
- open_in_bin "a.abc" in
- abcFile @@ Byte.of_channel ch
+++ /dev/null
-open Base
-
-let of_channel ch =
- Stream.from (fun pos ->
- try
- Some (input_byte ch)
- with End_of_file ->
- None)
-
-let (++) x y =
- (x lsl 8) + y
-
-let byte =
- Stream.next
-
-let u8 =
- parser [<c = byte>] -> c
-
-let u16 =
- parser [<n2 = byte; n1 = byte >] ->
- n1 ++ n2
-
-let s_extend d =
- (d lsl 7) asr 7
-
-let s24 =
- parser [<n3 = byte; n2 = byte; n1 = byte>] ->
- s_extend (n1 ++ n2 ++ n3)
-
-let leq n stream =
- match Stream.peek stream with
- Some m when m <= n ->
- Stream.next stream
- | _ ->
- raise Stream.Failure
-
-let (+++) x y =
- Int32.logor (Int32.shift_left x 7) (Int32.logand y 0x7Fl)
-
-let rec read_u30 stream =
- match stream with parser
- [<n = leq 0x7F >] ->
- Int32.of_int n
- | [<n = byte>] ->
- (read_u30 stream) +++ (Int32.of_int n)
- | [<>] ->
- raise (Stream.Error "invalid format")
-
-let u30 =
- read_u30
-
-let u32 =
- read_u30
-
-let s32 =
- read_u30
-
-let d64 =
- let shift_or x y =
- Int64.logor (Int64.shift_left y 8) (Int64.of_int x) in
- parser
- [<d = Parsec.repeat 8 byte>] ->
- Int64.float_of_bits @@ List.fold_right shift_or d 0L
-
-let sample () =
- Stream.of_list @@ range 0 10
-
-
+++ /dev/null
-val of_channel : in_channel -> int Stream.t
-val u8 : 'a Stream.t -> 'a
-val u16 : int Stream.t -> int
-val s24 : int Stream.t -> int
-val u30 : int Stream.t -> int32
-val u32 : int Stream.t -> int32
-val s32 : int Stream.t -> int32
-val d64 : int Stream.t -> float
-
+++ /dev/null
-open Base
-open Byte
-
-let op n stream =
- match Stream.peek stream with
- Some m when m = n ->
- Stream.next stream
- | _ ->
- raise Stream.Failure
-
-let code =
- parser
- [< _ = op 0xc5 >] ->
- `Add_i
- | [< _ = op 0x86; index = u30 >] ->
- `AsType index
- | [< _ = op 0x87 >] ->
- `AsTypeLate
- | [< _ = op 0xa8 >] ->
- `BitAnd
- | [< _ = op 0x97 >] ->
- `BitNot
- | [< _ = op 0xa9 >] ->
- `BitOr
- | [< _ = op 0xaa >] ->
- `BitXor
- | [< _ = op 0x41; arg_count = u30 >] ->
- `Call arg_count
- | [< _ = op 0x43; index = u30; arg_count = u30 >] ->
- `CallMethod (index,arg_count)
- | [< _ = op 0x46; index = u30; arg_count = u30 >] ->
- `CallProperty (index,arg_count)
- | [< _ = op 0x4c; index = u30; arg_count = u30 >] ->
- `CallPropLex (index,arg_count)
- | [< _ = op 0x4f; index = u30; arg_count = u30 >] ->
- `CallPropVoid (index,arg_count)
- | [< _ = op 0x44; index = u30; arg_count = u30 >] ->
- `CallStatic (index,arg_count)
- | [< _ = op 0x45; index = u30; arg_count = u30 >] ->
- `CallSuper (index,arg_count)
- | [< _ = op 0x4e; index = u30; arg_count = u30 >] ->
- `CallSuperVoid (index,arg_count)
- | [< _ = op 0x78 >] ->
- `CheckFilter
- | [< _ = op 0x80; index = u30 >] ->
- `Coerce index
- | [< _ = op 0x82 >] ->
- `Coerce_a
- | [< _ = op 0x85 >] ->
- `Coerce_s
- | [< _ = op 0x42; arg_count = u30 >] ->
- `Construct arg_count
- | [< _ = op 0x4a; index = u30; arg_count = u30 >] ->
- `ConstructProp (index,arg_count)
- | [< _ = op 0x49; arg_count = u30 >] ->
- `ConstructSuper arg_count
- | [< _ = op 0x76 >] ->
- `Convert_b
- | [< _ = op 0x73 >] ->
- `Convert_i
- | [< _ = op 0x75 >] ->
- `Convert_d
- | [< _ = op 0x77 >] ->
- `Convert_o
- | [< _ = op 0x74 >] ->
- `Convert_u
- | [< _ = op 0x70 >] ->
- `Convert_s
- | [< _ = op 0xef; debug_type = u8; index = u30; reg = u8; extra = u30 >] ->
- `Debug (debug_type,index,reg,extra)
- | [< _ = op 0xf1; index = u30 >] ->
- `DebugFile index
- | [< _ = op 0xf0; linenum = u30 >] ->
- `DebugLine linenum
- | [< _ = op 0x94; index = u30 >] ->
- `DecLocal index
- | [< _ = op 0xc3; index = u30 >] ->
- `DecLocal_i index
- | [< _ = op 0x93 >] ->
- `Decrement
- | [< _ = op 0xc1 >] ->
- `Decrement_i
- | [< _ = op 0x6a; name = u30 >] ->
- `DeleteProperty name
- | [< _ = op 0xa3 >] ->
- `Divide
- | [< _ = op 0x2a >] ->
- `Dup
- | [< _ = op 0x06; string = u30 >] ->
- `Dxns string
- | [< _ = op 0x07 >] ->
- `DxnsLate
- | [< _ = op 0xab >] ->
- `Equals
- | [< _ = op 0x72 >] ->
- `Esc_xattr
- | [< _ = op 0x71 >] ->
- `Esc_xelem
- | [< _ = op 0x5f; _ = u30 >] ->
- failwith "finddef: undocumented instruction"
- | [< _ = op 0x5e; name = u30 >] ->
- `FindProperty name
- | [< _ = op 0x5d; name = u30 >] ->
- `FindPropStrict name
- | [< _ = op 0x59; name = u30 >] ->
- `GetDescendants name
- | [< _ = op 0x64 >] ->
- `GetGlobalScope
- | [< _ = op 0x6e; slot_id = u30 >] ->
- `GetGlobalSlot slot_id
- | [< _ = op 0x60; name = u30 >] ->
- `GetLex name
- | [< _ = op 0x62; index = u30 >] ->
- `GetLocal index
- | [< _ = op 0xD0 >] ->
- `GetLocal_0
- | [< _ = op 0xD1 >] ->
- `GetLocal_1
- | [< _ = op 0xD2 >] ->
- `GetLocal_2
- | [< _ = op 0xD3 >] ->
- `GetLocal_3
- | [< _ = op 0x66; name = u30 >] ->
- `GetProperty name
- | [< _ = op 0x65; index = u8 >] ->
- `GetScopeObject index
- | [< _ = op 0x6c; slot_id = u30 >] ->
- `GetSlot slot_id
- | [< _ = op 0x04; name = u30 >] ->
- `GetSuper name
- | [< _ = op 0xb0 >] ->
- `GreaterEquals
- | [< _ = op 0xaf >] ->
- `GreaterThan
- | [< _ = op 0x1f >] ->
- `HasNext
- | [< _ = op 0x32; object_reg = u32; index_reg = u32 >] ->
- `HasNext2 (object_reg,index_reg)
- | [< _ = op 0x13; offset = s24 >] ->
- `IfEq offset
- | [< _ = op 0x12; offset = s24 >] ->
- `IfFalse offset
- | [< _ = op 0x17; offset = s24 >] ->
- `IfGt offset
- | [< _ = op 0x16; offset = s24 >] ->
- `IfLe offset
- | [< _ = op 0x15; offset = s24 >] ->
- `IfLt offset
- | [< _ = op 0x15; offset = s24 >] ->
- `IfLt offset
- | [< _ = op 0x0f; offset = s24 >] ->
- `IfNge offset
- | [< _ = op 0x0e; offset = s24 >] ->
- `IfNgt offset
- | [< _ = op 0x0d; offset = s24 >] ->
- `IfNle offset
- | [< _ = op 0x0c; offset = s24 >] ->
- `IfNlt offset
- | [< _ = op 0x14; offset = s24 >] ->
- `IfNe offset
- | [< _ = op 0x19; offset = s24 >] ->
- `IfStrictEq offset
- | [< _ = op 0x1a; offset = s24 >] ->
- `IfStrictNe offset
- | [< _ = op 0x11; offset = s24 >] ->
- `IfTrue offset
- | [< _ = op 0xb4 >] ->
- `In
- | [< _ = op 0x92; index = u30 >] ->
- `IncLocal index
- | [< _ = op 0xc2; index = u30 >] ->
- `IncLocal_i index
- | [< _ = op 0x91 >] ->
- `Increment
- | [< _ = op 0xc0 >] ->
- `Increment_i
- | [< _ = op 0x68; index = u30 >] ->
- `InitProperty index
- | [< _ = op 0xb1 >] ->
- `InstanceOf
- | [< _ = op 0xb2; index = u30 >] ->
- `IsType index
- | [< _ = op 0xb3 >] ->
- `IsTypeLate
- | [< _ = op 0x10; offset = s24 >] ->
- `Jump offset
- | [< _ = op 0x08; index = u30 >] ->
- `Kill index
- | [< _ = op 0x09 >] ->
- `Label
- | [< _ = op 0xae >] ->
- `LessEquals
- | [< _ = op 0xad >] ->
- `LessThan
- | [< _ = op 0x1b;
- default_offset = s24;
- case_count = u30;
- case_offsets = Parsec.repeat_l (Int32.add case_count 1l) s24 >] ->
- `LookupSwitch (default_offset,case_offsets)
- | [< _ = op 0xa5 >] ->
- `LShift
- | [< _ = op 0xa4 >] ->
- `Modulo
- | [< _ = op 0xa2 >] ->
- `Multiply
- | [< _ = op 0xc7 >] ->
- `Multiply_i
- | [< _ = op 0x90 >] ->
- `Negate
- | [< _ = op 0xc4 >] ->
- `Negate_i
- | [< _ = op 0x57 >] ->
- `NewActivation
- | [< _ = op 0x56; arg_count = u30 >] ->
- `NewArray arg_count
- | [< _ = op 0x5a; index = u30 >] ->
- `NewCatch index
- | [< _ = op 0x58; index = u30 >] ->
- `NewClass index
- | [< _ = op 0x40; index = u30 >] ->
- `NewFunction index
- | [< _ = op 0x55; arg_count = u30 >] ->
- `NewObject arg_count
- | [< _ = op 0x1e >] ->
- `NextName
- | [< _ = op 0x23 >] ->
- `NextValue
- | [< _ = op 0x02 >] ->
- `Nop
- | [< _ = op 0x96 >] ->
- `Not
- | [< _ = op 0x29 >] ->
- `Pop
- | [< _ = op 0x1d >] ->
- `PopScope
- | [< _ = op 0x24; byte_value = u8 >] ->
- `PushByte byte_value
- | [< _ = op 0x2f; index = u30 >] ->
- `PushDouble index
- | [< _ = op 0x27 >] ->
- `PushFalse
- | [< _ = op 0x2d; index = u30 >] ->
- `PushInt index
- | [< _ = op 0x31; index = u30 >] ->
- `PushNamespace index
- | [< _ = op 0x28 >] ->
- `PushNan
- | [< _ = op 0x20 >] ->
- `PushNull
- | [< _ = op 0x30 >] ->
- `PushScope
- | [< _ = op 0x25; value = u30 >] ->
- `PushShort value
- | [< _ = op 0x2c; index = u30 >] ->
- `PushString index
- | [< _ = op 0x26 >] ->
- `PushTrue
- | [< _ = op 0x2e; index = u30 >] ->
- `PushUInt index
- | [< _ = op 0x21 >] ->
- `PushUndefined
- | [< _ = op 0x1c >] ->
- `PushWith
- | [< _ = op 0x48 >] ->
- `ReturnValue
- | [< _ = op 0x47 >] ->
- `ReturnVoid
- | [< _ = op 0xa6 >] ->
- `RShift
- | [< _ = op 0x63; index = u30 >] ->
- `SetLocal index
- | [< _ = op 0xd4 >] ->
- `SetLocal_0
- | [< _ = op 0xd5 >] ->
- `SetLocal_1
- | [< _ = op 0xd6 >] ->
- `SetLocal_2
- | [< _ = op 0xd7 >] ->
- `SetLocal_3
- | [< _ = op 0x6f; slot_index = u30 >] ->
- `SetGlobalSlot slot_index
- | [< _ = op 0x61; index = u30 >] ->
- `SetProperty index
- | [< _ = op 0x6d; slot_index = u30 >] ->
- `SetSlot slot_index
- | [< _ = op 0x05; index = u30 >] ->
- `SetSuper index
- | [< _ = op 0xac >] ->
- `StrictEquals
- | [< _ = op 0xa1 >] ->
- `Subtract
- | [< _ = op 0xc6 >] ->
- `Subtract_i
- | [< _ = op 0x2b >] ->
- `Swap
- | [< _ = op 0x03 >] ->
- `Throw
- | [< _ = op 0x95 >] ->
- `TypeOf
- | [< _ = op 0xa7 >] ->
- `URShift
+++ /dev/null
-open Base
-
-let fail () =
- raise Stream.Failure
-
-let rec times f =
- function
- 0 -> ()
- | n -> f () ;times f (n-1)
-
-let rec repeat n f stream =
- if n <= 0 then
- []
- else
- match stream with parser
- [<c = f>] ->
- c::repeat (n-1) f stream
- | [<>] ->
- raise (Stream.Error "invalid format")
-
-let repeat_l n f stream =
- repeat (Int32.to_int n) f stream
-
-let string str stream =
- let cs =
- ExtString.String.explode str in
- let n =
- List.length cs in
- match Stream.npeek n stream with
- ys when cs = ys ->
- times (fun ()->Stream.junk stream) n;
- ys
- | _ ->
- fail ()
-
-let char c stream =
- match Stream.peek stream with
- Some x when x = c ->
- Stream.junk stream;
- x
- | _ ->
- fail ()
-
-let rec until c stream =
- match Stream.peek stream with
- Some x when x != c ->
- Stream.junk stream;
- x::(until c stream)
- | _ ->
- []
-
-let one_of str stream =
- match Stream.peek stream with
- Some c when String.contains str c ->
- Stream.next stream
- | _ ->
- fail ()
-
-let option f stream =
- try
- Some (f stream)
- with Stream.Failure ->
- None
-
-let (<|>) f g =
- parser
- [<e = f>] -> e
- | [<e = g>] -> e
-
-let rec many parse stream =
- match stream with parser
- [< e = parse; s>] -> e::many parse s
- | [<>] -> []
-
-let many1 parse stream =
- let x =
- parse stream in
- x::many parse stream
-
-let alpha stream =
- match Stream.peek stream with
- Some ('a'..'z') | Some ('A'..'Z') ->
- Stream.next stream
- | _ ->
- fail ()
-
-let digit stream =
- match Stream.peek stream with
- Some ('0'..'9') ->
- Stream.next stream
- | _ ->
- fail ()
-
-let try_ f stream =
- (*
- Use black-magic to save stream state
-
- from stream.ml:
- type 'a t = { count : int; data : 'a data }
- *)
- let t =
- Obj.repr stream in
- let count =
- Obj.field t 0 in
- let data =
- Obj.field t 1 in
- try
- f stream
- with Stream.Failure | Stream.Error _ ->
- Obj.set_field t 0 count;
- Obj.set_field t 1 data;
- fail ()
+++ /dev/null
-########################################################################
-# Phony targets are scoped, so you probably want to declare them first.
-#
-
-.PHONY: clean
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-################################################
-# Configuration. You may want to modify any of these configuration
-# variables.
-#
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-#
-# This project requires ocamlfind
-#
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- extlib
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln('This project requires ocamlfind, but is was not found.')
- eprintln('You need to install ocamlfind and run "omake --configure".')
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-################################################
-#
-# Camlp4 flags
-#
-
-CAMLP4FILES[] =
- ../camlp4/pa_oo.cmo
-
-OCAMLPPFLAGS += -pp 'camlp4o ../camlp4/pa_oo.cmo'
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-.SCANNER: scan-ocaml-%.ml: %.ml $(CAMLP4FILES)
-
-################################################
-# Generated files
-#
-# Workaround for the fact that ocamldep does not pay attention to .mll
-# and .mly files.
-#
-# OCamlGeneratedFiles(parser.ml lexer.ml)
-
-################################################
-# Build an OCaml library
-#
-
-FILES[] =
- abc
- byte
- disasm
- parsec
-
-LIB = swflib
-
-.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(LIB) *.opt *.run *.cma *.cmxa *.a
+++ /dev/null
-val of_channel : in_channel -> int Stream.t
-val u8 : 'a Stream.t -> 'a
-val u16 : int Stream.t -> int
-val s24 : int Stream.t -> int
-val u30 : int Stream.t -> int32
-val u32 : int Stream.t -> int32
-val s32 : int Stream.t -> int32
-val d64 : int Stream.t -> float
-
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 43
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/test
-END
-codeTest.ml
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/codeTest.ml
-END
-testSupport.ml
-K 25
-svn:wc:ra_dav:version-url
-V 58
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/testSupport.ml
-END
-swfmillTest.ml
-K 25
-svn:wc:ra_dav:version-url
-V 58
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/swfmillTest.ml
-END
-byteTest.ml
-K 25
-svn:wc:ra_dav:version-url
-V 55
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/byteTest.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 53
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/test/OMakefile
-END
-abcTest.ml
-K 25
-svn:wc:ra_dav:version-url
-V 54
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/abcTest.ml
-END
-.ocamlinit
-K 25
-svn:wc:ra_dav:version-url
-V 54
-/svn/!svn/ver/1796/ocaml/abc2xml/trunk/test/.ocamlinit
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/test
-http://www.libspark.org/svn
-
-
-
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-codeTest.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-8f4f7fd31bf4ae454f49adcee4cdfafa
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-524
-\f
-testSupport.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-179803a7f137eb619c482ce3e7391585
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-202
-\f
-swfmillTest.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-dda5c6929168abfc22b8b70e108bb160
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-2599
-\f
-byteTest.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-32912e0fc6dc6e1e4ee37b4bdc56df47
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1429
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-69f991d652ac8fd220f426f0d13cdadc
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1270
-\f
-abcTest.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-bfaa5591db161e992798cfb8d69fa41c
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-2341
-\f
-.ocamlinit
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-8051c2909d69f95d16250a64e3d91e7a
-2008-11-08T04:24:06.377630Z
-1796
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-85
-\f
+++ /dev/null
-#directory "..";;
-#use "../.ocamlinit";;
-#require "oUnit";;
-#load "testSupport.cmo";;
\ No newline at end of file
+++ /dev/null
-.PHONY: check clean
-
-################################################
-# Configuration.
-#
-
-
-#
-# This project requires ocamlfind
-#
-
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- xml-light
- extlib
- oUnit
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln(This project requires ocamlfind, but is was not found.)
- eprintln(You need to install ocamlfind and run "omake --configure".)
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-OCAMLINCLUDES += ../xml
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-
-################################################
-# Build an OCaml program
-#
-
-FILES[] =
- testSupport
- byteTest
- abcTest
- swfmillTest
- codeTest
-
-PROGRAM = runner
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
-OCAML_LIBS += ../xml/habc-xml
-
-# OCAML_CLIBS +=
-# OCAML_OTHER_LIBS +=
-# OCAML_LIB_FLAGS +=
-
-
-OCamlProgram($(PROGRAM), $(FILES))
-
-.DEFAULT: $(PROGRAM)
-
-check: $(PROGRAM)
- ./$(PROGRAM)
-
-#
-# PHONY TARGET
-#
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(PROGRAM) *.opt *.run
+++ /dev/null
-open Base
-open OUnit
-open TestSupport
-
-let abc =
- example "hello"
-
-
-let cpool =
- abc#constant_pool
-
-let _ =
- ("asm module test" >::: [
- "major/minor version" >::
- (fun () ->
- ok 16 abc#minor_version;
- ok 46 abc#major_version);
- "cpool" >::: [
- "integer" >::
- (fun () -> ok [] cpool#integer);
- "uinteger" >::
- (fun () -> ok [] cpool#uinteger);
- "double" >::
- (fun () -> ok [] cpool#double);
- "string" >::
- (fun () -> ok [""; "Hello,world!!";"print"] cpool#string);
- "namespace" >::
- (fun () ->
- match cpool#namespace with
- [ns] ->
- ok (`Namespace 1l) ns
- | _ ->
- assert_failure "list size is over");
- "namespace set" >::
- (fun () ->
- ok [] cpool#ns_set);
- "multiname" >::
- (fun () ->
- match cpool#multiname with
- [`QName x;`QName y] ->
- ok 1 (Int32.to_int x#ns);
- ok 1 (Int32.to_int x#name);
- ok 1 (Int32.to_int y#ns);
- ok 3 (Int32.to_int y#name);
- | _ ->
- assert_failure "not qname")
- ];
- "method signature" >::
- (fun () ->
- match abc#methods with
- [m] ->
- ok [] m#param_types;
- ok 0l m#return_type;
- ok 1l m#name;
- ok false m#need_activation;
- ok false m#need_arguments;
- ok false m#need_rest;
- ok false m#set_dxns;
- ok None m#options;
- ok None m#param_names
- | _ ->
- assert_failure "over size");
- "metadata test" >::
- (fun () ->
- ok [] abc#metadata);
- "class and instance size has same size" >::
- (fun () ->
- ok (List.length abc#instances) (List.length abc#classes));
- "instance" >::
- (fun () ->
- ok [] abc#instances);
- "class" >::
- (fun () ->
- ok [] abc#classes);
- "script" >::
- (fun () ->
- match abc#script with
- [s] ->
- ok 0l s#init;
- ok [] s#traits
- | _ ->
- assert_failure "error");
- "method body" >::
- (fun () ->
- match abc#method_body with
- [m] ->
- ok 0l m#methodi;
- ok [] m#exceptions;
- ok 1l m#local_count;
- ok 0l m#init_scope_depth;
- ok 1l m#max_scope_depth;
- ok 2l m#max_stack;
- ok [] m#traits;
- flip ok m#code [
- `GetLocal_0;
- `PushScope;
- `FindPropStrict 2l;
- `PushString 2l;
- `CallPropLex (2l,1l);
- `Pop;
- `ReturnVoid ]
- | _ ->
- assert_failure "error");
- ]) +> run_test_tt
-
-
-
+++ /dev/null
-open OUnit
-open Base
-open Byte
-open TestSupport
-
-let of_list xs =
- Stream.of_list xs
-
-let tests = ("byte module test" >::: [
- "u8 is single byte" >::
- (fun _ ->
- ok 0 (u8 @@ of_list [0]));
- "u16 is little endian" >::
- (fun _ ->
- ok 0x0100 (u16 @@ of_list [0;1] ));
- "s24" >::
- (fun _ ->
- ok 0x000001 (s24 @@ of_list [1;0;0] );
- ok ~-1 (s24 @@ of_list [0xFF;0xFF;0xFF] ));
- "u30 is single byte when value < 0x7F" >::
- (fun _ ->
- ok 0l (u30 @@ of_list [0]);
- ok 0x7Fl (u30 @@ of_list [0x7F]));
- "u30 is 2 bytes when value <= 0x7F 0xFF" >::
- (fun _ ->
- ok 0xFFl (u30 @@ of_list [0xFF;0x01]);
- ok 0x3F_FFl (u30 @@ of_list [0xFF;0x7F]));
- "u30 is 3 bytes when value <= 0x7F 0xFF 0xFF" >::
- (fun _ ->
- ok 0x7FFFl (u30 @@ of_list [0xFF;0xFF;0x01]);
- ok 0x1F_FFFFl (u30 @@ of_list [0xFF;0xFF;0x7F]));
- "u30 is 4 bytes when value <= 0x7F 0xFF 0xFF 0xFF" >::
- (fun _ ->
- ok 0x003F_FFFFl (u30 @@ of_list [0xFF;0xFF;0xFF;0x01]);
- ok 0x0FFF_FFFFl (u30 @@ of_list [0xFF;0xFF;0xFF;0x7F]));
- "u30 is 5 bytes when value <= 0x7F 0xFF 0xFF 0xFF 0xFF" >::
- (fun _ ->
- ok 0x1FFF_FFFFl (u30 @@ of_list [0xFF;0xFF;0xFF;0xFF;0x01]);
- ok 0xFFFF_FFFFl (u30 @@ of_list [0xFF;0xFF;0xFF;0xFF;0xF]));
- "d64 is float(IEEE 754 format)" >::
- (fun _ ->
- ok 0.75 (d64 @@ of_list [0;0;0;0;0;0;0xe8;0x3f]))
-]) +> run_test_tt
-
+++ /dev/null
-open Base
-open OUnit
-open EasyXml
-
-let ok x y =
- OUnit.assert_equal ~printer:Xml.to_string_fmt (normalize x) (normalize y)
-
-let _ =
- ("code module test" >::: [
- "add" >::
- (fun _ ->
- ok (elem "OpAdd" []) @@
- Code.to_xml `Add);
- "constructprop" >::
- (fun _ ->
- ok (attr "OpConstructProp" ["name","1";"argc","42"]) @@
- Code.to_xml (`ConstructProp (1l,42l)));
- "getlex" >::
- (fun _ ->
- ok (attr "OpGetLex" ["name","42"]) @@
- Code.to_xml (`GetLex 42l))
- ]) +> run_test_tt
-
-
-
+++ /dev/null
-open Base
-open OUnit
-open Xml
-open EasyXml
-
-let ok x y =
- OUnit.assert_equal ~printer:Xml.to_string_fmt (normalize x) (normalize y)
-
-let abc =
- TestSupport.example "hello"
-
-let cpool =
- Swfmill.of_cpool abc#constant_pool
-
-let methods =
- Swfmill.of_methods abc#methods
-
-let metadata =
- Swfmill.of_metadata abc#metadata
-
-let instances =
- Swfmill.of_instances abc#instances
-
-let classes =
- Swfmill.of_classes abc#classes
-
-let scripts =
- Swfmill.of_script abc#script
-
-let method_bodies =
- Swfmill.of_method_bodies abc#method_body
-
-let _ =
- ("action module test" >::: [
- "constants" >::
- (fun () ->
- flip ok cpool @@ elem "Constants"
- [
- elem "ints" [];
- elem "uints" [];
- elem "doubles" [];
- elem "strings" [attr "String2" ["value",""];
- attr "String2" ["value","Hello,world!!"];
- attr "String2" ["value","print"] ];
- elem "namespaces" [attr "Namespace" ["index","1"]];
- elem "namespaceSets" [];
- elem "multinames" [attr "QName" ["namespaceIndex","1";"nameIndex","1"];
- attr "QName" ["namespaceIndex","1";"nameIndex","3"] ]
- ]
- );
- "method info" >::
- (fun _ ->
- flip ok methods @@ elem "methods" [
- element
- "MethodInfo"
- ["retType" ,"0";
- "nameIndex" ,"1";
- "hasParamNames" ,"0";
- "setSDXNs" ,"0";
- "isExplicit" ,"0";
- "ignoreRest" ,"0";
- "hasOptional" ,"0";
- "needRest" ,"0";
- "needActivation","0";
- "needArguments" ,"0"]
- [elem "paramTypes" []]
- ]
- );
- "metadata" >::
- (fun _ ->
- flip ok metadata @@ elem "metadata" []);
- "instances" >::
- (fun _ ->
- flip ok instances @@ elem "instances" []);
- "classes" >::
- (fun _ ->
- flip ok classes @@ elem "classes" []);
- "script" >::
- (fun _ ->
- flip ok scripts @@ elem "scripts" [
- element "ScriptInfo" ["initIndex","0"] [elem "traits" []]
- ]);
- "method body" >::
- (fun _ ->
- flip ok method_bodies @@ elem "methodBodies" [
- element "MethodBody" ["methodInfo" ,"0";
- "maxStack" ,"2";
- "maxRegs" ,"1";
- "scopeDepth" ,"0";
- "maxScope" ,"1";
- "exceptionCount","0"]
- [ elem "code" [
- attr "OpGetLocal0" [];
- attr "OpPushScope" [];
- attr "OpFindPropStrict" ["name","2"];
- attr "OpPushString" ["index","2"];
- attr "OpCallPropLex" ["name","2";"argc","1"];
- attr "OpPop" [];
- attr "OpReturnVoid" []; ];
- elem "exceptions" [];
- elem "traits" [] ]
- ]);
- ]) +> run_test_tt
+++ /dev/null
-open Base
-let ok x y =
- OUnit.assert_equal ~printer:Std.dump x y
-
-let example name =
- let ch =
- open_in_bin @@ Printf.sprintf "../example/%s.abc" name in
- Abc.of_stream @@ Byte.of_channel ch
-
-
################################################
# Configuration.
-#
+#
#
#
# Include path
#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-OCAMLINCLUDES += ../xml
+OCAMLINCLUDES += ../src
#
-# Compile native or byte code?
+# Compile native or byte code?
#
# The default values are defined as follows:
#
swfmillTest
codeTest
+OCAMLINCLUDES += ../../base/
+OCAML_LIBS += ../../base/base
+
PROGRAM = runner
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
-OCAML_LIBS += ../xml/habc-xml
+OCAML_LIBS += ../src/habc-xml
# OCAML_CLIBS +=
-# OCAML_OTHER_LIBS +=
+# OCAML_OTHER_LIBS +=
# OCAML_LIB_FLAGS +=
+
OCamlProgram($(PROGRAM), $(FILES))
.DEFAULT: $(PROGRAM)
check: $(PROGRAM)
./$(PROGRAM)
+
#
# PHONY TARGET
#
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 44
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/utils
-END
-base.ml
-K 25
-svn:wc:ra_dav:version-url
-V 52
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/utils/base.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 54
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/utils/OMakefile
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/utils
-http://www.libspark.org/svn
-
-
-
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-base.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-29d4c308c57870383e209e7f39ea35b1
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1391
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-f255c0541ede3481dcf426fb3a1c2ebb
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-357
-\f
+++ /dev/null
-.PHONY: clean
-
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-FILES[] =
- base
-
-LIB = utils
-
-.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(LIB) *.opt *.run *.cma *.cmxa *.a
\ No newline at end of file
+++ /dev/null
-let (@@) f g = f g
-let (+>) f g = g f
-let ($) f g x = f (g x)
-let id x = x
-
-let uncurry f a b = f (a,b)
-let curry f (a,b) = f a b
-let flip f a b = f b a
-let const a _ = a
-
-let string_of_list xs =
- Printf.sprintf "[%s]"
- @@ String.concat ";" xs
-
-let rec unfold f init =
- match f init with
- Some (a, b) -> a :: unfold f b
- | None -> []
-
-let rec range a b =
- if a >= b then
- []
- else
- a::range (a+1) b
-
-let rec interperse delim =
- function
- [] -> []
- | [x] -> [x]
- | x::xs -> x::delim::interperse delim xs
-
-type ('a,'b) either = Left of 'a | Right of 'b
-let left =
- function
- Left a -> a
- | _ -> invalid_arg "left"
-let right =
- function
- Right a -> a
- | _ -> invalid_arg "right"
-
-let map_accum_left f init xs =
- let f (accum,ys) x =
- let accum',y =
- f accum x in
- (accum',y::ys) in
- let accum,ys =
- List.fold_left f (init,[]) xs in
- accum,List.rev ys
-
-let rec group_by f =
- function
- [] ->
- []
- | x1::x2::xs when f x1 x2 ->
- begin match group_by f @@ x2::xs with
- y::ys ->
- (x1::y)::ys
- | _ ->
- failwith "must not happen"
- end
- | x::xs ->
- [x]::group_by f xs
-
-let index x xs =
- let rec loop i = function
- [] ->
- raise Not_found
- | y::ys ->
- if x = y then
- i
- else
- loop (i+1) ys in
- loop 0 xs
-
-let hex =
- Printf.sprintf "0x%x"
-
-let todo x =
- failwith x
+++ /dev/null
-.PHONY: clean
-
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-FILES[] =
- base
-
-LIB = utils
-
-.DEFAULT: $(OCamlLibrary $(LIB), $(FILES))
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(LIB) *.opt *.run *.cma *.cmxa *.a
\ No newline at end of file
+++ /dev/null
-let (@@) f g = f g
-let (+>) f g = g f
-let ($) f g x = f (g x)
-let id x = x
-
-let uncurry f a b = f (a,b)
-let curry f (a,b) = f a b
-let flip f a b = f b a
-let const a _ = a
-
-let string_of_list xs =
- Printf.sprintf "[%s]"
- @@ String.concat ";" xs
-
-let rec unfold f init =
- match f init with
- Some (a, b) -> a :: unfold f b
- | None -> []
-
-let rec range a b =
- if a >= b then
- []
- else
- a::range (a+1) b
-
-let rec interperse delim =
- function
- [] -> []
- | [x] -> [x]
- | x::xs -> x::delim::interperse delim xs
-
-type ('a,'b) either = Left of 'a | Right of 'b
-let left =
- function
- Left a -> a
- | _ -> invalid_arg "left"
-let right =
- function
- Right a -> a
- | _ -> invalid_arg "right"
-
-let map_accum_left f init xs =
- let f (accum,ys) x =
- let accum',y =
- f accum x in
- (accum',y::ys) in
- let accum,ys =
- List.fold_left f (init,[]) xs in
- accum,List.rev ys
-
-let rec group_by f =
- function
- [] ->
- []
- | x1::x2::xs when f x1 x2 ->
- begin match group_by f @@ x2::xs with
- y::ys ->
- (x1::y)::ys
- | _ ->
- failwith "must not happen"
- end
- | x::xs ->
- [x]::group_by f xs
-
-let index x xs =
- let rec loop i = function
- [] ->
- raise Not_found
- | y::ys ->
- if x = y then
- i
- else
- loop (i+1) ys in
- loop 0 xs
-
-let hex =
- Printf.sprintf "0x%x"
-
-let todo x =
- failwith x
+++ /dev/null
-K 25
-svn:wc:ra_dav:version-url
-V 42
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml
-END
-code.ml
-K 25
-svn:wc:ra_dav:version-url
-V 50
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml/code.ml
-END
-swfmill.ml
-K 25
-svn:wc:ra_dav:version-url
-V 53
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml/swfmill.ml
-END
-easyXml.ml
-K 25
-svn:wc:ra_dav:version-url
-V 53
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml/easyXml.ml
-END
-main.ml
-K 25
-svn:wc:ra_dav:version-url
-V 50
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml/main.ml
-END
-OMakefile
-K 25
-svn:wc:ra_dav:version-url
-V 52
-/svn/!svn/ver/1951/ocaml/abc2xml/trunk/xml/OMakefile
-END
+++ /dev/null
-9
-
-dir
-2118
-http://www.libspark.org/svn/ocaml/abc2xml/trunk/xml
-http://www.libspark.org/svn
-
-
-
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-svn:special svn:externals svn:needs-lock
-
-
-
-
-
-
-
-
-
-
-
-7c0a6d06-9f08-4704-a8a8-7f8aea5d0da0
-\f
-code.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-82bd96ff4a4feae5d6349dea3eae4754
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-8234
-\f
-swfmill.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-5890aaae8e9e1db3a61527d7d66a3986
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-7083
-\f
-easyXml.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-c853e79338b06f3bb9f7305275a4de6b
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-404
-\f
-main.ml
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-f2fa4f32ba967f16519c5461c0cba492
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-306
-\f
-OMakefile
-file
-
-
-
-
-2009-01-03T13:12:27.000000Z
-5e863020e4fe2017361593eff7c0b712
-2008-12-03T12:48:09.320048Z
-1951
-mzp
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-1374
-\f
+++ /dev/null
-.PHONY: clean
-
-########################################################################
-# OCaml configuration.
-#
-#
-
-#
-# This project requires ocamlfind
-#
-USE_OCAMLFIND = true
-OCAMLPACKS[] =
- xml-light
- extlib
-
-if $(not $(OCAMLFIND_EXISTS))
- eprintln(This project requires ocamlfind, but is was not found.)
- eprintln(You need to install ocamlfind and run "omake --configure".)
- exit 1
-
-#
-# Include path
-#
-OCAMLINCLUDES += ../utils
-OCAMLINCLUDES += ../swflib
-
-#
-# Compile native or byte code?
-#
-# The default values are defined as follows:
-#
-NATIVE_ENABLED = $(OCAMLOPT_EXISTS)
-BYTE_ENABLED = true
-
-#
-# Various options
-#
-# OCAMLFLAGS +=
-# OCAMLCFLAGS +=
-# OCAMLOPTFLAGS +=
-# OCAML_LINK_FLAGS +=
-# OCAML_BYTE_LINK_FLAGS +=
-# OCAML_NATIVE_LINK_FLAGS +=
-
-
-################################################
-#
-# Camlp4 flags
-#
-
-CAMLP4FILES[] =
- ../camlp4/pa_oo.cmo
-
-OCAMLPPFLAGS += -pp 'camlp4o ../camlp4/pa_oo.cmo'
-OCAMLDEPFLAGS += $(OCAMLPPFLAGS)
-.SCANNER: scan-ocaml-%.ml: %.ml $(CAMLP4FILES)
-
-################################################
-# Build an OCaml program
-#
-
-OCAML_LIBS += ../utils/utils
-OCAML_LIBS += ../swflib/swflib
-
-FILES[] =
- easyXml
- swfmill
- code
-
-PROGRAM = habc-xml
-
-OCamlProgram($(PROGRAM), main $(FILES))
-OCamlLibrary($(PROGRAM), $(FILES))
-
-.DEFAULT: $(PROGRAM)
-
-clean:
- rm -f *.cm[iox] *~ *.o *.omc $(PROGRAM) *.opt *.run *.cma *.cmxa *.a
+++ /dev/null
-open Base
-open EasyXml
-
-let op name =
- attr name []
-
-let op_a name attrs =
- attr name @@ List.map (fun (x,y) -> (x,Int32.to_string y)) attrs
-
-let op_i name attrs =
- attr name @@ List.map (fun (x,y) -> (x,string_of_int y)) attrs
-
-let to_xml = function
- `Add ->
- op "OpAdd"
- | `Add_i ->
- op "OpAddI"
- | `AsType index ->
- op_a "OpAsType" ["name",index]
- | `AsTypeLate ->
- op "OpAsTypeLate"
- | `BitAnd ->
- op "OpBitAnd"
- | `BitNot ->
- op "OpBitNot"
- | `BitOr ->
- op "OpBitOr"
- | `BitXor ->
- op "OpBitXor"
- | `Call argc ->
- op_a "OpCall" ["argc",argc]
- | `CallMethod (name,argc) ->
- op_a "OpCallMethod" ["name",name; "argc",argc]
- | `CallProperty (name,argc) ->
- op_a "OpCallProperty" ["name",name; "argc",argc]
- | `CallPropLex (name,argc) ->
- op_a "OpCallPropLex" ["name",name; "argc",argc]
- | `CallPropVoid (name,argc) ->
- op_a "OpCallPropVoid" ["name",name; "argc",argc]
- | `CallStatic (name,argc) ->
- op_a "OpCallStatic" ["name",name; "argc",argc]
- | `CallSuper (name,argc) ->
- op_a "OpCallSuper" ["name",name; "argc",argc]
- | `CallSuperVoid (name,argc) ->
- op_a "OpCallSuperVoid" ["name",name; "argc",argc]
- | `CheckFilter ->
- op "OpCheckFilter"
- | `Coerce name ->
- op_a "OpCoerce" ["name",name]
- | `Coerce_a ->
- op "OpCoerceA"
- | `Coerce_s ->
- op "OpCoerceS"
- | `Construct argc ->
- op_a "OpConstruct" ["argc",argc]
- | `ConstructProp (name,argc) ->
- op_a "OpConstructProp" ["name",name; "argc",argc]
- | `ConstructSuper argc ->
- op_a "OpConstructSuper" ["argc",argc]
- | `Convert_b ->
- op "OpConvertB"
- | `Convert_i ->
- op "OpConvertI"
- | `Convert_d ->
- op "OpConvertD"
- | `Convert_o ->
- op "OpConvertO"
- | `Convert_u ->
- op "OpConvertU"
- | `Convert_s ->
- op "OpConvertS"
- | `Debug (unknown,name,reg,line)->
- attr "OpDebug" ["unknown", string_of_int unknown;
- "name" , Int32.to_string name;
- "reg" , string_of_int reg;
- "line" , Int32.to_string line]
- | `DebugFile file ->
- op_a "OpDebugFile" ["file",file]
- | `DebugLine line ->
- op_a "OpDebugLine" ["line",line]
- | `DecLocal address ->
- op_a "OpDecLocal" ["address",address]
- | `DecLocal_i address ->
- op_a "OpDecLocalI" ["address",address]
- | `Decrement ->
- op "OpDecrement"
- | `Decrement_i ->
- op "OpDecrementI"
- | `DeleteProperty name ->
- op_a "OpDeleteProperty" ["name",name]
- | `Divide ->
- op "OpDivide"
- | `Dup ->
- op "OpDup"
- | `Dxns name ->
- op_a "OpDXNs" ["name",name]
- | `DxnsLate ->
- op "OpDXNsLate"
- | `Equals ->
- op "OpEquals"
- | `Esc_xattr ->
- op "OpEscXattr"
- | `Esc_xelem ->
- op "OpEscXelem"
- | `FindProperty name ->
- op_a "OpFindProperty" ["name",name]
- | `FindPropStrict name ->
- op_a "OpFindPropStrict" ["name",name]
- | `GetDescendants name ->
- op_a "OpGetDescendants" ["name",name]
- | `GetGlobalScope ->
- op "OpGetGlobalScope"
- | `GetGlobalSlot slot_id ->
- op_a "OpGetGlobalSlot" ["soltID",slot_id]
- | `GetLex name ->
- op_a "OpGetLex" ["name",name]
- | `GetLocal address ->
- op_a "OpGetLocal" ["address",address]
- | `GetLocal_0 ->
- op "OpGetLocal0"
- | `GetLocal_1 ->
- op "OpGetLocal1"
- | `GetLocal_2 ->
- op "OpGetLocal2"
- | `GetLocal_3 ->
- op "OpGetLocal3"
- | `GetProperty name ->
- op_a "OpGetProperty" ["name",name]
- | `GetScopeObject scope_index ->
- attr "OpGetScopeObject" ["scopeIndex",string_of_int scope_index]
- | `GetSlot slot_id ->
- op_a "OpGetSlot" ["slotID",slot_id]
- | `GetSuper name ->
- op_a "OpGetSuper" ["name",name]
- | `GreaterEquals ->
- op "OpGreaterEquals"
- | `GreaterThan ->
- op "OpGreaterThan"
- | `HasNext ->
- op "OpHasNext"
- | `HasNext2 (object_reg,index_reg) ->
- op_a "OpHasNext2" ["object",object_reg;"index",index_reg]
- | `IfEq target ->
- op_i "OpIfEq" ["target",target]
- | `IfFalse target ->
- op_i "OpIfFalse" ["target",target]
- | `IfGt target ->
- op_i "OpIfGt" ["target",target]
- | `IfLe target ->
- op_i "OpIfLe" ["target",target]
- | `IfLt target ->
- op_i "OpIfLt" ["target",target]
- | `IfNge target ->
- op_i "OpIfNge" ["target",target]
- | `IfNgt target ->
- op_i "OpIfNgt" ["target",target]
- | `IfNle target ->
- op_i "OpIfNle" ["target",target]
- | `IfNlt target ->
- op_i "OpIfNgt" ["target",target]
- | `IfNe target ->
- op_i "OpIfNe" ["target",target]
- | `IfStrictEq target ->
- op_i "OpIfStrictEq" ["target",target]
- | `IfStrictNe target ->
- op_i "OpIfStrictNe" ["target",target]
- | `IfTrue target ->
- op_i "OpIfTrue" ["target",target]
- | `In ->
- op "OpIn"
- | `IncLocal address ->
- op_a "OpIncLocal" ["address",address]
- | `IncLocal_i address ->
- op_a "OpIncLocalI" ["address",address]
- | `Increment ->
- op "OpIncrement"
- | `Increment_i ->
- op "OpIncrementI"
- | `InitProperty name ->
- op_a "OpInitProperty" ["name",name]
- | `InstanceOf ->
- op "OpInstanceOf"
- | `IsType name ->
- op_a "OpIsType" ["name",name]
- | `IsTypeLate ->
- op "OpIsTypeLate"
- | `Jump target ->
- op_i "OpJump" ["target",target]
- | `Kill address ->
- op_a "OpKill" ["address",address]
- | `Label ->
- op "OpLabel"
- | `LessEquals ->
- op "OpLessEquals"
- | `LessThan ->
- op "OpLessThan"
- | `LookupSwitch (default_target,target_table) ->
- element "OpLookupSwitch" ["defaultTarget",string_of_int default_target;
- "caseCount" ,string_of_int @@ List.length target_table]
- [elem "targetTable" @@ List.map (fun v -> attr "U30" ["value",string_of_int v]) target_table]
- | `LShift ->
- op "OpLShift"
- | `Modulo ->
- op "OpModulo"
- | `Multiply ->
- op "OpMultiply"
- | `Multiply_i ->
- op "OpMultiplyI"
- | `Negate ->
- op "OpNegate"
- | `Negate_i ->
- op "OpNegateI"
- | `NewActivation ->
- op "OpNewActivation"
- | `NewArray argc ->
- op_a "OpNewArray" ["argc",argc]
- | `NewCatch exceptionIndex ->
- op_a "OpNewCatch" ["exceptionIndex",exceptionIndex]
- | `NewClass classIndex ->
- op_a "OpNewClass" ["classIndex",classIndex]
- | `NewFunction index ->
- op_a "OpNewFunction" ["index",index]
- | `NewObject argc ->
- op_a "OpNewObject" ["argc",argc]
- | `NextName ->
- op "OpNextName"
- | `NextValue ->
- op "OpNextValue"
- | `Nop ->
- op "OpNop"
- | `Not ->
- op "OpNot"
- | `Pop ->
- op "OpPop"
- | `PopScope ->
- op "OpPopScope"
- | `PushByte byte ->
- attr "OpPushByte" ["value",string_of_int byte]
- | `PushDouble index ->
- op_a "OpPushDouble" ["index",index]
- | `PushFalse ->
- op "OpPushFalse"
- | `PushInt index ->
- op_a "OpPushInt" ["index",index]
- | `PushNamespace index ->
- op_a "OpPushNamespace" ["index",index]
- | `PushNan ->
- op "OpPushNan"
- | `PushNull ->
- op "OpPushNull"
- | `PushScope ->
- op "OpPushScope"
- | `PushShort value ->
- op_a "OpPushShort" ["value",value]
- | `PushString index ->
- op_a "OpPushString" ["index",index]
- | `PushTrue ->
- op "OpPushTrue"
- | `PushUInt index ->
- op_a "OpPushUInt" ["index",index]
- | `PushUndefined ->
- op "OpPushUndefined"
- | `PushWith ->
- op "OpPushWith"
- | `ReturnValue ->
- op "OpReturnValue"
- | `ReturnVoid ->
- op "OpReturnVoid"
- | `RShift ->
- op "OpRShift"
- | `SetLocal address ->
- op_a "OpSetLocal" ["address",address]
- | `SetLocal_0 ->
- op "OpSetLocal0"
- | `SetLocal_1 ->
- op "OpSetLocal1"
- | `SetLocal_2 ->
- op "OpSetLocal2"
- | `SetLocal_3 ->
- op "OpSetLocal3"
- | `SetGlobalSlot slot_id ->
- op_a "OpSetGlobalSlot" ["slotID",slot_id]
- | `SetProperty name ->
- op_a "OpSetProperty" ["name",name]
- | `SetSlot slot_id ->
- op_a "OpSetSlot" ["slotID",slot_id]
- | `SetSuper name ->
- op_a "OpSetSuper" ["name",name]
- | `StrictEquals ->
- op "OpStrictEquals"
- | `Subtract ->
- op "OpSubtract"
- | `Subtract_i ->
- op "OpSubtractI"
- | `SubtractI ->
- op "OpSubtractI"
- | `Swap ->
- op "OpSwap"
- | `Throw ->
- op "OpThrow"
- | `TypeOf ->
- op "OpTypeOf"
- | `URShift ->
- op "OpURShift"
-
+++ /dev/null
-let element name attrs children =
- Xml.Element (name,attrs,children)
-
-let elem name children =
- element name [] children
-
-let attr name attrs =
- element name attrs []
-
-let pcdata x =
- Xml.PCData x
-
-
-let rec normalize =
- function
- Xml.Element (name,attrs,children) ->
- Xml.Element (name,
- List.sort (fun (a,_) (b,_) -> compare a b) attrs,
- List.map normalize children)
- | x ->
- x
+++ /dev/null
-open Base
-let _ =
- let argv =
- Array.to_list Sys.argv in
- match argv with
- _::xs ->
- xs +> List.iter (print_endline $
- Xml.to_string_fmt $
- Swfmill.to_xml $
- Abc.of_stream $
- Byte.of_channel $
- open_in_bin)
- | [] ->
- failwith "must not happen"
+++ /dev/null
-open Base
-open EasyXml
-
-let some x =
- match x with Some _ -> "1" | None -> "0"
-
-let bool x =
- if x then "1" else "0"
-
-let u30 x =
- attr "U30" ["value",Int32.to_string x]
-
-let value name x =
- attr name ["value",x]
-
-let index_attr name xs =
- attr name @@ List.map (fun (x,y) -> (x,Int32.to_string y)) xs
-
-let elem_with name f xs =
- elem name @@ List.map f xs
-
-let of_namespace ns =
- let make name index =
- element name ["index",Int32.to_string index] [] in
- match ns with
- `Namespace name ->
- make "Namespace" name
- | `PackageNamespace name ->
- make "PackageNamespace" name
- | `PackageInternaNs name ->
- make "PackageInternalNamespace" name
- | `ProtectedNamespace name ->
- make "ProtectedNamespace" name
- | `ExplicitNamespace name ->
- make "ExplicitNamespace" name
- | `StaticProtectedNs name ->
- todo "this namespace is not support."
- | `PrivateNs name ->
- make "PrivateNamespace" name
-
-let of_ns_set ns_set =
- elem "namespaces" @@
- List.map (value "U30" $ Int32.to_string) ns_set#ns
-
-let of_multiname =
- function
- `QName o ->
- index_attr "QName" ["nameIndex",o#name; "namespaceIndex",o#ns]
- | `QNameA o ->
- index_attr "QNameA" ["namespaceIndex",o#ns; "nameIndex",o#name]
- | `RTQName o ->
- index_attr "RTQName" ["nameIndex",o#name]
- | `RTQNameA o ->
- index_attr "RTQNameA" ["nameIndex",o#name]
- | `RTQNameL ->
- index_attr "RTQNameL" []
- | `RTQNameLA ->
- index_attr "RTQNameLA" []
- | `Multiname o ->
- index_attr "Multiname" ["nameIndex",o#name; "namespaceSetIndex",o#ns_set]
- | `MultinameA o ->
- index_attr "MultinameA" ["nameIndex",o#name; "namespaceSetIndex",o#ns_set]
- | `MultinameL o ->
- index_attr "MultinameL" ["namespaceSetIndex",o#ns_set]
- | `MultinameLA o ->
- index_attr "MultinameLA" ["namespaceSetIndex",o#ns_set]
-
-let of_cpool constants =
- elem "Constants"
- [
- elem "ints" @@ List.map (value "U30" $ Int32.to_string) constants#integer;
- elem "uints" @@ List.map (value "U30" $ Int32.to_string) constants#uinteger;
- elem "doubles" @@ List.map (value "Double" $ string_of_float) constants#double;
- elem "strings" @@ List.map (value "String2") constants#string;
- elem "namespaces" @@ List.map of_namespace constants#namespace;
- elem "namespaceSets" @@ List.map of_ns_set constants#ns_set;
- elem "multinames" @@ List.map of_multiname constants#multiname
- ]
-
-let of_methods xs =
- elem_with "methods"
- (fun m ->
- element "MethodInfo" ["retType" ,Int32.to_string m#return_type;
- "nameIndex" ,Int32.to_string m#name;
- "hasParamNames" ,some m#param_names;
- "setSDXNs" ,bool m#set_dxns;
- "isExplicit" ,"0";
- "ignoreRest" ,bool m#need_rest;
- "hasOptional" ,some m#options;
- "needRest" ,bool m#need_rest;
- "needActivation",bool m#need_activation;
- "needArguments" ,bool m#need_arguments]
- [elem "paramTypes" @@ List.map u30 m#param_types]) xs
-
-let of_metadata xs =
- elem_with "metadata"
- (fun m ->
- element "MetadataInfo" ["nameIndex",Int32.to_string m#name]
- [elem "keys" @@ List.map (fun i-> u30 i#key) m#items;
- elem "values" @@ List.map (fun i-> u30 i#value) m#items ]) xs
-
-let of_trait trait =
- element "TraitInfo" [ "nameIndex" ,Int32.to_string trait#name;
- "hasMetadata",some trait#metadata;
- "override" ,bool trait#attr_override;
- "final" ,bool trait#attr_final]
- [ elem "trait" [
- match trait#data with
- `Class t ->
- attr "Class" ["slotID",Int32.to_string t#slot_id;
- "classInfo",Int32.to_string t#classi]
- | `Slot t ->
- index_attr "Slot" @@ (["slotID" ,t#slot_id;
- "typeIndex" ,t#type_name;
- "valueIndex",t#vindex;
- ] @ match t#vkind with
- None -> [ ]
- | Some kind -> ["valueKind",Int32.of_int kind])
- | `Const t ->
- attr "Slot" @@ ([
- "slotID" ,Int32.to_string t#slot_id;
- "typeIndex" ,Int32.to_string t#type_name;
- "valueIndex",Int32.to_string t#vindex;
- ] @ match t#vkind with
- None -> [ ]
- | Some kind -> ["valueKind",string_of_int kind])
- | `Function t ->
- attr "Function" ["slotID",Int32.to_string t#slot_id;
- "methodInfo",Int32.to_string t#functioni]
- | `Getter t ->
- attr "Getter" ["dispID",Int32.to_string t#disp_id;
- "methodInfo",Int32.to_string t#methodi]
- | `Method t ->
- attr "Method" ["dispID",Int32.to_string t#disp_id;"methodInfo",Int32.to_string t#methodi]
- | `Setter t ->
- attr "Setter" ["dispID",Int32.to_string t#disp_id;"methodInfo",Int32.to_string t#methodi]
- ]]
-
-
-let of_instances instances =
- elem_with "instances"
- (fun i ->
- element "InstanceInfo"
- (["nameIndex" ,Int32.to_string i#name;
- "superIndex" ,Int32.to_string i#super_name;
- "hasProtectedNS",bool i#is_protected;
- "interface" ,bool i#is_interface;
- "final" ,bool i#is_final;
- "sealed" ,bool i#is_sealed;
- "iInitIndex" ,Int32.to_string i#iinit] @
- (match i#protectedNs with
- None -> []
- | Some x ->
- ["protectedNS",Int32.to_string x])) @@
- [elem "interfaces" @@ List.map u30 i#interface;
- elem "traits" @@ List.map of_trait i#traits]) instances
-
-let of_classes xs =
- elem_with "classes"
- (fun c ->
- element "ClassInfo"
- ["cInitIndex",Int32.to_string c#cinit]
- [elem "traits" @@ List.map of_trait c#traits]) xs
-
-let of_exception e =
- index_attr "Exception" [
- "tryStart",e#from_pos;
- "tryEnd" ,e#to_pos;
- "target" ,e#target;
- "type" ,e#exc_type;
- "name" ,e#var_name ]
-
-let of_method_bodies xs =
- elem_with "methodBodies"
- (fun m ->
- element "MethodBody" ["exceptionCount",string_of_int @@ List.length m#exceptions;
- "maxRegs" ,Int32.to_string m#local_count;
- "maxScope" ,Int32.to_string m#max_scope_depth;
- "maxStack" ,Int32.to_string m#max_stack;
- "methodInfo" ,Int32.to_string m#methodi;
- "scopeDepth" ,Int32.to_string m#init_scope_depth]
- [elem_with "code" Code.to_xml m#code;
- elem_with "exceptions" of_exception m#exceptions;
- elem_with "traits" of_trait m#traits ]) xs
-
-
-let of_script scripts =
- elem_with "scripts"
- (fun s ->
- element "ScriptInfo" ["initIndex",Int32.to_string s#init] @@
- [elem_with "traits" of_trait s#traits] )
- scripts
-
-
-let of_abc abc =
- element "Action3"
- ["minorVersion",string_of_int abc#minor_version;
- "majorVersion",string_of_int abc#major_version]
- [elem "constants" [of_cpool abc#constant_pool];
- of_methods abc#methods;
- of_metadata abc#metadata;
- of_instances abc#instances;
- of_classes abc#classes;
- of_script abc#script;
- of_method_bodies abc#method_body]
-
-let to_xml =
- of_abc
-
-let f () =
- let ch =
- open_in_bin "a.abc" in
- Abc.of_stream @@ Byte.of_channel ch
-
-let sample () =
- let ch =
- open_in_bin "a.abc" in
- to_xml @@ Abc.of_stream @@ Byte.of_channel ch
-
OSDN Git Service
