Commits

camlspotter committed b06d459

now llvm starts

Comments (0)

Files changed (17)

 
 OCAMLPACKS[]= 
     sexplib.syntax
+    llvm
 
 OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax
 OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax
    sbuffer
    planck
    plang
+   plex
    pscheme
    test
 
+requires = ""
+version = "[llvm 2.8]"
+description = "LLVM 2.8"
+directory = "^"
+browse_interfaces = " Llvm Llvm_analysis Llvm_bitreader Llvm_bitwriter Llvm_executionengine Llvm_scalar_opts Llvm_target "
+archive(byte) = "llvm.cma llvm_analysis.cma"
+archive(native) = "llvm.cmxa llvm_analysis.cmxa"
+linkopts = "-cc g++ -cclib -L/home/jfuruse/.share/prefix/lib -cclib -lpthread -cclib -ldl -cclib -lm -cclib -lLLVMpic16passes -cclib -lLLVMMCDisassembler -cclib -lLLVMXCoreCodeGen -cclib -lLLVMXCoreAsmPrinter -cclib -lLLVMXCoreInfo -cclib -lLLVMSystemZCodeGen -cclib -lLLVMSystemZAsmPrinter -cclib -lLLVMSystemZInfo -cclib -lLLVMSparcCodeGen -cclib -lLLVMSparcAsmPrinter -cclib -lLLVMSparcInfo -cclib -lLLVMPowerPCCodeGen -cclib -lLLVMPowerPCAsmPrinter -cclib -lLLVMPowerPCInfo -cclib -lLLVMPIC16AsmPrinter -cclib -lLLVMPIC16CodeGen -cclib -lLLVMPIC16Info -cclib -lLLVMMipsAsmPrinter -cclib -lLLVMMipsCodeGen -cclib -lLLVMMipsInfo -cclib -lLLVMMSP430CodeGen -cclib -lLLVMMSP430AsmPrinter -cclib -lLLVMMSP430Info -cclib -lLLVMMBlazeAsmPrinter -cclib -lLLVMMBlazeCodeGen -cclib -lLLVMMBlazeInfo -cclib -lLLVMLinker -cclib -lLLVMipo -cclib -lLLVMInterpreter -cclib -lLLVMInstrumentation -cclib -lLLVMJIT -cclib -lLLVMExecutionEngine -cclib -lLLVMCppBackend -cclib -lLLVMCppBackendInfo -cclib -lLLVMCellSPUCodeGen -cclib -lLLVMCellSPUAsmPrinter -cclib -lLLVMCellSPUInfo -cclib -lLLVMCBackend -cclib -lLLVMCBackendInfo -cclib -lLLVMBlackfinCodeGen -cclib -lLLVMBlackfinAsmPrinter -cclib -lLLVMBlackfinInfo -cclib -lLLVMBitWriter -cclib -lLLVMX86Disassembler -cclib -lLLVMX86AsmParser -cclib -lLLVMX86CodeGen -cclib -lLLVMX86AsmPrinter -cclib -lLLVMX86Info -cclib -lLLVMAsmParser -cclib -lLLVMARMDisassembler -cclib -lLLVMARMAsmParser -cclib -lLLVMARMCodeGen -cclib -lLLVMARMAsmPrinter -cclib -lLLVMARMInfo -cclib -lLLVMArchive -cclib -lLLVMBitReader -cclib -lLLVMAlphaCodeGen -cclib -lLLVMSelectionDAG -cclib -lLLVMAlphaAsmPrinter -cclib -lLLVMAsmPrinter -cclib -lLLVMMCParser -cclib -lLLVMCodeGen -cclib -lLLVMScalarOpts -cclib -lLLVMInstCombine -cclib -lLLVMTransformUtils -cclib -lLLVMipa -cclib -lLLVMAnalysis -cclib -lLLVMTarget -cclib -lLLVMMC -cclib -lLLVMCore -cclib -lLLVMAlphaInfo -cclib -lLLVMSupport -cclib -lLLVMSystem "
+requires = ""
+version = "[llvm 2.8]"
+description = "LLVM 2.8"
+directory = "^"
+browse_interfaces = " Llvm Llvm_analysis Llvm_bitreader Llvm_bitwriter Llvm_executionengine Llvm_scalar_opts Llvm_target "
+archive(byte) = "llvm.cma llvm_analysis.cma"
+archive(native) = "llvm.cmxa llvm_analysis.cmxa"
+linkopts = 

llvm/llvm-spot-copy.sh

+#!/bin/sh
+
+for i in `find $PREFIX/lib/ocaml/ -name 'llvm*.mli'`
+do
+  spit=`echo \`basename $i\` | sed -e 's/mli$/spit/'`
+  src=`find llvm-2.8/bindings/ocaml -iname $spit`
+  if [ "$src" != "" ]; then
+    echo found $src
+    cp $src $PREFIX/lib/ocaml
+  fi
+done
+

llvm/make-META.sh

+#!/bin/sh
+
+cat META.in
+
+echo -n '"-cc g++ '
+
+for i in `llvm-config --libs --ldflags`
+do
+  echo -n "-cclib $i "
+done
+
+echo '"'
 type ('a, 'pos) generator = ('a, 'pos) Pstream.generator
 
 module type S = sig
-  type pos
-  module Result : Result.S with type error = pos * string
   module Str : Pstream.S
-  type 'a t = Str.t -> ('a * Str.t) Result.t
-  include Utils.Monad.T with type 'a t := 'a t
+  module Result : Result.S with type error = Str.pos * string
+  include Utils.Monad.T with type 'a t = Str.t -> ('a * Str.t) Result.t
   val take : Str.elem t
-  val pos : 'a t -> ('a * pos) t
+  val pos : 'a t -> ('a * Str.pos) t
   val error : string -> 'a t
   val eos : unit t
   val filter_map : string -> (Str.elem -> 'a option) -> 'a t
   val ( <|> ) : 'a t -> 'a t -> 'a t
   val ignore : 'a t -> unit t
     
-  val stream_gen : 'a option t -> Str.t -> ('a, pos * pos) generator
+  val stream_gen : 
+    'a option t 
+    -> (Str.t -> Str.t -> 'b)  (* position calculator *)
+    -> Str.t 
+    -> ('a, 'b) generator
 end
 
 (* basic *)
     | Some _ -> R.Error (S.pos s, "end of stream expected")
     | None -> R.Ok ((), s)
   
-  let filter_map : 'a . string -> (S.elem -> 'a option) -> 'a t = 
+  let filter_map : string -> (S.elem -> 'a option) -> 'a t = 
     fun error_mes p s ->
       Result.bind (take s) (fun (elem, s') ->
 	match p elem with
     in
     aux str >>= fun () -> return ()
   
-  let star : 'a . 'a t -> 'a list t = fun com ->
+  let star : 'a t -> 'a list t = fun com ->
     let rec aux st = fun s ->
       match com s with
       | R.Error _ -> return (List.rev st) s
     in
     aux []
   
-  let star_ : 'a . 'a t -> unit t = fun com ->
+  let star_ : 'a t -> unit t = fun com ->
     let rec aux = fun s ->
       match com s with
       | R.Error _ -> return () s
     in
     aux
   
-  let plus : 'a . 'a t -> 'a list t = fun com ->
+  let plus : 'a t -> 'a list t = fun com ->
     com >>= fun v -> 
     star com >>= fun vs -> 
     return (v :: vs)
   
-  let plus_ : 'a . 'a t -> unit t = fun com ->
+  let plus_ : 'a t -> unit t = fun com ->
     com >>= fun _v -> 
     star_ com >>= fun () -> 
     return ()
 
   module Str = S
 
-  let stream_gen (c : 'a option t) (st : Str.t) =
+  let stream_gen (c : 'a option t) (pos_conv : Str.t -> Str.t -> 'b) (st : Str.t) =
     let rec f st () = 
       match c st with
       | Result.Ok (None, st') -> f st' ()
-      | Result.Ok (Some token, st') -> (S.pos st, S.pos st'), `Some (token, f st')
-      | Result.Error (_, "unexpected end of stream") -> (S.pos st, S.pos st), `None
+      | Result.Ok (Some token, st') -> pos_conv st st', `Some (token, f st')
+      | Result.Error (_, "unexpected end of stream") -> pos_conv st st, `None
       | Result.Error (pos, s) -> raise (Error (pos, s))
     in
     f st
 (* CR bad escape *)
 
 module type S = sig
-  type pos
-  module Result : Result.S with type error = pos * string
   module Str : Pstream.S
-  type 'a t = Str.t -> ('a * Str.t) Result.t
-  include Utils.Monad.T with type 'a t := 'a t
+  module Result : Result.S with type error = Str.pos * string
+  
+  include Utils.Monad.T with type 'a t = Str.t -> ('a * Str.t) Result.t
 
   val take : Str.elem t
-  val pos : 'a t -> ('a * pos) t
+  val pos : 'a t -> ('a * Str.pos) t
   val error : string -> 'a t
   val eos : unit t
   val filter_map : string -> (Str.elem -> 'a option) -> 'a t
   val ( <|> ) : 'a t -> 'a t -> 'a t
   val ignore : 'a t -> unit t
 
-  val stream_gen : 'a option t -> Str.t -> ('a, pos * pos) generator
+  val stream_gen : 
+    'a option t 
+    -> (Str.t -> Str.t -> 'b)  (* position calculator *)
+    -> Str.t 
+    -> ('a, 'b) generator
 end
 
 module Make (S : Pstream.S) : S 
   with module Str = S
-  and  type pos = S.pos
 
 module String (S : Pstream.S with type elem = char) : sig
   include S with module Str = S
-	    and type pos = S.pos	
   val string : string -> string t
   val chars_to_string : char list t -> string t
 end
 open Utils
 
-module OCaml = struct
-  module Char = Char
-end
-
 module type P = sig
   include Planck.S with type Str.elem = Sbuffer.elem
                    and  type Str.t = Sbuffer.t
-		   and  type pos = Sbuffer.pos
+		   and  type Str.pos = Sbuffer.pos
   val string : string -> string t
   val chars_to_string : char list t -> string t
 
 	  if Sbuffer.bytes st1 >= Sbuffer.bytes st2 then r1 else r2
 end
 
-module Literal = struct
-
-  open P
-
-  module Char = struct
-    let digit_char =
-      tokenp "digit expected" (function
-        | '0' .. '9' -> true
-        | _ -> false)
-    
-    let digit =
-      filter_map "digit expected" (function
-        | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
-        | _ -> None)
-    
-    let oct_char =
-      tokenp "octal expected" (function
-        | '0' .. '7' -> true
-        | _ -> false)
-    
-    let oct =
-      filter_map "octal expected" (function
-        | ('0' .. '7' as c) -> Some (Char.code c - Char.code '0')
-        | _ -> None)
-    
-    let hex_char =
-      tokenp "hex expected" (function
-        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
-        | _ -> false)
-    
-    let hex =
-      filter_map "hex expected" (function
-        | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
-        | ('a' .. 'f' as c) -> Some (Char.code c - Char.code 'a' + 10)
-        | ('A' .. 'F' as c) -> Some (Char.code c - Char.code 'A' + 10)
-        | _ -> None)
-    
-    let char = 
-      let normal = tokenp "" (function
-        | '\'' | '\\' -> false
-        | _ -> true)
-      in
-      let backslashed = 
-        token "" '\\' >>= fun _ ->
-    	filter_map "" (function
-    	  | 'b' -> Some '\b'
-    	  | 't' -> Some '\t'
-    	  | 'n' -> Some '\n'
-    	  | 'f' -> Some '\012'
-    	  | 'r' -> Some '\r'
-    	  | 'e' -> Some '\027'
-    	  | '\'' -> Some '\''
-    	  | _ -> None)
-      in
-      let hex =
-        string "\\x" >>= fun _ ->
-    	hex >>= fun c1 ->
-    	hex >>= fun c2 ->
-    	return (char_of_int (c1 * 16 + c2))
-      in
-      let oct =
-        string "\\o" >>= fun _ ->
-    	oct >>= fun c1 ->
-    	oct >>= fun c2 ->
-    	oct >>= fun c3 ->
-    	return (char_of_int (c1 * 64 + c2 * 8 + c3))
-      in
-      let digit = 
-        string "\\" >>= fun _ ->
-    	digit >>= fun c1 ->
-    	digit >>= fun c2 ->
-    	digit >>= fun c3 ->
-    	return (char_of_int (c1 * 100 + c2 * 10 + c3))
-      in
-      let quote = token "" '\'' in
-      surrounded quote quote (normal <|> backslashed <|> hex <|> oct <|> digit)
-  end
-
-  module String = struct
-    open Char
-
-    let string = 
-      let normal = tokenp "" (function
-        | '"' | '\\' -> false
-        | _ -> true)
-      in
-      let backslashed = 
-        token "" '\\' >>= fun _ ->
-    	filter_map "" (function
-    	  | 'b' -> Some '\b'
-    	  | 't' -> Some '\t'
-    	  | 'n' -> Some '\n'
-    	  | 'f' -> Some '\012'
-    	  | 'r' -> Some '\r'
-    	  | 'e' -> Some '\027'
-    	  | '\'' -> Some '\''
-    	  | _ -> None)
-      in
-      let hex =
-        string "\\x" >>= fun _ ->
-    	hex >>= fun c1 ->
-    	hex >>= fun c2 ->
-    	return (char_of_int (c1 * 16 + c2))
-      in
-      let oct =
-        string "\\o" >>= fun _ ->
-    	oct >>= fun c1 ->
-    	oct >>= fun c2 ->
-    	oct >>= fun c3 ->
-    	return (char_of_int (c1 * 64 + c2 * 8 + c3))
-      in
-      let digit = 
-        string "\\" >>= fun _ ->
-    	digit >>= fun c1 ->
-    	digit >>= fun c2 ->
-    	digit >>= fun c3 ->
-    	return (char_of_int (c1 * 100 + c2 * 10 + c3))
-      in
-      let dquote = token "" '\"' in
-      surrounded dquote dquote 
-	(chars_to_string (star (normal <|> backslashed <|> hex <|> oct <|> digit)))
-  end
-
-  module Num = struct
-
-    type nat = { base : int;
-		 rev_nums : int list }
-
-    let code_0 = OCaml.Char.code '0' 
-    let code_a = OCaml.Char.code 'a'
-    let code_A = OCaml.Char.code 'A'
-
-    let rev_nums = List.rev_map (function c ->
-      let offset = match c with 
-	| '0'..'9' -> code_0
-	| 'a'..'f' -> code_a - 10
-	| 'A'..'F' -> code_A - 10
-	| _ -> assert false
-      in
-      OCaml.Char.code c - offset)
-
-    let digit =
-      plus Char.digit_char >>= fun chars ->
-      return { base = 10; rev_nums =  rev_nums chars }
-    let oct =
-      string "0o" >>= fun _ ->
-      plus Char.oct_char >>= fun chars ->
-      return { base = 8; rev_nums = rev_nums chars }
-    let hex =
-      string "0x" >>= fun _ ->
-      plus Char.hex_char >>= fun chars ->
-      return { base = 16; rev_nums = rev_nums chars }
-
-    let nat = digit <|> oct <|> hex
-    (* CR jfuruse: we must take the longest match, 
-       to make this ordering working *)
-
-    (* CR jfuruse: no overflow. No minus. *)
-    (* Order is important *)
-    let nat = oct <|> hex <|> digit
-
-    let nat_int = nat >>= fun t ->
-      let base = t.base in
-      let rec to_int st mul = function
-	| [] -> st
-	| x::xs -> to_int (st + x * mul) (mul * base) xs
-      in
-      return (to_int 0 1 t.rev_nums)
-  end
-
-  let char = Char.char
-  let string = String.string
-  let nat = Num.nat
-  let nat_int = Num.nat_int
-end
-
-module Identifier = struct
-
-  open P
-
-  (* [A-Za-z0-9_'] *)
-  let char_uppercase = tokenp "[A-Z] expected" (function
-    | 'A'..'Z' -> true
-    | _ -> false)
-
-  let char_lowercase = tokenp "[a-z] expected" (function
-    | 'a'..'z' -> true
-    | _ -> false)
-
-  let char_lowercase_symbol = tokenp "[_\'] expected" (function
-    | '_' | '\'' -> true
-    | _ -> false)
-
-  let char_lowercase_head_symbol = tokenp "[_] expected" (function
-    | '_' -> true
-    | _ -> false)
-
-  let lowercase : string t = 
-    substr ((char_lowercase_head_symbol <|> char_lowercase) >>= fun _ -> 
-            star_ (char_uppercase <|> char_lowercase <|> char_lowercase_symbol <|> Literal.Char.digit_char))
-
-  let uppercase : string t =
-    substr (char_uppercase >>= fun _ -> 
-            star_ (char_uppercase <|> char_lowercase <|> char_lowercase_symbol <|> Literal.Char.digit_char))
-end
-
-let whitespace : char P.t = P.tokenp "Whitespace expected" (function
-  | ' ' | '\t' | '\n' | '\r' | '\000' -> true
-  | _ -> false)
-
-module Token = struct
-  type t =
-    | Int of int
-    | Char of char
-    | String of string
-    | LIdent of string
-    | UIdent of string
-    | LParen
-    | RParen
-  with sexp
-
-  type token = t
-
-  open P
-  let lex : token option P.t = 
-    let ret v = return (Some v) in
-    (plus_ whitespace >>= fun _ -> return None)
-    <|> (
-      (token "( expected" '(' >>= fun _ -> ret LParen)
-      <|> (token ") expected" ')' >>= fun _ -> ret RParen)
-      <|> (Literal.char >>= fun c -> ret (Char c))
-      <|> (Literal.string >>= fun s -> ret (String s))
-      <|> (Literal.nat_int >>= fun i -> ret (Int i))
-      <|> (Identifier.lowercase >>= fun s -> ret (LIdent s))
-      <|> (Identifier.uppercase >>= fun s -> ret (UIdent s))
-      <|> (take >>= fun c -> error (Printf.sprintf "Unexpected char %C" c))
-    )  
-    
-  module Str = Pstream.Simple(struct type t = token end)(Position.Region)
-
-  let rec regionize gen =
-    fun () -> 
-      let (pos1, pos2), res = gen () in
-      let pos = { Position.Region.start = pos1; end_ = pos2 } in
-      let res = match res with
-	| `None -> `None
-	| `Some (v, gen) -> `Some (v, regionize gen)
-      in
-      pos, res
-
-  let stream st = Str.create (regionize (P.stream_gen lex st))
-end
-
 include P
-
-module Test = struct
-  let f t str =
-    let stream = Sbuffer.from_string str in
-    match t stream with
-    | Result.Error _ -> None
-    | Result.Ok (v,_) -> Some v
-
-  let literal_ident () =
-    prerr_endline "Plang.Test.literal_ident ...";
-    assert (f Literal.char "'x'" = Some 'x');
-    assert (f Literal.char "'xx'" = None);
-    assert (f Literal.char "'\n'" = Some '\n');
-    assert (f Literal.char "'\\''" = Some '\'');
-    assert (f Literal.char "'\\x41'" = Some 'A');
-    assert (f Literal.char "'\\o101'" = Some 'A');
-    assert (f Literal.char "'\\065'" = Some 'A');
-    assert (f Literal.string "\"hello world\"" = Some "hello world");
-    assert (f Literal.string "\"hello\\nworld\"" = Some "hello\nworld");
-    assert (f Literal.nat_int "0123" = Some 123);
-    assert (f Literal.nat_int "0o10" = Some 8);
-    assert (f Literal.nat_int "0x10" = Some 16);
-    assert (f Identifier.lowercase "hello42World_\'*" = Some "hello42World_\'");
-    assert (f Identifier.uppercase "Hello42World_\'*" = Some "Hello42World_\'");
-    assert (f (Literal.Num.digit </> Literal.Num.hex) "0x10" = Some { Literal.Num.base = 16; rev_nums = [0; 1] });
-    prerr_endline "Plang.Test.literal_ident done"
-  ;;
-
-  open Token
-  let lex () = 
-    prerr_endline "Plang.Test.lex ...";
-    assert (Token.Str.to_list (Token.stream (Sbuffer.from_string "(hello 24 world)"))
-	      = [ LParen; LIdent "hello"; Int 24; LIdent "world"; RParen ]);
-    prerr_endline "Plang.Test.lex done"
-end
 module type P = sig
   include Planck.S with type Str.elem = Sbuffer.elem
                    and  type Str.t = Sbuffer.t
-		   and  type pos = Sbuffer.pos
+		   and  type Str.pos = Sbuffer.pos
+  (* From Planck.String *)			  
   val string : string -> string t
   val chars_to_string : char list t -> string t
 
     (** longest match *)
 end
 
-module P : P
-
-module Literal : sig
-
-  open P
-
-  module Num : sig
-    type nat = { base : int;
-		 rev_nums : int list }
-    val digit : nat t
-    val oct : nat t
-    val hex : nat t
-    val nat : nat t
-    val nat_int : int t
-  end
-
-  val char : char t
-  val string : string t
-  val nat : Num.nat t
-  val nat_int : int t
-end
-
-module Identifier : sig
-  open P
-
-  val lowercase : string t
-  val uppercase : string t
-end
-
-val whitespace : char P.t
-
-module Token : sig
-  type t =
-    | Int of int
-    | Char of char
-    | String of string
-    | LIdent of string
-    | UIdent of string
-    | LParen
-    | RParen
-  with sexp
-
-  val lex : t option P.t
-
-  module Str : Pstream.S 
-    with type pos = Position.Region.t
-    and type elem = t
-  val stream : Sbuffer.t -> Str.t
-end
-
 include P
-
-module Test : sig
-  val literal_ident : unit -> unit
-  val lex : unit -> unit
-end
+open Plang
+
+module OCaml = struct
+  module Char = Char
+end
+
+module Literal = struct
+
+  module Char = struct
+    let digit_char =
+      tokenp "digit expected" (function
+        | '0' .. '9' -> true
+        | _ -> false)
+    
+    let digit =
+      filter_map "digit expected" (function
+        | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
+        | _ -> None)
+    
+    let oct_char =
+      tokenp "octal expected" (function
+        | '0' .. '7' -> true
+        | _ -> false)
+    
+    let oct =
+      filter_map "octal expected" (function
+        | ('0' .. '7' as c) -> Some (Char.code c - Char.code '0')
+        | _ -> None)
+    
+    let hex_char =
+      tokenp "hex expected" (function
+        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
+        | _ -> false)
+    
+    let hex =
+      filter_map "hex expected" (function
+        | ('0' .. '9' as c) -> Some (Char.code c - Char.code '0')
+        | ('a' .. 'f' as c) -> Some (Char.code c - Char.code 'a' + 10)
+        | ('A' .. 'F' as c) -> Some (Char.code c - Char.code 'A' + 10)
+        | _ -> None)
+    
+    let char = 
+      let normal = tokenp "" (function
+        | '\'' | '\\' -> false
+        | _ -> true)
+      in
+      let backslashed = 
+        token "" '\\' >>= fun _ ->
+    	filter_map "" (function
+    	  | 'b' -> Some '\b'
+    	  | 't' -> Some '\t'
+    	  | 'n' -> Some '\n'
+    	  | 'f' -> Some '\012'
+    	  | 'r' -> Some '\r'
+    	  | 'e' -> Some '\027'
+    	  | '\'' -> Some '\''
+    	  | _ -> None)
+      in
+      let hex =
+        string "\\x" >>= fun _ ->
+    	hex >>= fun c1 ->
+    	hex >>= fun c2 ->
+    	return (char_of_int (c1 * 16 + c2))
+      in
+      let oct =
+        string "\\o" >>= fun _ ->
+    	oct >>= fun c1 ->
+    	oct >>= fun c2 ->
+    	oct >>= fun c3 ->
+    	return (char_of_int (c1 * 64 + c2 * 8 + c3))
+      in
+      let digit = 
+        string "\\" >>= fun _ ->
+    	digit >>= fun c1 ->
+    	digit >>= fun c2 ->
+    	digit >>= fun c3 ->
+    	return (char_of_int (c1 * 100 + c2 * 10 + c3))
+      in
+      let quote = token "" '\'' in
+      surrounded quote quote (normal <|> backslashed <|> hex <|> oct <|> digit)
+  end
+
+  module String = struct
+    open Char
+
+    let string = 
+      let normal = tokenp "" (function
+        | '"' | '\\' -> false
+        | _ -> true)
+      in
+      let backslashed = 
+        token "" '\\' >>= fun _ ->
+    	filter_map "" (function
+    	  | 'b' -> Some '\b'
+    	  | 't' -> Some '\t'
+    	  | 'n' -> Some '\n'
+    	  | 'f' -> Some '\012'
+    	  | 'r' -> Some '\r'
+    	  | 'e' -> Some '\027'
+    	  | '\'' -> Some '\''
+    	  | _ -> None)
+      in
+      let hex =
+        string "\\x" >>= fun _ ->
+    	hex >>= fun c1 ->
+    	hex >>= fun c2 ->
+    	return (char_of_int (c1 * 16 + c2))
+      in
+      let oct =
+        string "\\o" >>= fun _ ->
+    	oct >>= fun c1 ->
+    	oct >>= fun c2 ->
+    	oct >>= fun c3 ->
+    	return (char_of_int (c1 * 64 + c2 * 8 + c3))
+      in
+      let digit = 
+        string "\\" >>= fun _ ->
+    	digit >>= fun c1 ->
+    	digit >>= fun c2 ->
+    	digit >>= fun c3 ->
+    	return (char_of_int (c1 * 100 + c2 * 10 + c3))
+      in
+      let dquote = token "" '\"' in
+      surrounded dquote dquote 
+	(chars_to_string (star (normal <|> backslashed <|> hex <|> oct <|> digit)))
+  end
+
+  module Num = struct
+
+    type nat = { base : int;
+		 rev_nums : int list }
+
+    let code_0 = OCaml.Char.code '0' 
+    let code_a = OCaml.Char.code 'a'
+    let code_A = OCaml.Char.code 'A'
+
+    let rev_nums = List.rev_map (function c ->
+      let offset = match c with 
+	| '0'..'9' -> code_0
+	| 'a'..'f' -> code_a - 10
+	| 'A'..'F' -> code_A - 10
+	| _ -> assert false
+      in
+      OCaml.Char.code c - offset)
+
+    let digit =
+      plus Char.digit_char >>= fun chars ->
+      return { base = 10; rev_nums =  rev_nums chars }
+    let oct =
+      string "0o" >>= fun _ ->
+      plus Char.oct_char >>= fun chars ->
+      return { base = 8; rev_nums = rev_nums chars }
+    let hex =
+      string "0x" >>= fun _ ->
+      plus Char.hex_char >>= fun chars ->
+      return { base = 16; rev_nums = rev_nums chars }
+
+    let nat = digit <|> oct <|> hex
+    (* CR jfuruse: we must take the longest match, 
+       to make this ordering working *)
+
+    (* CR jfuruse: no overflow. No minus. *)
+    (* Order is important *)
+    let nat = oct <|> hex <|> digit
+
+    let nat_int = nat >>= fun t ->
+      let base = t.base in
+      let rec to_int st mul = function
+	| [] -> st
+	| x::xs -> to_int (st + x * mul) (mul * base) xs
+      in
+      return (to_int 0 1 t.rev_nums)
+  end
+
+  let char = Char.char
+  let string = String.string
+  let nat = Num.nat
+  let nat_int = Num.nat_int
+end
+
+module Identifier = struct
+
+  (* [A-Za-z0-9_'] *)
+  let char_uppercase = tokenp "[A-Z] expected" (function
+    | 'A'..'Z' -> true
+    | _ -> false)
+
+  let char_lowercase = tokenp "[a-z] expected" (function
+    | 'a'..'z' -> true
+    | _ -> false)
+
+  let char_lowercase_symbol = tokenp "[_\'] expected" (function
+    | '_' | '\'' -> true
+    | _ -> false)
+
+  let char_lowercase_head_symbol = tokenp "[_] expected" (function
+    | '_' -> true
+    | _ -> false)
+
+  let lowercase : string t = 
+    substr ((char_lowercase_head_symbol <|> char_lowercase) >>= fun _ -> 
+            star_ (char_uppercase <|> char_lowercase <|> char_lowercase_symbol <|> Literal.Char.digit_char))
+
+  let uppercase : string t =
+    substr (char_uppercase >>= fun _ -> 
+            star_ (char_uppercase <|> char_lowercase <|> char_lowercase_symbol <|> Literal.Char.digit_char))
+end
+
+let whitespace : char t = tokenp "Whitespace expected" (function
+  | ' ' | '\t' | '\n' | '\r' | '\000' -> true
+  | _ -> false)
+
+module Test = struct
+  let f t str =
+    let stream = Sbuffer.from_string str in
+    match t stream with
+    | Result.Error _ -> None
+    | Result.Ok (v,_) -> Some v
+
+  let literal_ident () =
+    prerr_endline "Plang.Test.literal_ident ...";
+    assert (f Literal.char "'x'" = Some 'x');
+    assert (f Literal.char "'xx'" = None);
+    assert (f Literal.char "'\n'" = Some '\n');
+    assert (f Literal.char "'\\''" = Some '\'');
+    assert (f Literal.char "'\\x41'" = Some 'A');
+    assert (f Literal.char "'\\o101'" = Some 'A');
+    assert (f Literal.char "'\\065'" = Some 'A');
+    assert (f Literal.string "\"hello world\"" = Some "hello world");
+    assert (f Literal.string "\"hello\\nworld\"" = Some "hello\nworld");
+    assert (f Literal.nat_int "0123" = Some 123);
+    assert (f Literal.nat_int "0o10" = Some 8);
+    assert (f Literal.nat_int "0x10" = Some 16);
+    assert (f Identifier.lowercase "hello42World_\'*" = Some "hello42World_\'");
+    assert (f Identifier.uppercase "Hello42World_\'*" = Some "Hello42World_\'");
+    assert (f (Literal.Num.digit </> Literal.Num.hex) "0x10" = Some { Literal.Num.base = 16; rev_nums = [0; 1] });
+    prerr_endline "Plang.Test.literal_ident done"
+  ;;
+end
+
+open Plang
+
+module Literal : sig
+
+  module Num : sig
+    type nat = { base : int;
+		 rev_nums : int list }
+    val digit : nat t
+    val oct : nat t
+    val hex : nat t
+    val nat : nat t
+    val nat_int : int t
+  end
+
+  val char : char t
+  val string : string t
+  val nat : Num.nat t
+  val nat_int : int t
+end
+
+module Identifier : sig
+  val lowercase : string t
+  val uppercase : string t
+end
+
+val whitespace : char t
+
+module Test : sig
+  val literal_ident : unit -> unit
+end
+
 open Utils
 
-module T = Plang.Token
-module P = Planck.Make(T.Str)
-
-open P
+module Token = struct
+  type t =
+    | Int of int
+    | Char of char
+    | String of string
+    | LIdent of string
+    | UIdent of string
+    | LParen
+    | RParen
+    | Define
+    | Lambda
+  with sexp
+end
 
 module Lang = struct
   type desc = 
     | UIdent of string
     | Unit
     | App of t list
+    | Define of string * t
+    | Lambda of string list * t
 
   and t = { desc : desc; pos : Position.Region.t }
 
     | UIdent s -> Format.fprintf ppf "%s" s
     | Unit -> Format.fprintf ppf "()"
     | App ts -> 
-      Format.fprintf ppf "(@[%a@])"
-	(Format.list (fun ppf -> Format.fprintf ppf "@ ") format)
-	ts
+        Format.fprintf ppf "(@[<2>%a@])"
+	  (Format.list (fun ppf -> Format.fprintf ppf "@ ") format)
+	  ts
+    | Define (name, t) -> Format.fprintf ppf "(@[<2>define %s@ @[%a@]@])" name format t
+    | Lambda (names, t) -> 
+        Format.fprintf ppf "(@[<2>lambda (@[%a@])@ @[%a@]@])" 
+          (Format.list (fun ppf -> Format.fprintf ppf "@ ") Format.pp_print_string) names
+          format t
 end
 
-open Lang
+module Lexer = struct
 
-let lparen = token "( expected" T.LParen
-let rparen = token ") expected" T.RParen
+  open Token
+  open Plang
+  open Plex
 
-let with_pos t = pos t >>= fun (desc, pos) -> 
-  return { desc = desc; pos = pos }
+  let keyword_table = 
+    let tbl = Hashtbl.create 17 in
+    List.iter (fun (k,v) ->
+      Hashtbl.add tbl k v)
+      [ "define", Define;
+	"lambda", Lambda ];
+    tbl
+    
+  let lex : Token.t option t = 
+    let ret v = return (Some v) in
+    (plus_ whitespace >>= fun _ -> return None)
+    <|> (
+      (token "( expected" '(' >>= fun _ -> ret LParen)
+      <|> (token ") expected" ')' >>= fun _ -> ret RParen)
+      <|> (Literal.char >>= fun c -> ret (Char c))
+      <|> (Literal.string >>= fun s -> ret (String s))
+      <|> (Literal.nat_int >>= fun i -> ret (Int i))
+      <|> (Identifier.lowercase >>= fun s -> 
+	   try ret (Hashtbl.find keyword_table s) with Not_found -> ret (LIdent s))
+      <|> (Identifier.uppercase >>= fun s -> ret (UIdent s))
+      <|> (take >>= fun c -> error (Printf.sprintf "Unexpected char %C" c))
+    )  
+    
+  module Str = Pstream.Simple(struct type t = Token.t end)(Position.Region)
 
-let literal = filter_map "" (function 
-  | T.Int n -> Some (Int n)
-  | T.Char c -> Some (Char c)
-  | T.String s -> Some (String s)
-  | _ -> None)
+  let stream : Plang.Str.t -> Str.t = fun st -> Str.create 
+    (stream_gen lex (fun st st' ->
+      let pos1 : Position.File.t = Plang.Str.pos st in
+      let pos2 : Position.File.t = Plang.Str.pos st' in
+      { Position.Region.start = pos1; end_ = pos2 }) st)
 
-let ident = filter_map "" (function
-  | T.LIdent s -> Some (LIdent s)
-  | T.UIdent s -> Some (UIdent s)
-  | _ -> None)
+  module Test = struct
 
-let rec parened = fun x -> begin
-  surrounded lparen rparen (star expr)
-  >>= function
-    | [] -> return Unit
-    | l -> return (App l)
-end x
-    
-and expr = fun x -> begin
-  with_pos (literal <|> ident <|> parened)
-end x
+    open Token
+    let lex () = 
+      prerr_endline "Pscheme.Lexer.Test.lex ...";
+      assert (Str.to_list (stream (Sbuffer.from_string "(hello 24 world)"))
+	      = [ LParen; LIdent "hello"; Int 24; LIdent "world"; RParen ]);
+      prerr_endline "Plang.Test.lex done"
+  end
+end
 
-module Test = struct
+module Parser = struct
   open Lang
-  type tokens = T.t list with sexp
-  let _ = 
-    let str = T.stream (Sbuffer.from_string "(hello 24 world)") in
-    Format.eprintf "%a@." Sexplib.Sexp.pp_hum (sexp_of_tokens (T.Str.to_list str));
-    match expr str with
-    | Result.Error (pos, err) -> 
-        Format.eprintf "ERROR: %a : %s@." Position.Region.format pos  err
-    | Result.Ok (e, _) -> 
-        Format.eprintf "%a@." Lang.format e
-  ;;
+  module T = Token
+  
+  include Planck.Make(Lexer.Str)
+  
+  let lparen = token "( expected" T.LParen
+  let rparen = token ") expected" T.RParen
+  
+  let with_pos t = pos t >>= fun (desc, pos) -> 
+    return { desc = desc; pos = pos }
+  
+  let literal = filter_map "" (function 
+    | T.Int n -> Some (Int n)
+    | T.Char c -> Some (Char c)
+    | T.String s -> Some (String s)
+    | _ -> None)
+
+  let lident = filter_map "" (function
+    | T.LIdent s -> Some s
+    | _ -> None)
+
+  let ident = filter_map "" (function
+    | T.LIdent s -> Some (LIdent s)
+    | T.UIdent s -> Some (UIdent s)
+    | _ -> None)
+
+  let lambda_args = surrounded lparen rparen (star lident)
+
+  let rec parened : Lang.desc t = fun x -> begin
+    lparen >>= fun _ ->
+    (define_desc <|> lambda_desc <|> expr_desc) >>= fun desc ->
+    rparen >>= fun _ -> return desc
+  end x
+
+  and expr_desc : Lang.desc t = fun x -> begin
+    star expr >>= function
+      | [] -> return Unit
+      | l -> return (App l)
+  end x
+
+  and define_desc = fun x -> begin
+    token "" T.Define >>= fun _ ->
+    lident >>= fun id ->
+    expr >>= fun e -> 
+    return (Define (id, e))
+  end x
+
+  and lambda_desc = fun x -> begin
+    token "" T.Lambda >>= fun _ ->
+    lambda_args >>= fun ids ->
+    expr >>= fun e -> 
+    return (Lambda (ids, e))
+  end x
+
+  and expr = fun x -> begin
+    with_pos (literal <|> ident <|> parened)
+  end x
+
+  let gen : Str.t -> (Lang.t, Position.None.t) Planck.generator = 
+    stream_gen (expr >>= fun x -> return (Some x)) (fun _st1 _st2 -> ())
+
+  module StrLang = Pstream.Simple(struct type t = Lang.t end)(Position.None)
+
+  let stream_lang : Str.t -> StrLang.t = fun st -> StrLang.create (gen st)
+
+  module Test = struct
+  
+    open Token
+    open Lang
+    type tokens = Token.t list with sexp
+    let parse () = 
+      let str = Lexer.stream (Sbuffer.from_string 
+  "
+  (define fib (lambda (x)
+      (if (lt x 3) 
+         1 
+         (add (fib (sub x 1)) (fib (sub x 2))))))
+  "
+      ) in
+      Format.eprintf "%a@." Sexplib.Sexp.pp_hum (sexp_of_tokens (Lexer.Str.to_list str));
+      match expr str with
+      | Result.Error (pos, err) -> 
+          Format.eprintf "ERROR: %a : %s@." Position.Region.format pos  err
+      | Result.Ok (e, _) -> 
+          Format.eprintf "%a@." Lang.format e
+    ;;
+
+    let parses () = 
+      let str = Lexer.stream (Sbuffer.from_string 
+  "
+  (define fib (lambda (x)
+      (if (lt x 3) 
+         1 
+         (add (fib (sub x 1)) (fib (sub x 2))))))
+  42
+  (fib 1)
+  "
+      ) in
+      let stream = stream_lang str in
+      StrLang.iter (fun lang -> 
+        Format.eprintf "%a@." Lang.format lang) stream
+    ;;
+  end
 end
+
+module Compile = struct
+  open Lang
+
+  module L = Llvm
+
+  let context = L.global_context ()
+  let the_module = L.create_module context "my cool jit"
+  let builder = L.builder context
+  let named_values : (string, L.llvalue) Hashtbl.t = Hashtbl.create 17
+  let i32_type = L.i32_type context
+
+  let rec codegen_expr : Lang.t -> L.llvalue = fun t -> match t.desc with
+      | Int n -> L.const_int i32_type n
+      | _ -> assert false
+
+  let codegen_proto (name, args) : L.llvalue =
+    (* Make the function type: double(double,double) etc. *)
+    let ints = Array.make (Array.length args) i32_type in
+    let f_type = L.function_type i32_type ints in (* int -> ... -> int *)
+    let f =
+      match L.lookup_function name the_module with
+      | None -> L.declare_function name f_type the_module
+	
+      (* If 'f' conflicted, there was already something named 'name'. If it
+       * has a body, don't allow redefinition or reextern. *)
+      | Some f ->
+          (* If 'f' already has a body, reject this. *)
+          if L.block_begin f <> L.At_end f then failwith "redefinition of function";
+	
+          (* If 'f' took a different type, reject. *)
+          if L.element_type (L.type_of f) <> f_type then
+            failwith "redefinition of function with different type";
+
+	  (* the function with the same name is declared but without body *)
+          f
+    in
+  
+    (* Set names for all arguments. *)
+    Array.iteri (fun i a ->
+      let n = args.(i) in
+      L.set_value_name n a;
+      Hashtbl.add named_values n a;
+    ) (L.params f);
+    f
+
+  let codegen_func (proto, body) : L.llvalue =
+    Hashtbl.clear named_values;
+    let the_function = codegen_proto proto in
+        
+    (* Create a new basic block to start insertion into. *)
+    let bb = L.append_block context "entry" the_function in
+    L.position_at_end bb builder;
+        
+    try
+      let ret_val = codegen_expr body in
+        
+      (* Finish off the function. *)
+      let _ = L.build_ret ret_val builder in
+        
+      (* Validate the generated code, checking for consistency. *)
+      Llvm_analysis.assert_valid_function the_function;
+        
+      the_function
+    with e ->
+      L.delete_function the_function;
+      raise e
+
+  let iter (str_lang : Parser.StrLang.t) = 
+    Parser.StrLang.iter (fun lang -> 
+      (* Evaluate a top-level expression into an anonymous function. *)
+      let e = ("" (* "" means anonymous *), [||]), lang in
+      L.dump_value (codegen_func e);
+    ) str_lang;
+    (* Print out all the generated code. *)
+    L.dump_module the_module
+
+  module Test = struct
+    let test () = 
+      let str = Lexer.stream (Sbuffer.from_string "42 24") in
+      let stream = Parser.stream_lang str in
+      iter stream
+  end
+end
-module P : sig
-  include Planck.S with type Str.elem = Plang.Token.t
-	           and  type Str.t = Plang.Token.Str.t
-		   and  type pos = Position.Region.t
+module Token : sig
+  type t =
+    | Int of int
+    | Char of char
+    | String of string
+    | LIdent of string
+    | UIdent of string
+    | LParen
+    | RParen
+    | Define
+    | Lambda
+  with sexp
 end
 
 module Lang : sig
     | UIdent of string
     | Unit
     | App of t list
+    | Define of string * t
+    | Lambda of string list * t
 
   and t = { desc : desc; pos : Position.Region.t }
 end
 
-val expr : Lang.t P.t
+module Lexer : sig
+  val lex : Token.t option Plang.t
+
+  module Str : Pstream.S 
+    with type pos = Position.Region.t
+    and type elem = Token.t
+  val stream : Sbuffer.t -> Str.t
+  module Test : sig
+    val lex : unit -> unit
+  end
+end
+
+module Parser : sig
+  include Planck.S with type Str.elem = Token.t
+	           and  type Str.t = Lexer.Str.t
+  val expr : Lang.t t
+  module Test : sig
+    val parse : unit -> unit
+    val parses : unit -> unit
+  end
+end
+
+module Compile : sig
+  module Test : sig
+    val test : unit -> unit
+  end
+end
   val peek : t -> elem option
   val is_empty : t -> bool
   val to_list : t -> elem list
+  val iter : (elem -> unit) -> t -> unit
 end
 
 module Make(S0 : S0) = struct
       | Some (elem, t) -> to_list (elem :: st) t
     in
     to_list [] t
+  let rec iter f t = match take t with
+    | None -> ()
+    | Some (elem, t) -> f elem; iter f t
 end
 
 type ('a, 'pos) generator = unit -> 'pos * [ `None | `Some of 'a * ('a, 'pos) generator ]
   val peek : t -> elem option
   val is_empty : t -> bool
   val to_list : t -> elem list
+  val iter : (elem -> unit) -> t -> unit
 end
 
 module Make(S0 : S0) : S 
 	    | '\n' -> Pos.add_newlines t.abs_pos 1
 	    | _ -> Pos.add_columns t.abs_pos 1
 	  in 
-	  Some (char, { t with rel_pos = t.rel_pos + 1; abs_pos}))
+	  Some (char, { t with rel_pos = t.rel_pos + 1; abs_pos = abs_pos}))
 
   type gen = Simple_string.gen
   let create gen = { buf = Simple_string.create gen;
 let test () = 
-  Plang.Test.literal_ident ();
-  Plang.Test.lex ()
+  Plex.Test.literal_ident ();
+  Pscheme.Lexer.Test.lex ();
+  Pscheme.Parser.Test.parse ();
+  Pscheme.Parser.Test.parses ();
+  Pscheme.Compile.Test.test ()
 
 let _ = test ()
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.