diff --git a/Makefile.common b/Makefile.common deleted file mode 100644 index 9789b735..00000000 --- a/Makefile.common +++ /dev/null @@ -1,151 +0,0 @@ -#### Definitions common to all platforms - -### Installation paths - -PREFIX ?= /usr/local -BINDIR ?= ${PREFIX}/bin -LIBDIR ?= ${PREFIX}/lib - -### Program names and paths - -EXTLIB = -I ../extlib-dev -I +extLib -I +site-lib/extlib -INSTALL = install -OCAMLEX = ocamllex -OCAMLOPT = ocamlopt - -### Generated files - -COMPILER_OBJECTS = ast.cmx lexer.cmx parser.cmx printer.cmx bytecode.cmx \ - compile.cmx plugin.cmx main.cmx -COMPILER_TARGETS = bin/neko -LIBS_TARGETS = bin/regexp.ndll bin/mod_neko.ndll bin/mysql.ndll -LIBNEKO_OBJECTS = alloc.o builtins.o callback.o context.o interp.o \ - load.o objtable.o others.o -TEST_TARGETS = bin/test.n -MTYPES_TARGET = bin/cgi.n bin/mysql.n bin/regexp.n bin/std.n -VM_OBJECTS = ${LIBNEKO_OBJECTS} main.o -VM_TARGETS = bin/nekovm bin/libneko.so -TARGETS = bin/std.ndll ${COMPILER_TARGETS} ${LIBS_TARGETS} ${VM_TARGETS} \ - ${TEST_TARGETS} ${MTYPES_TARGETS} - -### Main Targets - -all : extlib compiler vm libs - -mt : extlib compiler vm libs morelibs mtypes - -compiler : bin/neko - -clean : - (cd neko && rm -rf ${COMPILER_OBJECTS} *.o *.obj *.cm* neko) - (cd vm && rm -rf ${VM_OBJECTS} libneko.so) - rm -rf libs/*/*.o - -distclean : clean - rm -rf extlib-dev ${TARGETS} - -extlib : extlib-dev/extLib.cmxa - -install : all - [ -d "${LIBDIR}" ] || mkdir -p "${LIBDIR}" - ${INSTALL} -m 555 bin/libneko.so "${LIBDIR}/" - [ -d "${BINDIR}" ] || mkdir -p "${BINDIR}" - ${INSTALL} -m 555 bin/neko bin/nekovm "${BINDIR}/" - -libs : bin/test.n bin/std.ndll - -morelibs : ${LIBS_TARGETS} - -mtypes : ${MTYPES_TARGETS} - -test : all - LD_LIBRARY_PATH=bin bin/nekovm bin/test - -vm : bin/nekovm - -### Subtargets - -bin/test.n : compiler - bin/neko libs/test.neko - mv libs/test.n bin - -bin/cgi.n : compiler - bin/neko libs/mtypes/cgi.neko - mv libs/mtypes/cgi.n bin - -bin/mysql.n : compiler - bin/neko libs/mtypes/mysql.neko - mv libs/mtypes/mysql.n bin - -bin/std.n : compiler - bin/neko libs/mtypes/std.neko - mv libs/mtypes/std.n bin - -bin/regexp.n : compiler - bin/neko libs/mtypes/regexp.neko - mv libs/mtypes/regexp.n bin - -bin/libneko.so : - (cd vm && \ - ${MAKE} -f ../Makefile libneko.so && \ - cp -p libneko.so ../bin/) - -bin/neko : neko/neko - cp -p neko/neko bin/neko - -bin/nekovm : vm/main.o bin/libneko.so - ${CC} vm/main.o -o bin/nekovm ${LDFLAGS} -Lbin ${LIBNEKO} - -bin/regexp.ndll : libs/regexp/*.c - (cd libs/regexp && \ - ${CC} ${CFLAGS} -I../../vm -c *.c && \ - ${MAKESO} *.o ${LIBPCRE} -o ../../bin/regexp.ndll) - -bin/std.ndll : libs/std/*.c - (cd libs/std && \ - ${CC} ${CFLAGS} -I../../vm -c *.c && \ - ${MAKESO} *.o -o ../../bin/std.ndll) - -bin/mod_neko.ndll : libs/mod_neko/*.c - (cd libs/mod_neko && \ - ${CC} ${CFLAGS} -I../../vm ${APACHE_CFLAGS} -c *.c && \ - ${MAKESO} *.o -L../../bin ${LIBNEKO} -o ../../bin/mod_neko.ndll) - -bin/mysql.ndll : libs/mysql/*.c - (cd libs/mysql && \ - ${CC} ${CFLAGS} ${MYSQL_CFLAGS} -I../../vm -c *.c && \ - ${MAKESO} *.o ${LIBMYSQL} -o ../../bin/mysql.ndll) - -extlib-dev : - cvs -z3 -d:pserver:anonymous@cvs.sourceforge.net:/cvsroot/ocaml-lib co extlib-dev - -extlib-dev/extLib.cmxa : extlib-dev - (cd extlib-dev; ocaml install.ml -d "" -n -nodoc; touch extLib.cmxa) - -libneko.so : ${LIBNEKO_OBJECTS} - ${MAKESO} ${LIBNEKO_OBJECTS} -o libneko.so ${LDFLAGS} \ - ${LIBM} ${LIBDL} ${LIBGC} - -neko : ${COMPILER_OBJECTS} - ${OCAMLOPT} -o neko ${EXTLIB} extLib.cmxa ${COMPILER_OBJECTS} - -neko/neko : - (cd neko && ${MAKE} -f ../Makefile neko) - -vm/main.o : vm/main.c - (cd vm && ${CC} -c main.c) - -### Some magic - -.SUFFIXES : .c .cmx .ml .mll .o - -.c.o : - ${CC} ${CFLAGS} -c $< - -.mll.ml : - ${OCAMLEX} $< - -.ml.cmx : - ${OCAMLOPT} -pp camlp4o ${EXTLIB} -c $< - -.PHONY : all clean compiler distclean extlib libs test vm morelibs mt mtypes diff --git a/Makefile.linux b/Makefile.linux deleted file mode 100644 index a327783c..00000000 --- a/Makefile.linux +++ /dev/null @@ -1,18 +0,0 @@ -#### Specific definitions for linux - -APACHE_CFLAGS = -I/usr/local/apache/include -MYSQL_CFLAGS = -I/usr/local/include/mysql - -CFLAGS = -O3 -fomit-frame-pointer -fno-defer-pop -I/usr/local/include -fPIC -LDFLAGS = -L/usr/local/lib -LIBDL = -ldl -LIBGC = -lgc -LIBM = -lm -LIBZ = -lz -LIBNEKO = -lneko -LIBPCRE = -lpcre -MAKESO = gcc -shared -WBsymbolic -fPIC - -LIBMYSQL_STATIC = /usr/local/lib/mysql/libmysqlclient.a -LIBMYSQL_DYNAMIC = -lmysql -LIBMYSQL = ${LIBZ} ${LIBMYSQL_STATIC} diff --git a/cgi.neko b/cgi.neko deleted file mode 100644 index 1adbce66..00000000 --- a/cgi.neko +++ /dev/null @@ -1,126 +0,0 @@ -std = $loader.loadmodule("mtypes/std",$loader); -String = std.String; -Hash = std.Hash; - -get_env = $loader.loadprim("std@get_env",1); - -if( get_env("MOD_NEKO") != null ) { - - set_main = $loader.loadprim("mod_neko@cgi_set_main",1); - get_host_name = $loader.loadprim("mod_neko@get_host_name",0); - get_client_ip = $loader.loadprim("mod_neko@get_client_ip",0); - get_content_type = $loader.loadprim("mod_neko@get_content_type",0); - set_content_type = $loader.loadprim("mod_neko@set_content_type",1); - get_uri = $loader.loadprim("mod_neko@get_uri",0); - redirect = $loader.loadprim("mod_neko@redirect",1); - set_header = $loader.loadprim("mod_neko@set_header",2); - get_client_header = $loader.loadprim("mod_neko@get_client_header",1); - get_params_string = $loader.loadprim("mod_neko@get_params_string",0); - get_post_data = $loader.loadprim("mod_neko@get_post_data",0); - get_params = $loader.loadprim("mod_neko@get_params",0); - get_cookies = $loader.loadprim("mod_neko@get_cookies",0); - set_cookie = $loader.loadprim("mod_neko@set_cookie",2); - url_encode = $loader.loadprim("mod_neko@url_encode",1); - url_decode = $loader.loadprim("mod_neko@url_decode",1); - get_cwd = $loader.loadprim("mod_neko@cgi_get_cwd",0); - - // change local dir - set_cwd = $loader.loadprim("std@set_cwd",1); - set_cwd(get_cwd()); - -} else { - - var content_type = $array("text/html"); - - get_host_name = function() { return "localhost" }; - get_client_ip = function() { return "127.0.0.1" }; - get_content_type = function() { return content_type[0] }; - set_content_type = function(v) { content_type[0] = v }; - - $throw("module Cgi without Mod_neko loaded is not supported"); - -} - -Cgi = $new(null); - -Cgi.getCwd = get_cwd; - -Cgi.setMain = set_main; - -Cgi.getHostName = function() { - return String.new(get_host_name()); -} - -Cgi.getClientIP = function() { - return String.new(get_client_ip()); -} - -Cgi.getContentType = function() { - return String.new(get_content_type()); -} - -Cgi.setContentType = function(s) { - set_content_type(s.@s); -} - -Cgi.getURI = function() { - return String.new(get_uri()); -} - -Cgi.redirect = function(s) { - redirect(s.@s); -} - -Cgi.header = function(k,v) { - set_header(k.@s,v.@s) -} - -Cgi.getClientHeader = function(s) { - return String.new(get_client_header(s.@s)); -} - -Cgi.getParamsString = function() { - return String.new(get_params_string()); -} - -Cgi.getPostData = function() { - return String.new(get_post_data()); -} - -Cgi.getParams = function() { - var h = Hash.new(); - var o = $new(null); - var p = get_params(); - while( p != null ) { - o.@s = p[0]; - h.set(o,String.new(p[1])); - p = p[2]; - } - return h; -} - -Cgi.getCookies = function() { - var h = Hash.new(); - var o = $new(null); - var p = get_cookies(); - while( p != null ) { - o.@s = p[0]; - h.set(o,String.new(p[1])); - p = p[2]; - } - return h; -} - -Cgi.setCookie = function(k,v) { - set_cookie(k.@s,v.@s); -} - -Cgi.urlEncode = function(s) { - return String.new(url_encode(s.@s)); -} - -Cgi.urlDecode = function(s) { - return String.new(url_decode(s.@s)); -} - -$exports.Cgi = Cgi; diff --git a/configure b/configure deleted file mode 100644 index 6e9ecee1..00000000 --- a/configure +++ /dev/null @@ -1,62 +0,0 @@ -#! /bin/sh - -#### Detect platform and write Makefile based on that - -## Defaults -BSD='#' -GNU= -FREEBSD='#' -NETBSD='#' -OPENBSD='#' - -printf "Detecting platform..." - -[ -z "$PLATFORM" ] && PLATFORM="`uname -s`" - -case "$PLATFORM" in -Linux) - echo $PLATFORM - ;; -FreeBSD) - echo $PLATFORM - BSD= - GNU='#' - FREEBSD= - ;; -NetBSD) - echo $PLATFORM - BSD= - GNU='#' - NETBSD= - ;; -OpenBSD) - echo $PLATFORM - BSD= - GNU='#' - OPENBSD= - ;; -*) - echo 'unsupported platform' - echo 'You will probably have to edit the Makefile' - exit 1 - ;; -esac - -printf "Writing Makefile..." - -cat < Makefile -## Uncomment the following lines when building on Linux -${GNU}BUILDROOT ?= \${PWD} -${GNU}export BUILDROOT -${GNU}include \${BUILDROOT}/mk/Makefile.linux -${GNU}include \${BUILDROOT}/mk/Makefile.common - -## Uncomment the line for your BSD flavor and the line for Makefile.common -## when building on *BSD -${FREEBSD}.include "mk/Makefile.freebsd" -${NETBSD}.include "mk/Makefile.netbsd" -${OPENBSD}.include "mk/Makefile.openbsd" -${BSD}.include "mk/Makefile.common" -EOT - -echo done diff --git a/libs/include/ocaml/ml/mlast.ml b/libs/include/ocaml/ml/mlast.ml deleted file mode 100644 index 803e6e21..00000000 --- a/libs/include/ocaml/ml/mlast.ml +++ /dev/null @@ -1,208 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -type pos = { - pmin : int; - pmax : int; - pfile : string; -} - -type constant = - | Int of int - | Char of char - | Bool of bool - | Float of string - | String of string - | Ident of string - | Constr of string - | Module of string list * constant - -type keyword = - | Var - | If - | Else - | Function - | Try - | Catch - | Type - | Match - | Then - | When - | While - | Exception - -type token = - | Eof - | Semicolon - | Dot - | Comma - | Quote - | BraceOpen - | BraceClose - | ParentOpen of bool - | ParentClose - | BracketOpen - | BracketClose - | Arrow - | Vertical - | StreamOpen - | StreamClose - | Const of constant - | Keyword of keyword - | Binop of string - | Comment of string - | CommentLine of string - -type type_path = - | EType of type_path option * string list * string - | EPoly of string - | ETuple of type_path list - | EArrow of type_path * type_path - -type type_decl = - | EAbstract - | EAlias of type_path - | ERecord of (string * bool * type_path) list - | EUnion of (string * type_path option) list - -type arg = - | ATyped of arg * type_path - | ANamed of string - | ATuple of arg list - -type pattern_decl = - | PIdent of string - | PConst of constant - | PTuple of pattern list - | PRecord of (string * pattern) list - | PConstr of string list * string * pattern option - | PAlias of string * pattern - | PTyped of pattern * type_path - | PStream of stream_item list * int - -and pattern = pattern_decl * pos - -and stream_item = - | SPattern of pattern - | SExpr of string list * expr - | SMagicExpr of pattern * int - -and expr_decl = - | EConst of constant - | EBlock of expr list - | EField of expr * string - | ECall of expr * expr list - | EArray of expr * expr - | EVar of (string * type_path option) list * expr - | EIf of expr * expr * expr option - | EFunction of bool * string option * arg list * expr * type_path option - | EBinop of string * expr * expr - | EUnop of string * expr - | ETypeAnnot of expr * type_path - | ETupleDecl of expr list - | ETypeDecl of string list * string * type_decl - | EErrorDecl of string * type_path option - | ERecordDecl of (string * expr) list - | EMatch of expr * (pattern list * expr option * expr) list - | ETry of expr * (pattern list * expr option * expr) list - | ETupleGet of expr * int - | EApply of expr * expr list - | EWhile of expr * expr - -and expr = expr_decl * pos - -let pos = snd - -let null_pos = { pmin = -1; pmax = -1; pfile = "" } - -let punion p p2 = - { - pfile = p.pfile; - pmin = min p.pmin p2.pmin; - pmax = max p.pmax p2.pmax; - } - -let escape_char = function - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\\' -> "\\\\" - | c -> - if c >= '\032' && c <= '\126' then - String.make 1 c - else - Printf.sprintf "\\%.3d" (int_of_char c) - -let escape s = - let b = Buffer.create (String.length s) in - for i = 0 to (String.length s) - 1 do - Buffer.add_string b (escape_char s.[i]) - done; - Buffer.contents b - -let rec s_constant = function - | Int i -> string_of_int i - | Float s -> s - | Bool b -> if b then "true" else "false" - | Char c -> "'" ^ escape_char c ^ "\"" - | String s -> "\"" ^ escape s ^ "\"" - | Ident s -> s - | Constr s -> s - | Module (l,c) -> String.concat "." l ^ "." ^ s_constant c - -let s_path path n = - match path with - | [] -> n - | _ -> String.concat "." path ^ "." ^ n - -let s_keyword = function - | Var -> "var" - | If -> "if" - | Else -> "else" - | Function -> "function" - | Try -> "try" - | Catch -> "catch" - | Type -> "type" - | Match -> "match" - | Then -> "then" - | When -> "when" - | While -> "while" - | Exception -> "exception" - -let s_token = function - | Eof -> "" - | Semicolon -> ";" - | Dot -> "." - | Comma -> "," - | Quote -> "'" - | BraceOpen -> "{" - | BraceClose -> "}" - | ParentOpen _ -> "(" - | ParentClose -> ")" - | BracketOpen -> "[" - | BracketClose -> "]" - | StreamOpen -> "[<" - | StreamClose -> ">]" - | Arrow -> "->" - | Vertical -> "|" - | Const c -> s_constant c - | Keyword k -> s_keyword k - | Binop s -> s - | Comment s -> "/*" ^ s ^ "*/" - | CommentLine s -> "//" ^ s diff --git a/libs/include/ocaml/ml/mllexer.mll b/libs/include/ocaml/ml/mllexer.mll deleted file mode 100644 index d77118a7..00000000 --- a/libs/include/ocaml/ml/mllexer.mll +++ /dev/null @@ -1,209 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) -{ -open Mlast -open Lexing - -type error_msg = - | Invalid_character of char - | Unterminated_string - | Unclosed_comment - | Invalid_escaped_character of int - | Invalid_escape - -exception Error of error_msg * pos - -let error_msg = function - | Invalid_character c when int_of_char c > 32 && int_of_char c < 128 -> Printf.sprintf "Invalid character '%c'" c - | Invalid_character c -> Printf.sprintf "Invalid character 0x%.2X" (int_of_char c) - | Unterminated_string -> "Unterminated string" - | Unclosed_comment -> "Unclosed comment" - | Invalid_escaped_character n -> Printf.sprintf "Invalid escaped character %d" n - | Invalid_escape -> "Invalid escape sequence" - -let cur_file = ref "" -let all_lines = Hashtbl.create 0 -let lines = ref [] -let buf = Buffer.create 100 - -let error e pos = - raise (Error (e,{ pmin = pos; pmax = pos; pfile = !cur_file })) - -let keywords = - let h = Hashtbl.create 3 in - List.iter (fun k -> Hashtbl.add h (s_keyword k) k) - [Var;If;Else;Function;Try;Catch;Type;Match;Then;When;While;Exception] - ; h - -let init file = - cur_file := file; - lines := [] - -let save_lines() = - Hashtbl.replace all_lines !cur_file !lines - -let save() = - save_lines(); - !cur_file - -let restore file = - save_lines(); - cur_file := file; - lines := Hashtbl.find all_lines file - -let newline lexbuf = - lines := (lexeme_end lexbuf) :: !lines - -let find_line p lines = - let rec loop n delta = function - | [] -> n , p - delta - | lp :: l when lp > p -> n , p - delta - | lp :: l -> loop (n+1) lp l - in - loop 1 0 lines - -let get_error_line p = - let lines = List.rev (try Hashtbl.find all_lines p.pfile with Not_found -> []) in - let l, _ = find_line p.pmin lines in - l - -let get_error_pos printer p = - if p.pmin = -1 then - "(unknown)" - else - let lines = List.rev (try Hashtbl.find all_lines p.pfile with Not_found -> []) in - let l1, p1 = find_line p.pmin lines in - let l2, p2 = find_line p.pmax lines in - if l1 = l2 then begin - let s = (if p1 = p2 then Printf.sprintf " %d" p1 else Printf.sprintf "s %d-%d" p1 p2) in - Printf.sprintf "%s character%s" (printer p.pfile l1) s - end else - Printf.sprintf "%s lines %d-%d" (printer p.pfile l1) l1 l2 - -let reset() = Buffer.reset buf -let contents() = Buffer.contents buf -let store lexbuf = Buffer.add_string buf (lexeme lexbuf) -let add c = Buffer.add_string buf c - -let mk_tok t pmin pmax = - t , { pfile = !cur_file; pmin = pmin; pmax = pmax } - -let mk lexbuf t = - mk_tok t (lexeme_start lexbuf) (lexeme_end lexbuf) - -let mk_ident lexbuf = - let s = lexeme lexbuf in - mk lexbuf (try Keyword (Hashtbl.find keywords s) with Not_found -> Const (Ident s)) - -} - -let ident = ['a'-'z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* -let modident = ['A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* -let binop = ['!' '=' '*' '/' '<' '>' '&' '|' '^' '%' '+' ':' '-'] -let number = ['0'-'9'] -let space = [' ' '\r' '\t'] - -rule token = parse - | eof { mk lexbuf Eof } - | ';' { mk lexbuf Semicolon } - | '.' { mk lexbuf Dot } - | ',' { mk lexbuf Comma } - | '{' { mk lexbuf BraceOpen } - | '}' { mk lexbuf BraceClose } - | space+ '(' { mk lexbuf (ParentOpen true) } - | '(' { mk lexbuf (ParentOpen false) } - | ')' { mk lexbuf ParentClose } - | '[' { mk lexbuf BracketOpen } - | ']' { mk lexbuf BracketClose } - | '\'' { mk lexbuf Quote } - | '|' { mk lexbuf Vertical } - | space+ { token lexbuf } - | '\n' { newline lexbuf; token lexbuf } - | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ - | number+ { mk lexbuf (Const (Int (int_of_string (lexeme lexbuf)))) } - | number+ '.' number* - | '.' number+ { mk lexbuf (Const (Float (lexeme lexbuf))) } - | "true" { mk lexbuf (Const (Bool true)) } - | "false" { mk lexbuf (Const (Bool false)) } - | '"' { - reset(); - let pmin = lexeme_start lexbuf in - let pmax = (try string lexbuf with Exit -> error Unterminated_string pmin) in - mk_tok (Const (String (contents()))) pmin pmax; - } - | "/*" { - reset(); - let pmin = lexeme_start lexbuf in - let pmax = (try comment lexbuf with Exit -> error Unclosed_comment pmin) in - mk_tok (Comment (contents())) pmin pmax; - } - | "'\\n'" { mk lexbuf (Const (Char '\n')) } - | "'\\t'" { mk lexbuf (Const (Char '\t')) } - | "'\\r'" { mk lexbuf (Const (Char '\r')) } - | "'\\''" { mk lexbuf (Const (Char '\'')) } - | "'\\\\'" { mk lexbuf (Const (Char '\\')) } - | "'\\\"'" | "'\\t'" { mk lexbuf (Const (Char '"')) } - | '\'' [^'\\'] '\'' { mk lexbuf (Const (Char (lexeme lexbuf).[1])) } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] '\'' { - let s = String.sub (lexeme lexbuf) 2 3 in - let n = int_of_string s in - let c = (try char_of_int n with _ -> error (Invalid_escaped_character n) (lexeme_start lexbuf)) in - mk lexbuf (Const (Char c)) - } - | "//" [^'\n']* { - let s = lexeme lexbuf in - let n = (if s.[String.length s - 1] = '\r' then 3 else 2) in - mk lexbuf (CommentLine (String.sub s 2 ((String.length s)-n))) - } - | "[<" { mk lexbuf StreamOpen } - | ">]" { mk lexbuf StreamClose } - | "->" { mk lexbuf Arrow } - | binop binop? | ">>>" | "===" | "!==" | "or" | "and" | "xor" { mk lexbuf (Binop (lexeme lexbuf)) } - | ident { mk_ident lexbuf } - | modident { mk lexbuf (Const (Constr (lexeme lexbuf))) } - | _ { - error (Invalid_character (lexeme_char lexbuf 0)) (lexeme_start lexbuf) - } - -and comment = parse - | eof { raise Exit } - | '\r' { comment lexbuf } - | '\n' { newline lexbuf; store lexbuf; comment lexbuf } - | "*/" { lexeme_end lexbuf } - | '*' { store lexbuf; comment lexbuf } - | [^'*' '\n' '\r']+ { store lexbuf; comment lexbuf } - -and string = parse - | eof { raise Exit } - | '\n' { newline lexbuf; store lexbuf; string lexbuf } - | "\\\"" { add "\""; string lexbuf } - | "\\\\" { add "\\"; string lexbuf } - | "\\n" { add "\n"; string lexbuf } - | "\\t" { add "\t"; string lexbuf } - | "\\r" { add "\r"; string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { - let i = int_of_string (String.sub (lexeme lexbuf) 1 3) in - if i >= 256 then error (Invalid_escaped_character i) (lexeme_start lexbuf); - add (String.make 1 (char_of_int i)); - string lexbuf - } - | '\\' { error Invalid_escape (lexeme_start lexbuf) } - | '"' { lexeme_end lexbuf } - | [^'"' '\\' '\n']+ { store lexbuf; string lexbuf } - \ No newline at end of file diff --git a/libs/include/ocaml/ml/mlmain.ml b/libs/include/ocaml/ml/mlmain.ml deleted file mode 100644 index 1ac1e8c9..00000000 --- a/libs/include/ocaml/ml/mlmain.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -let nekoml file ch out = - IO.close_in ch; - Mltyper.verbose := !Plugin.verbose; - Mlneko.verbose := !Plugin.verbose; - let path = ExtString.String.nsplit (Filename.dirname file) "/" in - let modname = path @ [String.capitalize (Filename.chop_extension (Filename.basename file))] in - let ctx = Mltyper.context (!Plugin.paths) in - ignore(Mltyper.load_module ctx modname Mlast.null_pos); - Hashtbl.iter (fun m (e,deps,idents) -> - let e = Mlneko.generate e deps idents m in - let file = String.concat "/" m ^ ".neko" in - let ch = (if m = modname then out else IO.output_channel (open_out file)) in - let ctx = Printer.create ch in - Printer.print ctx e; - IO.close_out ch - ) (Mltyper.modules ctx) - -let nekoml_exn = function - | Mllexer.Error (m,p) -> Plugin.exn_infos "syntax error" (Mllexer.error_msg m) (fun f -> Mllexer.get_error_pos f p) - | Mlparser.Error (m,p) -> Plugin.exn_infos "parse error" (Mlparser.error_msg m) (fun f -> Mllexer.get_error_pos f p) - | Mltyper.Error (m,p) -> Plugin.exn_infos "type error" (Mltyper.error_msg m) (fun f -> Mllexer.get_error_pos f p) - | Lexer.Error (m,p) -> Plugin.exn_infos "syntax error" (Lexer.error_msg m) (fun f -> Lexer.get_error_pos f p) - | Parser.Error (m,p) -> Plugin.exn_infos "parse error" (Parser.error_msg m) (fun f -> Lexer.get_error_pos f p) - | e -> raise e - -;; -Plugin.register "nml" "neko" nekoml nekoml_exn diff --git a/libs/include/ocaml/ml/mlmatch.ml b/libs/include/ocaml/ml/mlmatch.ml deleted file mode 100644 index 2d20f87c..00000000 --- a/libs/include/ocaml/ml/mlmatch.ml +++ /dev/null @@ -1,287 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -(* ----- - We're using the same algorithm and source code as described in - chapter 5.2.4 of "The Zinc experiment" by X. Leroy - ( http://citeseer.ist.psu.edu/leroy90zinc.html ) - also described in "The Implementation of Functional Programming Languages" - by Simon Peyton Jones, in the Chapter 5 by Philip Wadler - ( http://research.microsoft.com/Users/simonpj/Papers/slpj-book-1987/ ) -*) - -open Mlast -open Mltype - -type complete = - | Total - | Partial - | Dubious - -type lambda = match_op - -type matching = (pattern list * lambda) list * lambda list - -let fully_matched_ref = ref (fun cl -> false) -let error_ref = ref (fun (msg : string) (p : pos) -> assert false; ()) - -let error msg p = - !error_ref msg p; - assert false - -let failure = MFailure -let handle l1 l2 = if l2 = MFailure then l1 else if l1 = MFailure then l2 else MHandle (l1,l2) -let exec e = MExecute (e,true) -let cond path lambdas = MConstants (path,lambdas) -let rec switch path lambdas = - match lambdas with - | [TVoid,m1] -> m1 - | (TVoid,m1) :: l -> MNext (m1, switch path l) - | _ -> MSwitch (path,lambdas) - -let ewhen e e2 = MWhen (e,e2) - -let rec bind v p = function - | MBind (v2,p2,m) -> MBind (v2,p2,bind v p m) - | act -> if v = "_" then act else MBind (v,p,act) - -let rec junk p k = function - | MBind (v,m,m2) -> MBind (v,m,junk p k m2) - | act -> if k = 0 then act else MJunk (p,k,act) - -let rec stream_pattern (p,pos) = - (match p with - | PIdent i -> PConst (Ident i) - | PConst c -> PConst c - | PTuple pl -> PTuple (List.map stream_pattern pl) - | PRecord pr -> PRecord (List.map (fun (s,p) -> s , stream_pattern p) pr) - | PConstr (path,name,param) -> PConstr (path,name,match param with None -> None | Some p -> Some (stream_pattern p)) - | PAlias (s,p) -> PAlias (s,stream_pattern p) - | PTyped (p,t) -> PTyped (stream_pattern p,t) - | PStream (s,k) -> PStream (s,k)) , pos - -let rec have_when = function - | MWhen _ -> true - | MBind (_,_,e) -> have_when e - | _ -> false - -let t_const = function - | Int i -> TInt i - | String s -> TString s - | Float f -> TFloat f - | Char c -> TChar c - | Ident i -> TIdent i - | Bool b -> TBool b - | _ -> assert false - -let total p1 p2 = - match p1 , p2 with - | Total , Total -> Total - | Partial , _ -> Partial - | _ , Partial -> Partial - | _ , _ -> Dubious - -let partial p1 p2 = - match p1 , p2 with - | Total , _ -> p2 - | _ , Total -> Total - | _ , _ -> Dubious - -let rec start_by_a_variable (p,_) = - match p with - | PAlias (_,p) -> start_by_a_variable p - | PIdent _ -> true - | _ -> false - -let add_to_match (casel,pathl) cas = - cas :: casel , pathl - -let make_constant_match path cas = - match path with - | [] -> assert false - | _ :: pathl -> [cas] , pathl - -let make_token_match path cas = - [cas] , path - -let make_construct_match tuple nargs pathl cas = - match pathl with - | [] -> assert false - | path :: pathl -> - let rec make_path i = - if i >= nargs then - pathl - else - let k = if tuple then MTuple (path,i) else MField (path,i) in - k :: make_path (i + 1) - in - [cas] , make_path 0 - -let make_record_match args pathl cas = - match pathl with - | [] -> assert false - | path :: pathl -> - [cas] , List.fold_left (fun acc (f,_) -> MRecordField (path,f) :: acc) pathl (List.rev args) - -let add_to_division make_match divlist key cas = - try - let matchref = List.assoc key divlist in - matchref := add_to_match !matchref cas; - divlist - with Not_found -> - (key , ref (make_match cas)) :: divlist - -let always_add make_match divlist cas = - (TVoid , ref (make_match cas)) :: divlist - -let lines_of_matching = fst - -let fully_matched cl = - !fully_matched_ref cl - -let flatten = function - | None -> [] - | Some (PTuple l,_) -> l - | Some p -> [p] - -let split_matching (m:matching) = - match m with - | _ , [] -> - assert false - | casel, (curpath :: endpathl as pathl) -> - let rec split_rec = function - | ((PTyped (p,_),_) :: l , act) :: rest -> - split_rec ((p :: l, act) :: rest) - | ((PAlias (var,p),_) :: l , act) :: rest -> - split_rec ((p :: l, bind var curpath act) :: rest) - | ((PIdent var,_) :: l , act) :: rest -> - let vars , others = split_rec rest in - add_to_match vars (l, bind var curpath act) , others - | casel -> - ([] , endpathl) , (casel , pathl) - in - split_rec casel - -let divide_matching (m:matching) = - match m with - | _ , [] -> - assert false - | casel , (curpath :: tailpathl as pathl) -> - let rec divide_rec = function - | [] -> - [] , [] , ([] , pathl) - | ([],_) :: _ -> - assert false - | ((PTyped (p,_),_) :: l , act) :: rest -> - divide_rec ((p :: l , act) :: rest) - | ((PAlias (var,p),_) :: l, act) :: rest -> - divide_rec ((p :: l , bind var curpath act) :: rest) - | ((PConst c,_) :: l, act) :: rest -> - let constant , constrs, others = divide_rec rest in - add_to_division (make_constant_match pathl) constant (t_const c) (l, act), constrs , others - | ((PConstr (path,c,arg),_) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - let args = flatten arg in - constants , add_to_division (make_construct_match false (List.length args) pathl) constrs (TModule (path,TConstr c)) (args @ l,act) , others - | ((PTuple [],_) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , add_to_division (make_constant_match pathl) constrs TVoid (l, act), others - | ((PTuple args,_) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , add_to_division (make_construct_match true (List.length args) pathl) constrs TVoid (args @ l,act) , others - | ((PRecord args,_) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , add_to_division (make_record_match args pathl) constrs TVoid (List.map snd args @ l,act) , others - | ((PStream ((SPattern p :: sl),k),pp) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , always_add (make_token_match ((MToken (curpath,k)) :: pathl)) constrs (stream_pattern p :: (PStream (sl,k+1),pp) :: l, act) , others - | ((PStream ((SMagicExpr ((PTuple _,_) as p,e) :: sl),k),pp) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - let bind = MExecute (mk (TConst (TIdent "@tmp")) t_void pp,false) in - constants , always_add (make_token_match (junk curpath k (MExecute (Obj.magic e,false)) :: bind :: pathl)) constrs ((PConst (Ident "@tmp"),pp) :: stream_pattern p :: (PStream (sl,0),pp) :: l, act) , others - | ((PStream ((SMagicExpr (p,e) :: sl),k),pp) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , always_add (make_token_match (junk curpath k (MExecute (Obj.magic e,false)) :: pathl)) constrs (stream_pattern p :: (PStream (sl,0),pp) :: l, act) , others - | ((PStream ([],k),pp) :: l,act) :: rest -> - let constants , constrs, others = divide_rec rest in - constants , always_add (make_constant_match pathl) constrs (l, junk curpath k act) , others - | casel -> - [] , [] , (casel,pathl) - in - divide_rec casel - -let rec conquer_divided_matching = function - | [] -> - [], Total, [] - | (key, matchref) :: rest -> - let l1, p1, u1 = conquer_matching !matchref in - let l2, p2, u2 = conquer_divided_matching rest in - (key , l1) :: l2 , total p1 p2 , u1 @ u2 - -and conquer_matching (m:matching) = - match m with - | [] , _ -> - failure , Partial , [] - | ([],action) :: rest , k -> - if have_when action then - let a , p , r = conquer_matching (rest,k) in - handle action a , p , r - else - action , Total, rest - | _ , [] -> - assert false - | (p :: _,_) :: _ , _ :: _ when start_by_a_variable p -> - let vars , rest = split_matching m in - let l1, p1, u1 = conquer_matching vars in - let l2, p2, u2 = conquer_matching rest in - if p1 = Total then - l1 , Total, u1 @ lines_of_matching rest - else - handle l1 l2 , (if p2 = Total then Total else Dubious) , u1 @ u2 - | _ , path :: _ -> - match divide_matching m with - | [] , [] , vars -> - conquer_matching vars - | consts , [] , vars -> - let l1, _ , u1 = conquer_divided_matching consts in - let l2, p2, u2 = conquer_matching vars in - handle (cond path l1) l2 , p2 , u1 @ u2 - | [] , constrs , vars -> - let l1, p1, u1 = conquer_divided_matching constrs in - let l2, p2, u2 = conquer_matching vars in - if fully_matched (List.map fst constrs) && p1 = Total then - switch path l1 , Total , u1 @ lines_of_matching vars - else - handle (switch path l1) l2 , partial p1 p2 , u1 @ u2 - | _ -> - assert false - -let make (cases : (pattern list * texpr option * texpr) list) p = - let cases = List.concat (List.map (fun (pl,wcond,e) -> - let e = exec e in - let e = (match wcond with None -> e | Some e2 -> ewhen e2 e) in - List.map (fun p -> [p] , e) pl - ) cases) in - let m = cases , [MRoot] in - let lambda, partial, unused = conquer_matching m in - (match unused with - | [] -> () - | ([] , _ ) :: _ -> error "Some pattern are never matched" p - | ((_,p) :: _ , _) :: _ -> error "This pattern is never matched" p); - partial <> Total , lambda diff --git a/libs/include/ocaml/ml/mlneko.ml b/libs/include/ocaml/ml/mlneko.ml deleted file mode 100644 index 51f5a8d2..00000000 --- a/libs/include/ocaml/ml/mlneko.ml +++ /dev/null @@ -1,495 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Ast -open Mltype - -type comparison = - | Native - | Structural - -type context = { - module_name : string; - mutable counter : int; - mutable refvars : (string,unit) PMap.t; -} - -let verbose = ref false - -let gen_label ctx = - let c = ctx.counter in - ctx.counter <- ctx.counter + 1; - "l" ^ string_of_int c - -let gen_variable ctx = - let c = ctx.counter in - ctx.counter <- ctx.counter + 1; - "v" ^ string_of_int c - -let module_name m = - "@" ^ String.concat "_" m - -let builtin name = - EConst (Builtin name) , Ast.null_pos - -let ident name = - EConst (Ident name) , Ast.null_pos - -let int n = - EConst (Int n) , Ast.null_pos - -let null = - EConst Null , Ast.null_pos - -let core s p = - EField ((EConst (Ident (module_name ["Core"])),p),s) , p - -let pos (p : Mlast.pos) = - { - pmin = p.Mlast.pmin; - pmax = p.Mlast.pmax; - pfile = p.Mlast.pfile; - } - -let rec is_fun t = - match t.texpr with - | TNamed (_,_,t) | TLink t -> is_fun t - | TPoly - | TMono _ - | TFun _ -> true - | _ -> false - -let rec call ret f args p = - match f with - | EConst (Builtin _) , _ -> ECall (f,args) , p - | _ -> - match args with - | a :: b :: c :: d :: x :: l -> - let app = ECall ((EConst (Builtin "apply"),p),[f;a;b;c;d]) , p in - call ret app (x :: l) p - | _ -> - if is_fun ret then - ECall ((EConst (Builtin "apply"),p),f :: args) , p - else - ECall (f,args) , p - -let array args p = - ECall ((EConst (Builtin "array"),p),args) , p - -let block e = - match e with - | EBlock _ , _ -> e - | _ -> EBlock [e] , snd e - -let rec arity t = - match t.texpr with - | TAbstract -> 0 - | TTuple tl -> List.length tl - | TLink t -> arity t - | _ -> 1 - -let comparison t = - match tlinks true t with - | TNamed (["int"],[],_) - | TNamed (["char"],[],_) - | TNamed (["float"],[],_) - | TNamed (["string"],[],_) -> Native - | _ -> Structural - -let rec gen_constant ctx c p = - (match c with - | TVoid -> EConst Null - | TInt n when n < 0 -> EBinop ("-",int 0, int (-n)) - | TInt n -> EConst (Int n) - | TFloat s -> EConst (Float s) - | TChar c -> EConst (Int (int_of_char c)) - | TString s -> EConst (String s) - | TIdent s -> - if PMap.mem s ctx.refvars then EArray ((EConst (Ident s),null_pos),int 0) else EConst (Ident s) - | TBool true -> EConst True - | TBool false -> EConst False - | TConstr "[]" | TModule (["Core"],TConstr "[]") -> fst (core "@empty" p) - | TConstr "::" | TModule (["Core"],TConstr "::") -> fst (core "@cons" p) - | TConstr s -> EConst (Ident s) - | TModule ([],c) -> fst (gen_constant ctx c p) - | TModule (m,c) -> - EField ( (EConst (Ident (module_name m)),p) , (match c with TConstr x -> x | TIdent s -> s | _ -> assert false)) - ) , p - -type match_context = { - ctx : context; - h : (match_op , string) Hashtbl.t; - out : string; - pos : Ast.pos; - mutable next : string; - mutable first : bool; -} - -let no_label = "" - -let rec gen_match_rec mctx fail m = - try - ident (Hashtbl.find mctx.h m) - with Not_found -> - let p = mctx.pos in - let ctx = mctx.ctx in - let gen_rec = gen_match_rec mctx in - match m with - | MFailure -> - let label = if mctx.first && mctx.next <> no_label then mctx.next else fail in - if label = no_label then - EBlock [] , p - else - call t_void (builtin "goto") [ident label] p - | MHandle (m1,m2) -> - let label = gen_label ctx in - let m1 = gen_rec label m1 in - let m2 = gen_rec fail m2 in - EBlock [m1; ELabel label, p; m2] , p - | MRoot -> - assert false - | MExecute (e,b) -> - if not b then begin - let ematch = EBinop ("==" , ident "@exc" , core "Stream_matching" p) , p in - let reraise = EIf ( ematch , gen_rec fail MFailure, Some(ECall (builtin "throw", [ident "@exc"]) , p) ) , p in - mctx.first <- false; - match e.edecl with - | TConst _ -> gen_expr ctx e - | _ -> ETry (gen_expr ctx e, "@exc" , reraise ) , p - end else begin - mctx.first <- true; - let out = call t_void (builtin "goto") [ident mctx.out] p in - EBlock [gen_expr ctx e;out] , p - end; - | MConstants (m,[TIdent v,m1]) -> - let m = gen_rec fail m in - EBlock [ - EVars [v, Some m] , p; - gen_rec fail m1 - ] , p - | MConstants (m,cl) -> - let e = gen_rec fail m in - let v = gen_variable ctx in - let exec = List.fold_left (fun acc (c,m) -> - let test = EBinop ("==", ident v, gen_constant ctx c p) , p in - let exec = gen_rec fail m in - EIf (test, exec, Some acc) , p - ) (gen_rec fail MFailure) (List.rev cl) in - EBlock [ - EVars [v, Some e] , p; - exec - ] , p - | MRecordField (m,f) -> - EField (gen_rec fail m, f) , p - | MTuple (m,n) -> - EArray (gen_rec fail m, int n) , p - | MField (m,n) -> - EArray (gen_rec fail m, int (n + 2)) , p - | MNext (m1,m2) -> - let old = mctx.next in - let label = gen_label ctx in - mctx.next <- label; - let m1 = gen_rec fail m1 in - mctx.next <- old; - let m2 = gen_rec fail m2 in - EBlock [m1; ELabel label, p; m2] , p - | MSwitch (m,cl) -> - let e = gen_rec fail m in - let v = gen_variable ctx in - let exec = List.fold_left (fun acc (c,m) -> - let test = EBinop ("==", ident v, gen_constant ctx c p) , p in - let exec = gen_rec fail m in - EIf (test, exec, Some acc) , p - ) (gen_rec fail MFailure) (List.rev cl) in - EBlock [ - EVars [v, Some (EArray (e,int 0),p)] , p; - exec; - ] , p - | MBind (v,m1,m2) -> - let e1 = gen_rec fail m1 in - Hashtbl.add mctx.h m1 v; - let e2 = gen_rec fail m2 in - Hashtbl.remove mctx.h m1; - EBlock [(EVars [v, Some e1] , p); e2] , p - | MWhen (e,m) -> - let e = gen_expr ctx e in - let m = gen_rec fail m in - let fail = gen_rec fail MFailure in - EIf (e,m,Some fail) , p - | MToken (m,n) -> - call t_void (core "stream_token" p) [gen_rec fail m; int n] p - | MJunk (m,n,m2) -> - let m = gen_rec fail m in - mctx.first <- false; - EBlock [ - call t_void (core "stream_junk" p) [m; int n] p; - gen_rec fail m2 - ] , p - -and gen_matching ctx v m p stream out = - let mctx = { - ctx = ctx; - h = Hashtbl.create 0; - pos = p; - out = out; - first = stream; - next = no_label; - } in - let label = (if stream then gen_label ctx else no_label) in - Hashtbl.add mctx.h MRoot v; - let e = gen_match_rec mctx label m in - if stream then begin - let vpos = gen_variable ctx in - let stream_pos = ECall (core "stream_pos" p, [ident v]) , p in - let test = EBinop ("==", ident vpos , stream_pos) , p in - let exc = ECall (builtin "throw",[EIf (test, core "Stream_matching" p , Some (core "Stream_error" p)) , p]) , p in - EBlock [EVars [vpos , Some stream_pos] , p; e; ELabel label , p; exc] , p - end else - e - -and gen_match ctx e m stream p = - let out = gen_label ctx in - let v = gen_variable ctx in - let m = gen_matching ctx v m p stream out in - let m = ENext ((EVars [v,Some e],p),m) , p in - EBlock [m; ELabel out , p] , p - -and gen_constructor ctx tname c t p = - let field = ident c in - let printer = EConst (Ident (tname ^ "__string")) , p in - let val_type t = - match arity t with - | 0 -> - let make = array [null;printer] p in - ENext ((EBinop ("=" , field, make) ,p) , (EBinop("=" , (EArray (field,int 0),p) , field) , p)) , p - | n -> - let args = Array.to_list (Array.init n (fun n -> "p" ^ string_of_int n)) in - let build = array (field :: printer :: List.map (fun a -> EConst (Ident a) , p) args) p in - let func = EFunction (args, (EBlock [EReturn (Some build),p] , p)) , p in - EBinop ("=" , field , func ) , p - in - let export = EBinop ("=", (EField (ident ctx.module_name,c),p) , field) , p in - ENext (val_type t , export) , p - -and gen_type_printer ctx c t = - let printer = mk (TConst (TModule (["Core"],TIdent "@print_union"))) t_void Mlast.null_pos in - let e = mk (TCall (printer,[ - mk (TConst (TString c)) t_string Mlast.null_pos; - mk (TConst (TIdent "v")) t_void Mlast.null_pos - ])) t_string Mlast.null_pos in - e - -and gen_type ctx name t p = - match t.texpr with - | TAbstract - | TMono _ - | TPoly - | TRecord _ - | TTuple _ - | TFun _ - | TNamed (_,_,{ texpr = TNamed _ }) -> - EBlock [] , p - | TLink t -> - gen_type ctx name t p - | TNamed (name,_,t) -> - let rec loop = function - | [] -> assert false - | [x] -> x - | _ :: l -> loop l - in - gen_type ctx (loop name) t p - | TUnion (_,constrs) -> - let cmatch = gen_match ctx (ident "v") (MSwitch (MRoot,List.map (fun (c,t) -> - let e = gen_type_printer ctx c t in - TConstr c , MExecute (e,true) - ) constrs)) false p in - let printer = EFunction (["v"], cmatch) , p in - let regs = List.map (fun (c,t) -> gen_constructor ctx name c t p) constrs in - EBlock ((EVars [name ^ "__string",Some printer],p) :: regs) , p - -and gen_binop ctx op e1 e2 p = - let compare op = - let cmp = ECall (core "@compare" p,[gen_expr ctx e1; gen_expr ctx e2]) , p in - EBinop (op , cmp , int 0) , p - in - let make op = - EBinop (op,gen_expr ctx e1,gen_expr ctx e2) , p - in - let builtin op = - ECall (builtin op,[gen_expr ctx e1; gen_expr ctx e2]) , p - in - match op with - | "and" -> make "&" - | "or" -> make "|" - | "xor" -> make "^" - | "==" | "!=" | ">" | "<" | ">=" | "<=" -> - (match comparison e1.etype with - | Structural -> compare op - | Native -> make op) - | "===" -> EBinop ("==", builtin "pcompare" , int 0) , p - | "!==" -> EBinop ("!=" , builtin "pcompare" , int 0) , p - | ":=" -> - (match e1.edecl with - | TField _ -> make "=" - | TArray (a,i) -> - ECall (core "@aset" p,[gen_expr ctx a; gen_expr ctx i; gen_expr ctx e2]) , p - | _ -> - EBinop ("=",(EArray (gen_expr ctx e1,int 0),pos e1.epos),gen_expr ctx e2) , p) - | _ -> - make op - -and gen_expr ctx e = - let p = pos e.epos in - match e.edecl with - | TConst c -> gen_constant ctx c p - | TBlock el -> EBlock (gen_block ctx el p) , p - | TParenthesis e -> EParenthesis (gen_expr ctx e) , p - | TCall ({ edecl = TConst (TIdent "neko") },[{ edecl = TConst (TString s) }]) - | TCall ({ edecl = TConst (TModule ([],TIdent "neko")) },[{ edecl = TConst (TString s) }]) - | TCall ({ edecl = TConst (TModule (["Core"],TIdent "neko")) },[{ edecl = TConst (TString s) }]) -> - let ch = IO.input_string (String.concat "\"" (ExtString.String.nsplit s "'")) in - let file = "neko@" ^ p.pfile in - Parser.parse (Lexing.from_function (fun s p -> try IO.input ch s 0 p with IO.No_more_input -> 0)) file - | TCall (f,el) -> - let f = gen_expr ctx f in - call e.etype f (List.map (gen_expr ctx) el) p - | TField (e,s) -> EField (gen_expr ctx e, s) , p - | TArray (e1,e2) -> - let e1 = gen_expr ctx e1 in - ECall (core "@aget" p,[e1;gen_expr ctx e2]) , p - | TVar ([v],e) -> - ctx.refvars <- PMap.remove v ctx.refvars; - EVars [v , Some (gen_expr ctx e)] , p - | TVar (vl,e) -> - let n = ref (-1) in - EVars (("@tmp" , Some (gen_expr ctx e)) :: List.map (fun v -> - ctx.refvars <- PMap.remove v ctx.refvars; - incr n; - v , Some (EArray (ident "@tmp",int !n),p) - ) vl) , p - | TIf (e,e1,e2) -> - let e = gen_expr ctx e in - let e1 = gen_expr ctx e1 in - EIf (e, e1, match e2 with None -> None | Some e2 -> Some (gen_expr ctx e2)) , p - | TWhile (e1,e2) -> - let e1 = gen_expr ctx e1 in - let e2 = gen_expr ctx e2 in - EWhile (e1, e2, NormalWhile) , p - | TFunction (_,"_",params,e) -> EFunction (List.map fst params,block (gen_expr ctx e)) , p - | TFunction (false,name,params,e) -> EVars [name , Some (EFunction (List.map fst params,block (gen_expr ctx e)) , p)] , p - | TFunction _ -> EBlock [gen_functions ctx [e] p] , p - | TBinop (op,e1,e2) -> gen_binop ctx op e1 e2 p - | TTupleDecl tl -> array (List.map (gen_expr ctx) tl) p - | TTypeDecl t -> gen_type ctx "" t p - | TMut e -> gen_expr ctx (!e) - | TRecordDecl fl -> - EObject (("__string", core "@print_record" p) :: List.map (fun (s,e) -> s , gen_expr ctx e) fl) , p - | TListDecl el -> - (match el with - | [] -> array [] p - | x :: l -> - let x = gen_expr ctx x in - array [x; gen_expr ctx { e with edecl = TListDecl l }] p) - | TUnop (op,e) -> - (match op with - | "-" -> EBinop ("-",int 0,gen_expr ctx e) , p - | "*" -> EArray (gen_expr ctx e,int 0) , p - | "!" -> call t_void (builtin "not") [gen_expr ctx e] p - | "&" -> array [gen_expr ctx e] p - | _ -> assert false) - | TMatch (e,m,stream) -> - gen_match ctx (gen_expr ctx e) m stream p - | TTupleGet (e,n) -> - EArray (gen_expr ctx e,int n) , p - | TErrorDecl (e,t) -> - let printer = gen_expr ctx (gen_type_printer ctx e t) in - let printer = EFunction (["v"], (EBlock [printer],p)) , p in - let printer = EVars [e ^ "__string",Some printer] , p in - ENext (printer , gen_constructor ctx e e t p) , p - | TTry (e,m) -> - let out = gen_label ctx in - let matching = gen_matching ctx "@exc" m p false out in - let reraise = call t_void (builtin "throw") [ident "@exc"] p in - let handle = EBlock [matching;reraise;ELabel out , p] , p in - ETry (gen_expr ctx e,"@exc",handle) , p - -and gen_functions ctx fl p = - let ell = ref (EVars (List.map (fun e -> - match e.edecl with - | TFunction (_,"_",params,e) -> - "_" , Some (EFunction (List.map fst params,block (gen_expr ctx e)),p) - | TFunction (_,name,_,_) -> - ctx.refvars <- PMap.add name () ctx.refvars; - name , Some (array [null] null_pos) - | _ -> assert false - ) fl) , null_pos) in - List.iter (fun e -> - let p = pos e.epos in - match e.edecl with - | TFunction (_,name,params,e) -> - if name <> "_" then begin - let e = gen_expr ctx e in - let e = EFunction (List.map fst params,block e) , p in - let e = EBinop ("=",(EArray (ident name,int 0),p),e) , p in - let e = EBlock [e; EBinop ("=",ident name,(EArray (ident name,int 0),p)) , p] , p in - ell := ENext (!ell, e) , p; - ctx.refvars <- PMap.remove name ctx.refvars; - end; - | _ -> - assert false - ) fl; - !ell - -and gen_block ctx el p = - let old = ctx.refvars in - let ell = ref [] in - let rec loop fl = function - | [] -> if fl <> [] then ell := gen_functions ctx (List.rev fl) p :: !ell - | { edecl = TFunction (true,name,p,f) } as e :: l -> loop (e :: fl) l - | { edecl = TMut r } :: l -> loop fl (!r :: l) - | x :: l -> - if fl <> [] then ell := gen_functions ctx (List.rev fl) p :: !ell; - ell := gen_expr ctx x :: !ell; - loop [] l - in - loop [] el; - ctx.refvars <- old; - List.rev !ell - -let generate e deps idents m = - let m = module_name m in - let ctx = { - module_name = m; - counter = 0; - refvars = PMap.empty; - } in - if !verbose then print_endline ("Generating " ^ m ^ ".neko"); - let init = EBinop ("=",ident m,builtin "exports"), null_pos in - let deps = List.map (fun m -> - let file = String.concat "/" m in - let load = ECall ((EField (builtin "loader","loadmodule"),null_pos),[gen_constant ctx (TString file) null_pos;builtin "loader"]) , null_pos in - EBinop ("=", ident (module_name m), load ) , null_pos - ) deps in - let exports = List.map (fun i -> - EBinop ("=", (EField (builtin "exports",i),null_pos) , ident i) , null_pos - ) idents in - match gen_expr ctx e with - | EBlock e , p -> EBlock (init :: deps @ e @ exports) , p - | e -> EBlock (init :: deps @ e :: exports) , null_pos - diff --git a/libs/include/ocaml/ml/mlparser.ml b/libs/include/ocaml/ml/mlparser.ml deleted file mode 100644 index 465f04c4..00000000 --- a/libs/include/ocaml/ml/mlparser.ml +++ /dev/null @@ -1,398 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Mlast - -type error_msg = - | Unexpected of token - | Unclosed of string - | Duplicate_default - | Unknown_macro of string - | Invalid_macro_parameters of string * int - -exception Error of error_msg * pos - -let error_msg = function - | Unexpected t -> "Unexpected " ^ s_token t - | Unclosed s -> "Unclosed " ^ s - | Duplicate_default -> "Duplicate default declaration" - | Unknown_macro m -> "Unknown macro " ^ m - | Invalid_macro_parameters (m,n) -> "Invalid number of parameters for macro " ^ m ^ " : " ^ string_of_int n ^ " required" - -let error m p = raise (Error (m,p)) - -let priority = function - | "+=" | "-=" | "*=" | "/=" | "|=" | "&=" | "^=" | ":=" -> -3 - | "&&" | "||" -> -2 - | "==" | "!=" | ">" | "<" | "<=" | ">=" | "===" | "!==" | "<>" | "=" -> -1 - | "+" | "-" -> 0 - | "*" | "/" -> 1 - | "or" | "and" | "xor" -> 2 - | "<<" | ">>" | "%" | ">>>" -> 3 - | _ -> 4 - -let can_swap _op op = - let p1 = priority _op in - let p2 = priority op in - if p1 < p2 then - true - else if p1 = p2 then - op <> "::" - else - false - -let rec make_binop op e ((v,p2) as e2) = - match v with - | EBinop (_op,_e,_e2) when can_swap _op op -> - let _e = make_binop op e _e in - EBinop (_op,_e,_e2) , punion (pos _e) (pos _e2) - | _ -> - EBinop (op,e,e2) , punion (pos e) (pos e2) - -let rec make_unop op ((v,p2) as e) p1 = - match v with - | EBinop (bop,e,e2) -> EBinop (bop, make_unop op e p1 , e2) , (punion p1 p2) - | _ -> - EUnop (op,e), punion p1 p2 - -let rec make_list_pat p = function - | [] -> PConstr ([],"[]",None) , p - | x :: l -> - let p = snd x in - let params = PTuple [x;make_list_pat p l] , p in - PConstr ([],"::",Some params) , p - -let rec make_list p = function - | [] -> EConst (Constr "[]") , p - | x :: l -> - let p = snd x in - ECall ((EConst (Constr "::") , p), [x;make_list p l]) , p - -let is_unop = function - | "-" | "*" | "!" | "&" -> true - | _ -> false - -let unclosed s p = error (Unclosed s) p - -let rec program = parser - | [< e = expr; p = program >] -> e :: p - | [< '(Semicolon,_); p = program >] -> p - | [< '(Eof,_) >] -> [] - -and expr = parser - | [< '(BraceOpen,p1); e = block1; s >] -> - (match s with parser - | [< '(BraceClose,p2); s >] -> e , punion p1 p2 - | [< >] -> unclosed "{" p1) - | [< '(Keyword Var,p1); '(Const (Ident name),_); t = type_opt; l = vars; e = expr; s >] -> - EVar ((name,t) :: l,e) , punion p1 (pos e) - | [< '(Keyword If,p1); cond = expr; '(Keyword Then,_); e = expr; s >] -> - (match s with parser - | [< '(Keyword Else,_); e2 = expr; s >] -> EIf (cond,e,Some e2) , punion p1 (pos e2) - | [< >] -> EIf (cond,e,None) , punion p1 (pos e)) - | [< '(Keyword Function,p1); r = function_rec; n = ident_opt; '(ParentOpen _,po); p = parameters_decl; t = type_opt; e = expr >] -> - EFunction (r,n,p,e,t) , punion p1 (pos e) - | [< '(Keyword Type,p1); pl = type_decl_parameters; '(Const (Ident tname),p2); d , p2 = type_declaration p2 >] -> - ETypeDecl (pl,tname,d) , punion p1 p2 - | [< '(Keyword Exception,p1); '(Const (Constr ename),p2); t = type_opt; s >] -> - EErrorDecl (ename,t) , punion p1 p2 - | [< '(Keyword Match,p1); e = expr; '(BraceOpen,po); pl = patterns_begin; s >] -> - (match s with parser - | [< '(BraceClose,pe); >] -> EMatch (e,pl), punion p1 pe - | [< >] -> unclosed "{" po) - | [< '(Keyword Try,p1); b = block; '(Keyword Catch,p2); '(BraceOpen,po); pl = patterns_begin; s >] -> - (match s with parser - | [< '(BraceClose,pe); >] -> ETry ((EBlock b,punion p1 p2),pl), punion p1 pe - | [< >] -> unclosed "{" po) - | [< '(Keyword While,p1); e = expr; '(BraceOpen,po); b = block; s >] -> - (match s with parser - | [< '(BraceClose,pe); s >] -> EWhile (e,(EBlock b,punion po pe)) , punion po pe - | [< >] -> unclosed "{" po) - | [< e = expr_short >] -> - e - -and expr_short = parser - | [< '(ParentOpen _,p1); pl = parameters; s >] -> - (match s with parser - | [< '(ParentClose,p2); s >] -> expr_next (ETupleDecl pl,punion p1 p2) s - | [< >] -> unclosed "(" p1) - | [< '(Binop op,p) when is_unop op; e = expr; s >] -> - expr_next (make_unop op e p) s - | [< '(Const (Constr n),p); e = expr_constr n p; s >] -> - expr_next e s - | [< '(Const c,p); s >] -> - expr_next (EConst c,p) s - | [< '(BracketOpen,p1); b = block; '(BracketClose,p2); s >] -> - expr_next (make_list (punion p1 p2) b) s - -and expr_next e = parser - | [< '(Binop ":",_); t , p = type_path; s >] -> - expr_next (ETypeAnnot (e,t),punion (pos e) p) s - | [< '(ParentOpen false,po); pl = parameters; s >] -> - (match s with parser - | [< '(ParentClose,p); s >] -> expr_next (ECall (e,pl),punion (pos e) p) s - | [< >] -> unclosed "(" po) - | [< '(Dot,_); s >] -> - (match s with parser - | [< '(Const (Ident name),p); s >] -> expr_next (EField (e,name),punion (pos e) p) s - | [< '(BracketOpen,po); e2 = expr; s >] -> - (match s with parser - | [< '(BracketClose,p); s >] -> expr_next (EArray (e,e2),punion (pos e) p) s - | [< >] -> unclosed "[" po)) - | [< '(Binop op,_); e2 = expr; s >] -> - make_binop op e e2 - | [< ep = expr_short >] -> - let rec loop ep = - match ep with - | EApply (e2,l) , p -> EApply (e,e2 :: l) , punion (pos e) p - | EBinop (op,e1,e2) , p -> EBinop (op,loop e1,e2) , punion (pos e) p - | _ -> EApply (e,[ep]) , punion (pos e) (pos ep) - in - loop ep - | [< >] -> - e - -and expr_constr n p = parser - | [< '(Dot,_); e = expr_constr2 >] -> - (match e with - | EConst ((Ident _) as c) , p2 - | EConst ((Constr _) as c) , p2 -> EConst (Module ([n],c)) , punion p p2 - | EConst (Module (l,c)) , p2 -> EConst (Module (n :: l,c)) , punion p p2 - | _ -> assert false); - | [< >] -> EConst (Constr n), p - -and expr_constr2 = parser - | [< '(Const (Ident n),p) >] -> EConst (Ident n) , p - | [< '(Const (Constr n),p); e = expr_constr n p >] -> e - -and block1 = parser - | [< '(Const (Ident name),p); s >] -> - (match s with parser - | [< '(Binop "=",_); e = expr; l = record_fields >] -> ERecordDecl ((name,e) :: l) - | [< e = expr_next (EConst (Ident name),p); b = block >] -> EBlock (e :: b)) - | [< b = block >] -> - EBlock b - -and record_fields = parser - | [< '(Const (Ident name),_); '(Binop "=",_); e = expr; l = record_fields >] -> (name,e) :: l - | [< '(Semicolon,_); l = record_fields >] -> l - | [< >] -> [] - -and vars = parser - | [< '(Binop "=",_) >] -> [] - | [< '(Comma,_); '(Const (Ident name),_); t = type_opt; l = vars >] -> (name,t) :: l - -and block = parser - | [< e = expr; b = block >] -> e :: b - | [< '(Semicolon,_); b = block >] -> b - | [< >] -> [] - -and parameters_decl = parser - | [< '(Const (Ident name),_); s >] -> parameters_decl_next (ANamed name) s - | [< '(ParentOpen _,_); l = parameters_decl; s >] -> parameters_decl_next (ATuple l) s - | [< '(ParentClose,_) >] -> [] - -and parameters_decl_next acc = parser - | [< '(Comma,_); p = parameters_decl >] -> acc :: p - | [< '(Binop ":",_); t , _ = type_path; s >] -> parameters_decl_next (ATyped (acc,t)) s - | [< '(ParentClose,_) >] -> [acc] - -and type_opt = parser - | [< '(Binop ":",_); t , _ = type_path; >] -> Some t - | [< >] -> None - -and function_rec = parser - | [< '(Const (Ident "rec"),_); >] -> true - | [< >] -> false - -and ident_opt = parser - | [< '(Const (Ident name),_); >] -> Some name - | [< >] -> None - -and parameters = parser - | [< e = expr; p = parameters_next >] -> e :: p - | [< >] -> [] - -and parameters_next = parser - | [< '(Comma,_); p = parameters >] -> p - | [< >] -> [] - -and type_path = parser - | [< '(Const (Ident tname),p); t = type_path_next (EType (None,[],tname)) p >] -> t - | [< '(Const (Constr m),p); '(Dot,_); l = type_path_mod; '(Const (Ident tname),_); t = type_path_next (EType (None,m :: l,tname)) p >] -> t - | [< '(Quote,_); '(Const (Ident a),p); t = type_path_next (EPoly a) p >] -> t - | [< '(ParentOpen _,_); t , p = type_path; l , p = type_path_list_next p; '(ParentClose,_); s >] -> - type_path_next (ETuple (t :: l)) p s - -and type_path_list p = parser - | [< t , p = type_path; l , p = type_path_list_next p >] -> t :: l , p - -and type_path_list_next p = parser - | [< '(Comma,_); t = type_path_list p >] -> t - | [< >] -> [] , p - -and type_path_next t p = parser - | [< '(Arrow,_); t2 , p = type_path >] -> EArrow(t,t2) , p - | [< '(Const (Ident tname),p); t = type_path_next (EType (Some t,[],tname)) p >] -> t - | [< '(Const (Constr m),p); '(Dot,_); l = type_path_mod; '(Const (Ident tname),_); t = type_path_next (EType (Some t,m :: l,tname)) p >] -> t - | [< >] -> t , p - -and type_path_mod = parser - | [< '(Const (Constr m),_); '(Dot,_); l = type_path_mod >] -> m :: l - | [< >] -> [] - -and type_decl_parameters = parser - | [< '(Quote,_); '(Const (Ident a),_); >] -> [a] - | [< '(ParentOpen _,_); l = type_decl_plist; '(ParentClose,_); >] -> l - | [< >] -> [] - -and type_decl_plist = parser - | [< '(Quote,_); '(Const (Ident a),_); l = type_decl_plist_next >] -> a :: l - -and type_decl_plist_next = parser - | [< '(Comma,_); l = type_decl_plist >] -> l - | [< >] -> [] - -and type_declaration p = parser - | [< '(BraceOpen,_); s >] -> - (match s with parser - | [< el , p = record_declaration false >] -> ERecord el , p - | [< el , p = union_declaration >] -> EUnion el , p) - | [< '(Binop "=",_); t , p = type_path >] -> EAlias t , p - | [< >] -> EAbstract , p - -and record_declaration mut = parser - | [< '(BraceClose,p) >] -> [] , p - | [< '(Const (Ident "mutable"),_); l = record_declaration true; >] -> l - | [< '(Semicolon,_); l = record_declaration false >] -> l - | [< '(Const (Ident name),_); '(Binop ":",_); t , _ = type_path; l , p = record_declaration false >] -> (name,mut,t) :: l , p - -and union_declaration = parser - | [< '(BraceClose,p) >] -> [] , p - | [< '(Semicolon,_); l = union_declaration >] -> l - | [< '(Const (Constr name),_); t = type_opt; l , p = union_declaration >] -> (name,t) :: l , p - -and patterns_begin = parser - | [< '(Vertical,_); l = patterns >] -> l - | [< l = patterns >] -> l - -and patterns = parser - | [< p = pattern; pl = pattern_next; w = when_clause; '(Arrow,pa); b = block; l = patterns_begin >] -> - let pat = (p :: pl,w,(match b with [e] -> e | _ -> EBlock b , pa) ) in - pat :: l - | [< >] -> [] - -and pattern_next = parser - | [< '(Vertical,_); p = pattern; l = pattern_next >] -> p :: l - | [< >] -> [] - -and pattern = parser - | [< d , p = pattern_decl; s >] -> - match s with parser - | [< '(Const (Ident "as"),_); '(Const (Ident v),p2); s >] -> PAlias (v, (d,p)) , punion p p2 - | [< '(Binop "::",_); d2 , p2 = pattern >] -> PConstr ([],"::",Some (PTuple [(d,p);(d2,p2)] , punion p p2)) , punion p p2 - | [< t = type_opt >] -> - match t with - | None -> d , p - | Some t -> PTyped ((d , p), t) , p - -and pattern_decl = parser - | [< '(ParentOpen _,p1); pl = pattern_tuple; '(ParentClose,p2) >] -> PTuple pl , punion p1 p2 - | [< '(BraceOpen,p1); '(Const (Ident name),_); '(Binop "=",_); p = pattern; pl = pattern_record; '(BraceClose,p2) >] -> PRecord ((name,p) :: pl) , punion p1 p2 - | [< '(Const (Constr name),p1); l, name, p2 = pattern_mod_path name p1; p , p2 = pattern_opt p2 >] -> PConstr (l,name,p) , punion p1 p2 - | [< '(Const (Ident i),p); >] -> PIdent i , p - | [< '(Const c,p); >] -> PConst c , p - | [< '(Binop "-",p1); '(Const (Int i),p2) >] -> PConst (Int (-i)) , punion p1 p2 - | [< '(BracketOpen,p1); l = pattern_list; '(BracketClose,p2) >] -> make_list_pat (punion p1 p2) l - | [< '(StreamOpen,p1); l = stream_list; '(StreamClose,p2) >] -> PStream (l,0) , punion p1 p2 - -and pattern_mod_path name p = parser - | [< '(Dot,_); '(Const (Constr n),p); l, n, p = pattern_mod_path n p >] -> name :: l , n , p - | [< >] -> [], name, p - -and stream_list = parser - | [< '(Const (Ident v),p1); s >] -> - (match s with parser - | [< l = stream_ident_list; e = expr; s >] -> SExpr (v :: l,e) :: stream_next s - | [< >] -> SPattern (PIdent v,p1) :: stream_next s) - | [< p = pattern; l = stream_next >] -> SPattern p :: l - | [< >] -> [] - -and stream_ident_list = parser - | [< '(Comma,_); '(Const (Ident v),_); l = stream_ident_list >] -> v :: l - | [< '(Binop "=",_) >] -> [] - -and stream_next = parser - | [< '(Semicolon,_); l = stream_list >] -> l - | [< >] -> [] - -and pattern_list = parser - | [< p = pattern; l = pattern_list_next >] -> p :: l - | [< >] -> [] - -and pattern_list_next = parser - | [< '(Semicolon,_); l = pattern_list >] -> l - | [< >] -> [] - -and pattern_tuple = parser - | [< p = pattern; l = pattern_tuple_next >] -> p :: l - | [< >] -> [] - -and pattern_tuple_next = parser - | [< '(Comma,_); l = pattern_tuple >] -> l - | [< >] -> [] - -and pattern_record = parser - | [< '(Const (Ident name),_); '(Binop "=",_); p = pattern; l = pattern_record >] -> (name,p) :: l - | [< '(Semicolon,_); l = pattern_record >] -> l - | [< >] -> [] - -and pattern_opt p = parser - | [< ( _ , pos as p) = pattern >] -> Some p , pos - | [< >] -> None , p - -and when_clause = parser - | [< '(Keyword When,_); e = expr >] -> Some e - | [< >] -> None - -let parse code file = - let old = Mllexer.save() in - Mllexer.init file; - let last = ref (Eof,null_pos) in - let rec next_token x = - let t, p = Mllexer.token code in - match t with - | Comment s | CommentLine s -> - next_token x - | _ -> - last := (t , p); - Some (t , p) - in - try - let l = program (Stream.from next_token) in - Mllexer.restore old; - EBlock l, { pmin = 0; pmax = (pos !last).pmax; pfile = file } - with - | Stream.Error _ - | Stream.Failure -> - Mllexer.restore old; - error (Unexpected (fst !last)) (pos !last) - | e -> - Mllexer.restore old; - raise e diff --git a/libs/include/ocaml/ml/mltype.ml b/libs/include/ocaml/ml/mltype.ml deleted file mode 100644 index 0a550de5..00000000 --- a/libs/include/ocaml/ml/mltype.ml +++ /dev/null @@ -1,284 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -type pos = Mlast.pos - -type mutflag = - | Mutable - | Immutable - -type type_expr = - | TAbstract - | TMono of int - | TPoly - | TRecord of (string * mutflag * t) list - | TUnion of int * (string * t) list - | TTuple of t list - | TLink of t - | TFun of t list * t - | TNamed of string list * t list * t - -and t = { - mutable tid : int; - mutable texpr : type_expr; -} - -type tconstant = - | TVoid - | TInt of int - | TBool of bool - | TFloat of string - | TString of string - | TChar of char - | TIdent of string - | TConstr of string - | TModule of string list * tconstant - -and match_op = - | MRoot - | MFailure - | MHandle of match_op * match_op - | MExecute of texpr * bool - | MConstants of match_op * (tconstant * match_op) list - | MField of match_op * int - | MTuple of match_op * int - | MToken of match_op * int - | MRecordField of match_op * string - | MJunk of match_op * int * match_op - | MSwitch of match_op * (tconstant * match_op) list - | MBind of string * match_op * match_op - | MWhen of texpr * match_op - | MNext of match_op * match_op - -and texpr_decl = - | TConst of tconstant - | TBlock of texpr list - | TParenthesis of texpr - | TCall of texpr * texpr list - | TField of texpr * string - | TArray of texpr * texpr - | TVar of string list * texpr - | TIf of texpr * texpr * texpr option - | TFunction of bool * string * (string * t) list * texpr - | TBinop of string * texpr * texpr - | TTupleDecl of texpr list - | TTypeDecl of t - | TMut of texpr ref - | TRecordDecl of (string * texpr) list - | TListDecl of texpr list - | TUnop of string * texpr - | TMatch of texpr * match_op * bool - | TTry of texpr * match_op - | TTupleGet of texpr * int - | TErrorDecl of string * t - | TWhile of texpr * texpr - -and texpr = { - edecl : texpr_decl; - etype : t; - epos : pos; -} - -type id_gen = int ref - -let pos e = e.epos - -let rec tlinks name t = - match t.texpr with - | TLink t -> tlinks name t - | TNamed (_,_,t) when not name -> tlinks name t - | _ -> t.texpr - -let etype name e = tlinks name e.etype - -let genid i = incr i; !i -let generator() = ref 0 - -let mk e t p = { - edecl = e; - etype = t; - epos = p; -} - -let t_abstract = { tid = -1; texpr = TAbstract } - -let abstract s = { - tid = -1; - texpr = TNamed ([s],[], t_abstract); -} - -let t_void = abstract "void" -let t_int = abstract "int" -let t_float = abstract "float" -let t_char = abstract "char" -let t_error = abstract "error" -let t_bool = { - tid = -1; - texpr = TNamed (["bool"],[], { - tid = -1; - texpr = TUnion (2,[ - ("true",{ tid = -1; texpr = TAbstract }); - ("false",{ tid = -1; texpr = TAbstract }) - ]); - }); -} - -let t_string = abstract "string" - -let t_mono g = { - tid = -2; - texpr = TMono (genid g); -} - -let t_polymorph g = { - tid = genid g; - texpr = TPoly; -} - -let t_poly g name = - let param = t_mono g in - { - tid = genid g; - texpr = TNamed ([name],[param], { tid = -1; texpr = TAbstract }); - } , param - -let mk_fun g params ret = { - tid = if List.exists (fun t -> t.tid <> -1) (ret :: params) then genid g else -1; - texpr = TFun (params,ret); -} - -let mk_tup g l = { - tid = if List.exists (fun t -> t.tid <> -1) l then genid g else -1; - texpr = TTuple l; -} - -let mk_record g fl = { - tid = if List.exists (fun (_,_,t) -> t.tid <> -1) fl then genid g else -1; - texpr = TRecord fl; -} - -let mk_union g fl = { - tid = if List.exists (fun (_,t) -> t.tid <> -1) fl then genid g else -1; - texpr = TUnion (List.length fl,fl); -} - -type print_infos = { - mutable pi_mcount : int; - mutable pi_pcount : int; - mutable pi_ml : (t * int) list; - mutable pi_ph : (int , int) Hashtbl.t; -} - -let s_context() = { - pi_mcount = 0; - pi_pcount = 0; - pi_ml = []; - pi_ph = Hashtbl.create 0; -} - -let poly_id n = - if n < 26 then - String.make 1 (char_of_int (int_of_char 'a' + n)) - else - string_of_int (n - 25) - -let s_mutable = function - | Mutable -> "mutable " - | Immutable -> "" - -let rec s_type ?(ext=false) ?(h=s_context()) t = - match t.texpr with - | TAbstract -> "" - | TMono _ -> Printf.sprintf "'_%s" (poly_id (try - if t.tid <> -2 then assert false; - List.assq t h.pi_ml - with Not_found -> - let k = h.pi_mcount in - h.pi_mcount <- h.pi_mcount + 1; - h.pi_ml <- (t,k) :: h.pi_ml; - k)) - | TPoly -> Printf.sprintf "'%s" (poly_id (try - if t.tid = -1 then assert false; - Hashtbl.find h.pi_ph t.tid - with Not_found -> - let k = h.pi_pcount in - h.pi_pcount <- h.pi_pcount + 1; - Hashtbl.add h.pi_ph t.tid k; - k)) - | TRecord fl -> Printf.sprintf "{ %s }" (String.concat "; " (List.map (fun (f,m,t) -> s_mutable m ^ f ^ " : " ^ s_type ~h t) fl)) - | TUnion (_,fl) -> Printf.sprintf "{ %s }" (String.concat "; " (List.map (fun (f,t) -> f ^ " : " ^ s_type ~h t) fl)) - | TTuple l -> Printf.sprintf "(%s)" (String.concat ", " (List.map (s_type ~h) l)) - | TLink t -> s_type ~ext ~h t - | TFun (tl,r) -> - let l = String.concat " -> " (List.map (s_fun ~ext ~h) tl) ^ " -> " in - l ^ s_type ~ext ~h r - | TNamed (name,params,t) -> - let s = (match params with - | [] -> "" - | [p] -> s_type ~h p ^ " " - | l -> "(" ^ String.concat ", " (List.map (s_type ~h) l) ^ ") ") - in - let name = String.concat "." name in - if ext then - s ^ name ^ " = " ^ s_type ~h t - else - s ^ name - -and s_fun ~ext ~h t = - match t.texpr with - | TLink t -> s_fun ~ext ~h t - | TFun _ -> "(" ^ s_type ~ext ~h t ^ ")" - | _ -> s_type ~ext ~h t - -let rec duplicate g ?(h=Hashtbl.create 0) t = - if t.tid < 0 then - t - else try - Hashtbl.find h t.tid - with Not_found -> - let t2 = { - tid = genid g; - texpr = TAbstract; - } in - Hashtbl.add h t.tid t2; - t2.texpr <- (match t.texpr with - | TAbstract -> TAbstract - | TMono _ -> assert false - | TPoly -> t2.tid <- -2; TMono (genid g) - | TRecord tl -> TRecord (List.map (fun (n,m,t) -> n , m, duplicate g ~h t) tl) - | TUnion (n,tl) -> TUnion (n,List.map (fun (n,t) -> n , duplicate g ~h t) tl) - | TTuple tl -> TTuple (List.map (duplicate g ~h) tl) - | TLink t -> TLink (duplicate g ~h t) - | TFun (tl,t) -> TFun (List.map (duplicate g ~h) tl, duplicate g ~h t) - | TNamed (n,p,t) -> TNamed (n,List.map (duplicate g ~h) p,duplicate g ~h t)); - t2 - -let rec polymorphize g mink t = - if t.tid = -1 then - () - else match t.texpr with - | TAbstract -> () - | TMono k -> if k > mink then begin t.texpr <- TPoly; t.tid <- genid g end; - | TPoly -> () - | TRecord fl -> List.iter (fun (_,_,t) -> polymorphize g mink t) fl - | TUnion (_,fl) -> List.iter (fun (_,t) -> polymorphize g mink t) fl - | TTuple tl -> List.iter (polymorphize g mink) tl - | TLink t -> polymorphize g mink t - | TFun (tl,t) -> List.iter (polymorphize g mink) tl; polymorphize g mink t - | TNamed (_,tl,t) -> List.iter (polymorphize g mink) tl diff --git a/libs/include/ocaml/ml/mltyper.ml b/libs/include/ocaml/ml/mltyper.ml deleted file mode 100644 index f449df68..00000000 --- a/libs/include/ocaml/ml/mltyper.ml +++ /dev/null @@ -1,1099 +0,0 @@ -(* - * NekoML Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Mlast -open Mltype - -type module_context = { - path : string list; - types : (string,t) Hashtbl.t; - constrs : (string, t * t) Hashtbl.t; - records : (string,t * t * mutflag) Hashtbl.t; - deps : (string list, module_context) Hashtbl.t; - mutable expr : texpr option; - mutable idents : (string,t) PMap.t; -} - -type context = { - gen : id_gen; - mutable mink : int; - mutable functions : (bool * string * texpr ref * t * (string * t) list * expr * t * pos) list; - mutable opens : module_context list; - mutable curfunction : string; - tmptypes : (string, t * t list * (string,t) Hashtbl.t) Hashtbl.t; - current : module_context; - modules : (string list, module_context) Hashtbl.t; - classpath : string list; -} - -type error_msg = - | Cannot_unify of t * t - | Have_no_field of t * string - | Stack of error_msg * error_msg - | Unknown_field of string - | Module_not_loaded of module_context - | Custom of string - -exception Error of error_msg * pos - -module SSet = Set.Make(String) - -let rec error_msg ?(h=s_context()) = function - | Cannot_unify (t1,t2) -> "Cannot unify " ^ s_type ~h t1 ^ " and " ^ s_type ~h t2 - | Have_no_field (t,f) -> s_type ~h t ^ " have no field " ^ f - | Stack (m1,m2) -> error_msg ~h m1 ^ "\n " ^ error_msg ~h m2 - | Unknown_field s -> "Unknown field " ^ s - | Module_not_loaded m -> "Module " ^ String.concat "." m.path ^ " require an interface" - | Custom s -> s - -let error m p = raise (Error (m,p)) - -let verbose = ref false - -let load_module_ref = ref (fun _ _ -> assert false) - -let add_local ctx v t = - if v <> "_" then ctx.current.idents <- PMap.add v t ctx.current.idents - -let save_locals ctx = - ctx.current.idents - -let restore_locals ctx l = - ctx.current.idents <- l - -let get_module ctx path p = - match path with - | [] -> ctx.current - | _ -> - let m = (try - Hashtbl.find ctx.modules path - with - Not_found -> - !load_module_ref ctx path p) in - if m != ctx.current then begin - if m.expr = None then error (Module_not_loaded m) p; - Hashtbl.replace ctx.current.deps m.path m; - end; - m - -let get_type ctx path name p = - let rec loop = function - | [] -> error (Custom ("Unknown type " ^ s_path path name)) p - | m :: l -> - try - Hashtbl.find m.types name - with - Not_found -> loop l - in - match path with - | [] -> - loop (ctx.current :: ctx.opens) - | _ -> - loop [get_module ctx path p] - -let get_constr ctx path name p = - let rec loop = function - | [] -> error (Custom ("Unknown constructor " ^ s_path path name)) p - | m :: l -> - try - let t1, t2 = Hashtbl.find m.constrs name in - (if m == ctx.current then [] else m.path) , t1, t2 - with - Not_found -> loop l - in - match path with - | [] -> - loop (ctx.current :: ctx.opens) - | _ -> - loop [get_module ctx path p] - -let get_ident ctx path name p = - let rec loop = function - | [] -> error (Custom ("Unknown identifier " ^ s_path path name)) p - | m :: l -> - try - (if m == ctx.current then [] else m.path) , PMap.find name m.idents - with - Not_found -> loop l - in - match path with - | [] -> - loop (ctx.current :: ctx.opens) - | _ -> - loop [get_module ctx path p] - -let get_record ctx f p = - let rec loop = function - | [] -> error (Unknown_field f) p - | m :: l -> - try - Hashtbl.find m.records f - with - Not_found -> loop l - in - let rt , ft , mut = loop (ctx.current :: ctx.opens) in - let h = Hashtbl.create 0 in - duplicate ctx.gen ~h rt, duplicate ctx.gen ~h ft, mut - -let rec is_tuple t = - match t.texpr with - | TLink t -> is_tuple t - | TTuple _ -> true - | TNamed(_,_,t) -> is_tuple t - | _ -> false - -let rec is_recursive t1 t2 = - if t1 == t2 then - true - else match t2.texpr with - | TAbstract - | TMono _ - | TPoly -> - false - | TRecord _ - | TUnion _ -> - assert false - | TTuple tl -> List.exists (is_recursive t1) tl - | TLink t -> is_recursive t1 t - | TFun (tl,t) -> List.exists (is_recursive t1) tl || is_recursive t1 t - | TNamed (_,p,t) -> List.exists (is_recursive t1) p - -let link ctx t1 t2 p = - if is_recursive t1 t2 then error (Cannot_unify (t1,t2)) p; - t1.texpr <- TLink t2; - if t1.tid < 0 then begin - if t2.tid = -1 then t1.tid <- -1 else t1.tid <- genid ctx.gen; - end else - if t2.tid = -1 then t1.tid <- -1 - -let unify_stack t1 t2 = function - | Error (Cannot_unify _ as e , p) -> error (Stack (e , Cannot_unify (t1,t2))) p - | e -> raise e - -let is_alias = function - | TAbstract - | TRecord _ - | TUnion _ -> false - | TMono _ - | TPoly - | TTuple _ - | TLink _ - | TFun _ - | TNamed _ -> true - -let rec propagate k t = - match t.texpr with - | TAbstract - | TPoly -> () - | TUnion _ - | TRecord _ -> assert false - | TMono k2 -> if k < k2 then t.texpr <- TMono k - | TTuple tl -> List.iter (propagate k) tl - | TLink t -> propagate k t - | TFun (tl,t) -> propagate k t; List.iter (propagate k) tl - | TNamed (_,tl,_) -> List.iter (propagate k) tl - -let rec unify ctx t1 t2 p = - if t1 == t2 then - () - else match t1.texpr , t2.texpr with - | TLink t , _ -> unify ctx t t2 p - | _ , TLink t -> unify ctx t1 t p - | TMono k , t -> link ctx t1 t2 p; propagate k t2 - | t , TMono k -> link ctx t2 t1 p; propagate k t1 - | TPoly , t -> link ctx t1 t2 p - | t , TPoly -> link ctx t2 t1 p - | TNamed (n1,p1,_) , TNamed (n2,p2,_) when n1 = n2 -> - (try - List.iter2 (fun p1 p2 -> unify ctx p1 p2 p) p1 p2 - with - e -> unify_stack t1 t2 e) - | TNamed (_,_,t1) , _ when is_alias t1.texpr -> - (try - unify ctx t1 t2 p - with - e -> unify_stack t1 t2 e) - | _ , TNamed (_,_,t2) when is_alias t2.texpr -> - (try - unify ctx t1 t2 p - with - e -> unify_stack t1 t2 e) - | TFun (tl1,r1) , TFun (tl2,r2) when List.length tl1 = List.length tl2 -> - (try - List.iter2 (fun t1 t2 -> unify ctx t1 t2 p) tl1 tl2; - unify ctx r1 r2 p; - with - e -> unify_stack t1 t2 e) - | TTuple tl1 , TTuple tl2 when List.length tl1 = List.length tl2 -> - (try - List.iter2 (fun t1 t2 -> unify ctx t1 t2 p) tl1 tl2 - with - e -> unify_stack t1 t2 e) - | _ , _ -> - error (Cannot_unify (t1,t2)) p - -let rec type_type ?(allow=true) ?(h=Hashtbl.create 0) ctx t p = - match t with - | ETuple [] -> - assert false - | ETuple [t] -> - type_type ~allow ~h ctx t p - | ETuple el -> - mk_tup ctx.gen (List.map (fun t -> type_type ~allow ~h ctx t p) el) - | EPoly s -> - (try - Hashtbl.find h s - with - Not_found -> - if not allow then error (Custom ("Unbound type variable '" ^ s)) p; - let t = t_mono ctx.gen in - Hashtbl.add h s t; - t) - | EType (param,path,name) -> - let param = (match param with None -> None | Some t -> Some (type_type ~allow ~h ctx t p)) in - let t = get_type ctx path name p in - (match t.texpr with - | TNamed (_,params,t2) -> - let tl = (match params, param with - | [] , None -> [] - | [x] , Some t -> [t] - | l , Some { texpr = TTuple tl } when List.length tl = List.length l -> tl - | _ , _ -> error (Custom ("Invalid number of type parameters for " ^ s_path path name)) p - ) in - let h = Hashtbl.create 0 in - let t = duplicate ctx.gen ~h t in - let params = List.map (duplicate ctx.gen ~h) params in - List.iter2 (fun pa t -> unify ctx pa t p) params tl; - t - | _ -> assert false) - | EArrow _ -> - let rec loop params t = - match t with - | EArrow (ta,tb) -> - let ta = type_type ~allow ~h ctx ta p in - loop (ta :: params) tb - | _ -> - let t = type_type ~allow ~h ctx t p in - mk_fun ctx.gen (List.rev params) t - in - loop [] t - -let rec type_constant ctx ?(path=[]) c p = - match c with - | Int i -> mk (TConst (TInt i)) t_int p - | Float s -> mk (TConst (TFloat s)) t_float p - | String s -> mk (TConst (TString s)) t_string p - | Bool b -> mk (TConst (TBool b)) t_bool p - | Char c -> mk (TConst (TChar c)) t_char p - | Ident s -> - let path , t = get_ident ctx path s p in - let t = duplicate ctx.gen t in - mk (TConst (TModule (path,TIdent s))) t p - | Constr s -> - let path , ut , t = get_constr ctx path s p in - let t = duplicate ctx.gen (match t.texpr with - | TAbstract -> ut - | TTuple tl -> mk_fun ctx.gen tl ut - | _ -> mk_fun ctx.gen [t] ut) in - mk (TConst (TModule (path,TConstr s))) t p - | Module (path,c) -> - type_constant ctx ~path c p - -type addable = NInt | NFloat | NString | NNan - -let addable str e = - match etype true e with - | TNamed (["int"],_,_) -> NInt - | TNamed (["float"],_,_) -> NFloat - | TNamed (["string"],_,_) when str -> NString - | _ -> NNan - -let type_binop ctx op e1 e2 p = - let emk t = mk (TBinop (op,e1,e2)) t p in - match op with - | "%" - | "+" - | "-" - | "/" - | "*" -> - let str = (op = "+") in - (match addable str e1, addable str e2 with - | NInt , NInt -> emk t_int - | NFloat , NFloat - | NInt , NFloat - | NFloat , NInt -> emk t_float - | NInt , NString - | NFloat , NString - | NString , NInt - | NString , NFloat - | NString , NString -> emk t_string - | NInt , NNan - | NFloat , NNan - | NString , NNan -> - unify ctx e2.etype e1.etype (pos e2); - emk e1.etype - | NNan , NInt - | NNan , NFloat - | NNan , NString -> - unify ctx e1.etype e2.etype (pos e1); - emk e2.etype - | NNan , NNan -> - unify ctx e1.etype t_int (pos e1); - unify ctx e2.etype t_int (pos e2); - emk t_int) - | ">>" - | ">>>" - | "<<" - | "and" - | "or" - | "xor" -> - unify ctx e1.etype t_int (pos e1); - unify ctx e2.etype t_int (pos e2); - emk t_int - | "&&" - | "||" -> - unify ctx e1.etype t_bool (pos e1); - unify ctx e2.etype t_bool (pos e2); - emk t_bool - | "<" - | "<=" - | ">" - | ">=" - | "==" - | "!=" - | "===" - | "!==" -> - unify ctx e2.etype e1.etype (pos e2); - emk t_bool - | ":=" -> - (match e1.edecl with - | TArray _ -> - unify ctx e2.etype e1.etype (pos e2); - emk t_void - | TField (e,f) -> - (match tlinks false e.etype with - | TRecord fl -> - let _ , mut , _ = (try List.find (fun (f2,_,_) -> f2 = f) fl with Not_found -> assert false) in - if mut = Immutable then error (Custom ("Field " ^ f ^ " is not mutable")) (pos e1); - unify ctx e2.etype e1.etype (pos e2); - emk t_void - | _ -> assert false); - | _ -> - let t , pt = t_poly ctx.gen "ref" in - unify ctx e2.etype pt (pos e2); - unify ctx e1.etype t (pos e1); - emk t_void) - | "::" -> - let t , pt = t_poly ctx.gen "list" in - unify ctx e1.etype pt (pos e1); - unify ctx e2.etype t (pos e2); - let c = mk (TConst (TConstr "::")) (t_mono ctx.gen) p in - mk (TCall (c,[e1;e2])) t p - | _ -> - error (Custom ("Invalid operation " ^ op)) p - -let type_unop ctx op e p = - let emk t = mk (TUnop (op,e)) t p in - match op with - | "&" -> - let p , pt = t_poly ctx.gen "ref" in - unify ctx e.etype pt (pos e); - emk p - | "*" -> - let p , pt = t_poly ctx.gen "ref" in - unify ctx e.etype p (pos e); - emk pt - | "!" -> - unify ctx e.etype t_bool (pos e); - emk t_bool - | "-" -> - (match addable false e with - | NInt -> emk t_int - | NFloat -> emk t_float - | _ -> - unify ctx e.etype t_int (pos e); - emk t_int) - | _ -> - assert false - -let rec type_arg ctx h binds p = function - | ATyped (a,t) -> - let n , ta = type_arg ctx h binds p a in - unify ctx ta (type_type ~h ctx t p) p; - n , ta - | ANamed s -> - s , t_mono ctx.gen - | ATuple al -> - let aname = "@t" ^ string_of_int (genid ctx.gen) in - let nl , tl = List.split (List.map (type_arg ctx h binds p) al) in - let k = ref 0 in - List.iter (fun n -> - if n <> "_" then binds := (aname,!k,n) :: !binds; - incr k; - ) nl; - aname , mk_tup ctx.gen tl - -let register_function ctx isrec name pl e rt p = - if ctx.functions = [] then ctx.mink <- !(ctx.gen); - let pl = (match pl with [] -> [ATyped (ANamed "_",EType (None,[],"void"))] | _ -> pl) in - let expr = ref (mk (TConst TVoid) t_void p) in - let h = Hashtbl.create 0 in - let binds = ref [] in - let el = List.map (type_arg ctx h binds p) pl in - let name = (match name with None -> "_" | Some n -> n) in - let e = (match List.rev !binds with - | [] -> e - | l -> - EBlock (List.fold_left (fun acc (v,n,v2) -> - (EVar ([v2,None], (ETupleGet ((EConst (Ident v),p),n),p)) , p) :: acc - ) [e] l) , p - ) in - let rt = (match rt with - | None -> t_mono ctx.gen - | Some rt -> type_type ~h ctx rt p - ) in - let ft = mk_fun ctx.gen (List.map snd el) rt in - ctx.functions <- (isrec,name,expr,ft,el,e,rt,p) :: ctx.functions; - if isrec then add_local ctx name ft; - mk (TMut expr) (if name = "_" then ft else t_void) p - -let type_format ctx s p = - let types = ref [] in - let percent = ref false in - for i = 0 to String.length s - 1 do - let c = String.get s i in - if !percent then begin - percent := false; - match c with - | '%' -> - () - | 'x' | 'X' | 'd' -> - types := t_int :: !types - | 'f' -> - types := t_float :: !types - | 's' -> - types := t_string :: !types - | 'b' -> - types := t_bool :: !types - | 'c' -> - types := t_char :: !types - | '0'..'9' | '.' -> - percent := true - | _ -> - error (Custom "Invalid % sequence") p - end else - match c with - | '%' -> - percent := true - | _ -> - () - done; - if !percent then error (Custom "Invalid % sequence") p; - match !types with - | [] -> t_void - | [x] -> x - | l -> mk_tup ctx.gen (List.rev l) - -let rec type_functions ctx = - let l = ctx.functions in - if l <> [] then - let mink = ctx.mink in - ctx.functions <- []; - let l = List.map (fun (isrec,name,expr,ft,el,e,rt,p) -> - let locals = save_locals ctx in - let func = ctx.curfunction in - if name <> "_" then begin - let fname = s_path ctx.current.path name in - if !verbose then prerr_endline ("Typing " ^ fname); - ctx.curfunction <- fname; - end; - List.iter (fun (p,pt) -> - add_local ctx p pt - ) el; - let e = type_expr ctx e in - restore_locals ctx locals; - ctx.curfunction <- func; - let ft2 = mk_fun ctx.gen (List.map snd el) e.etype in - unify ctx ft ft2 p; - expr := mk (TFunction (isrec,name,el,e)) ft2 p; - if not isrec then add_local ctx name ft; - ft2 - ) (List.rev l) in - List.iter (polymorphize ctx.gen mink) l - -and type_expr ctx (e,p) = - match e with - | EConst c -> - type_constant ctx c p - | EBlock [] -> - mk (TConst TVoid) t_void p - | EBlock (e :: l) -> - let locals = save_locals ctx in - let e = type_block ctx e in - let el , t = List.fold_left (fun (l,t) e -> - unify ctx t t_void (List.hd l).epos; - let e = type_block ctx e in - e :: l , e.etype - ) ([e] , e.etype) l in - type_functions ctx; - restore_locals ctx locals; - mk (TBlock (List.rev el)) t p - | EApply (e,el) -> - type_expr ctx (ECall (e,el),p) - | ECall ((EConst (Ident "open"),_),[EConst (Module (m,Constr modname)),p]) -> - ctx.opens <- get_module ctx (m @ [modname]) p :: ctx.opens; - mk (TConst TVoid) t_void p - | ECall ((EConst (Ident "open"),_),[EConst (Constr modname),p]) -> - ctx.opens <- get_module ctx [modname] p :: ctx.opens; - mk (TConst TVoid) t_void p - | ECall ((EConst (Ident "assert"),_) as a,[]) -> - let line = Mllexer.get_error_line p in - type_expr ctx (ECall (a,[EConst (String p.pfile),p;EConst (Int line),p]),p) - | ECall ((EConst (Ident "invalid_arg"),_) as a,[]) -> - type_expr ctx (ECall (a,[EConst (String ctx.curfunction),p]),p) - | ECall ((EConst (Constr "TYPE"),_),[e]) -> - let e = type_expr ctx e in - prerr_endline ("type : " ^ s_type e.etype); - mk (TParenthesis e) t_void p - | ECall (e,el) -> - let e = type_expr ctx e in - let el = (match el with [] -> [ETupleDecl [],p] | _ -> el) in - let el = List.map (type_expr ctx) el in - (match etype false e with - | TFun (args,r) -> - let rec loop acc expr l tl r = - match l , tl with - | e :: l , t :: tl -> - (match tlinks true t with - | TNamed (["format"],[param],_) -> - (match e.edecl with - | TConst (TString s) -> - let tfmt = type_format ctx s e.epos in - unify ctx param tfmt e.epos; - | _ -> - (match tlinks true e.etype with - | TNamed (["format"],[param2],_) -> - unify ctx param2 param e.epos - | _ -> - error (Custom "Constant string required for format") e.epos)) - | _ -> - unify ctx e.etype t (pos e)); - loop (e :: acc) expr l tl r - | [] , [] -> - mk (TCall (expr,List.rev acc)) r p - | [] , tl -> - mk (TCall (expr,List.rev acc)) (mk_fun ctx.gen tl r) p - | el , [] -> - match tlinks false r with - | TFun (args,r2) -> loop [] (mk (TCall (expr,List.rev acc)) r p) el args r2 - | _ -> error (Custom "Too many arguments") p - in - loop [] e el args r - | _ -> - let r = t_mono ctx.gen in - let f = mk_fun ctx.gen (List.map (fun e -> e.etype) el) r in - unify ctx e.etype f p; - mk (TCall (e,el)) r p - ); - | EField (e,s) -> - let e = type_expr ctx e in - let t = (match etype false e with - | TRecord fl -> - (try - let _ , _ , t = List.find (fun (s2,_,_) -> s = s2) fl in - t - with - Not_found -> error (Have_no_field (e.etype,s)) p) - | _ -> - let r , t , _ = get_record ctx s p in - unify ctx e.etype r (pos e); - t - ) in - mk (TField (e,s)) t p - | EArray (e,ei) -> - let e = type_expr ctx e in - let ei = type_expr ctx ei in - unify ctx ei.etype t_int (pos ei); - let t , pt = t_poly ctx.gen "array" in - unify ctx e.etype t (pos e); - mk (TArray (e,ei)) pt p - | EVar _ -> - error (Custom "Variable declaration not allowed outside a block") p - | EIf (e,e1,None) -> - let e = type_expr ctx e in - unify ctx e.etype t_bool (pos e); - let e1 = type_expr ctx e1 in - unify ctx e1.etype t_void (pos e1); - mk (TIf (e,e1,None)) t_void p - | EIf (e,e1,Some e2) -> - let e = type_expr ctx e in - unify ctx e.etype t_bool (pos e); - let e1 = type_expr ctx e1 in - let e2 = type_expr ctx e2 in - unify ctx e2.etype e1.etype (pos e2); - mk (TIf (e,e1,Some e2)) e1.etype p - | EWhile (e1,e2) -> - let e1 = type_expr ctx e1 in - unify ctx e1.etype t_bool (pos e1); - let e2 = type_expr ctx e2 in - unify ctx e2.etype t_void (pos e2); - mk (TWhile (e1,e2)) t_void p - | EFunction (isrec,name,pl,e,rt) -> - let r = register_function ctx isrec name pl e rt p in - type_functions ctx; - r - | EBinop (op,e1,e2) -> - type_binop ctx op (type_expr ctx e1) (type_expr ctx e2) p - | ETypeAnnot (e,t) -> - let e = type_expr ctx e in - let t = type_type ctx t p in - unify ctx e.etype t (pos e); - mk e.edecl t p - | ETupleDecl [] -> - mk (TConst TVoid) t_void p - | ETupleDecl [e] -> - let e = type_expr ctx e in - mk (TParenthesis e) e.etype (pos e) - | ETupleDecl el -> - let el = List.map (type_expr ctx) el in - mk (TTupleDecl el) (mk_tup ctx.gen (List.map (fun e -> e.etype) el)) p - | ETypeDecl (params,tname,decl) -> - let fullname = (match ctx.current.path with ["Core"] -> [tname] | p -> p @ [tname]) in - let t , tl , h = - try - let t , tl , h = Hashtbl.find ctx.tmptypes tname in - if decl <> EAbstract then Hashtbl.remove ctx.tmptypes tname; - if List.length tl <> List.length params then error (Custom ("Invalid number of parameters for type " ^ tname)) p; - t , tl , h - with - Not_found -> - if Hashtbl.mem ctx.current.types tname then error (Custom ("Invalid type redefinition of type " ^ tname)) p; - let h = Hashtbl.create 0 in - let tl = List.map (fun p -> - let t = t_mono ctx.gen in - Hashtbl.add h p t; - t - ) params in - let t = { - tid = -1; - texpr = TNamed (fullname,tl,t_abstract); - } in - Hashtbl.add ctx.current.types tname t; - if decl = EAbstract then Hashtbl.add ctx.tmptypes tname (t,tl,h); - t , tl , h - in - let t2 = (match decl with - | EAbstract -> t_abstract - | EAlias t -> type_type ~allow:false ~h ctx t p - | ERecord fields -> - let fields = List.map (fun (f,m,ft) -> - let ft = type_type ~allow:false ~h ctx ft p in - let m = (if m then Mutable else Immutable) in - Hashtbl.add ctx.current.records f (t,ft,m); - f , m , ft - ) fields in - mk_record ctx.gen fields - | EUnion constr -> - let constr = List.map (fun (c,ft) -> - let ft = (match ft with - | None -> t_abstract - | Some ft -> type_type ~allow:false ~h ctx ft p - ) in - Hashtbl.add ctx.current.constrs c (t,ft); - c , ft - ) constr in - mk_union ctx.gen constr - ) in - t.tid <- if t2.tid = -1 && params = [] then -1 else genid ctx.gen; - t.texpr <- TNamed (fullname,tl,t2); - polymorphize ctx.gen 0 t; - mk (TTypeDecl t) t_void p - | ERecordDecl fl -> - let s , _ = (try List.hd fl with _ -> assert false) in - let r , _ , _ = get_record ctx s p in - let fll = (match tlinks false r with - | TRecord fl -> fl - | _ -> assert false - ) in - let fl2 = ref fll in - let rec loop f = function - | [] -> - if List.exists (fun (f2,_,_) -> f = f2) fll then - error (Custom ("Duplicate declaration for field " ^ f)) p - else - error (Have_no_field (r,f)) p - | (f2,_,ft) :: l when f = f2 -> ft , l - | x :: l -> - let t , l = loop f l in - t , x :: l - in - let el = List.map (fun (f,e) -> - let ft , fl2b = loop f !fl2 in - fl2 := fl2b; - let e = type_expr ctx e in - unify ctx e.etype ft (pos e); - (f , e) - ) fl in - List.iter (fun (f,_,_) -> - error (Custom ("Missing field " ^ f ^ " in record declaration")) p; - ) !fl2; - mk (TRecordDecl el) r p - | EErrorDecl (name,t) -> - let t = (match t with None -> t_abstract | Some t -> type_type ~allow:false ctx t p) in - Hashtbl.add ctx.current.constrs name (t_error,t); - mk (TErrorDecl (name,t)) t_void p - | EUnop (op,e) -> - type_unop ctx op (type_expr ctx e) p - | EMatch (e,cl) -> - let e = type_expr ctx e in - let is_stream = List.for_all (fun (l,_,_) -> List.for_all (fun (p,_) -> match p with PStream _ -> true | _ -> false) l) cl in - let partial , m , t = type_match ctx e.etype cl p in - if not is_stream && partial then error (Custom "This matching is not complete") p; - mk (TMatch (e,m,is_stream)) t p - | ETry (e,cl) -> - let e = type_expr ctx e in - let _ , m , t = type_match ctx t_error cl p in - unify ctx t e.etype p; - mk (TTry (e,m)) t p - | ETupleGet (e,n) -> - let e = type_expr ctx e in - let try_unify et = - let t = Array.init (n + 1) (fun _ -> t_mono ctx.gen) in - unify ctx et (mk_tup ctx.gen (Array.to_list t)) p; - t.(n) - in - let rec loop et = - match et.texpr with - | TLink et -> loop et - | TTuple l -> (try List.nth l n with _ -> try_unify et) - | _ -> try_unify et - in - mk (TTupleGet (e,n)) (loop e.etype) p - -and type_block ctx ((e,p) as x) = - match e with - | EVar (vl,e) -> - type_functions ctx; - let e = type_expr ctx e in - let make v t = - let t = (match t with - | None -> t_mono ctx.gen - | Some t -> type_type ctx t p - ) in - add_local ctx v t; - t - in - let t = (match vl with - | [] -> assert false - | [v,t] -> make v t - | _ -> - mk_tup ctx.gen (List.map (fun (v,t) -> make v t) vl) - ) in - unify ctx t e.etype (pos e); - mk (TVar (List.map fst vl,e)) t_void p - | EFunction (true,name,pl,e,rt) -> - register_function ctx true name pl e rt p - | _ -> - type_functions ctx; - type_expr ctx x - -and type_pattern (ctx:context) h ?(h2 = Hashtbl.create 0) set add (pat,p) = - let pvar add s = - if SSet.mem s !set then error (Custom "This variable is several time in the pattern") p; - set := SSet.add s !set; - try - Hashtbl.find h s - with - Not_found -> - let t = t_mono ctx.gen in - Hashtbl.add h s t; - if add then add_local ctx s t; - t - in - let pt , pat = (match pat with - | PConst c -> - (match c with - | Int n -> t_int - | Float s -> t_float - | String s -> t_string - | Char c -> t_char - | Bool b -> t_bool - | Ident _ | Constr _ | Module _ -> - assert false) , pat - | PTuple [p] -> - let pt , pat = type_pattern ctx h ~h2 set add p in - pt , fst pat - | PTuple pl -> - let pl , patl = List.split (List.map (type_pattern ctx h ~h2 set add) pl) in - mk_tup ctx.gen pl , PTuple patl - | PRecord fl -> - let s = (try fst (List.hd fl) with _ -> assert false) in - let r , _ , _ = get_record ctx s p in - let fl = (match tlinks false r with - | TRecord rl -> - List.map (fun (f,pat) -> - let pt , pat = type_pattern ctx h ~h2 set add pat in - let t = (try - let _ , _ , t = List.find (fun (f2,_,_) -> f = f2 ) rl in t - with Not_found -> - error (Have_no_field (r,f)) p - ) in - unify ctx pt t (snd pat); - f , pat - ) fl - | _ -> - assert false - ) in - r , PRecord fl - | PIdent s -> - (if s = "_" then t_mono ctx.gen else pvar add s) , pat - | PConstr (path,s,param) -> - let tparam , param = (match param with - | None -> None , None - | Some ((_,p) as param) -> - let t , pat = type_pattern ctx h ~h2 set add param in - Some (p,t) , Some pat - ) in - let path , ut , t = get_constr ctx path s p in - (match t.texpr , tparam with - | TAbstract , None -> duplicate ctx.gen ut , PConstr (path,s,param) - | TAbstract , Some _ -> error (Custom "Constructor does not take parameters") p - | _ , None -> error (Custom "Constructor require parameters") p - | _ , Some (p,pt) -> - let h = Hashtbl.create 0 in - let ut = duplicate ctx.gen ~h ut in - let t = duplicate ctx.gen ~h t in - let param , pt = (match param with - | Some (PTuple l,p) when not (is_tuple t) -> Some (PTuple [(PTuple l,p)],p) , mk_fun ctx.gen [pt] ut - | Some (PIdent "_",p) -> param , pt - | _ -> param , (match pt.texpr with TTuple l -> mk_fun ctx.gen l ut | _ -> mk_fun ctx.gen [pt] ut) - ) in - let t = (match t.texpr with TTuple l -> mk_fun ctx.gen l ut | _ -> mk_fun ctx.gen [t] ut) in - unify ctx t pt p; - ut , PConstr (path,s,param)); - | PAlias (s,pat) -> - let pt , pat = type_pattern ctx h ~h2 set false pat in - let t = pvar false s in - unify ctx pt t (snd pat); - t , PAlias (s,pat) - | PTyped (pat,t) -> - let pt , pat = type_pattern ctx h ~h2 set add pat in - unify ctx pt (type_type ~h:h2 ctx t p) p; - pt , PTyped (pat,t) - | PStream (l,k) -> - let t , polyt = t_poly ctx.gen "stream" in - let locals = save_locals ctx in - let l = List.map (fun s -> - match s with - | SPattern pat -> - let t , p = type_pattern ctx h ~h2 set true pat in - unify ctx t polyt (snd p); - SPattern p - | SExpr ([v],e) -> - let e = type_expr ctx e in - let t = pvar true v in - unify ctx t e.etype e.epos; - SMagicExpr((PIdent v,e.epos),Obj.magic e) - | SExpr (vl,e) -> - let e = type_expr ctx e in - let tl = List.map (pvar true) vl in - unify ctx (mk_tup ctx.gen tl) e.etype e.epos; - let tup = PTuple (List.map (fun v -> PIdent v, e.epos) vl) in - SMagicExpr((tup,e.epos),Obj.magic e) - | SMagicExpr _ -> - assert false - ) l in - restore_locals ctx locals; - t , PStream (l,k) - ) in - pt , (pat,p) - -and type_match ctx t cl p = - let ret = t_mono ctx.gen in - let cl = List.map (fun (pl,wh,pe) -> - let first = ref true in - let h = Hashtbl.create 0 in - let mainset = ref SSet.empty in - let pl = List.map (fun pat -> - let set = ref SSet.empty in - let pt , pat = type_pattern ctx h set false pat in - if !first then begin - first := false; - mainset := !set; - end else begin - let s1 = SSet.diff !set !mainset in - let s2 = SSet.diff !mainset !set in - SSet.iter (fun s -> error (Custom ("Variable " ^ s ^ " must occur in all patterns")) p) (SSet.union s1 s2); - end; - unify ctx pt t p; - pat - ) pl in - let locals = save_locals ctx in - Hashtbl.iter (fun v t -> add_local ctx v t) h; - let wh = (match wh with - | None -> None - | Some e -> - let e = type_expr ctx e in - unify ctx e.etype t_bool e.epos; - Some e - ) in - let pe = type_expr ctx pe in - unify ctx pe.etype ret (pos pe); - restore_locals ctx locals; - pl , wh , pe - ) cl in - let rec loop cl = - match cl with - | TModule(path,TConstr c) :: l -> - let path , ut , t = get_constr ctx path c null_pos in - if ut == t_error then - false - else - (match tlinks false ut with - | TUnion (n,_) -> - n = List.length cl - | _ -> - assert false) - | TBool b :: l -> - let e = List.exists (fun c -> c = TBool (not b)) l in - prerr_endline (if e then "ok" else "notok"); - e - | TVoid :: _ -> - true - | _ :: l -> - loop cl - | [] -> - false - in - Mlmatch.fully_matched_ref := loop; - let partial , m = Mlmatch.make cl p in - partial , m , ret - -let modules ctx = - let h = Hashtbl.create 0 in - Hashtbl.iter (fun p m -> - match m.expr with - | None -> () - | Some e -> - let deps = ref (if m.path = ["Core"] || Hashtbl.mem m.deps ["Core"] then [] else [["Core"]]) in - let idents = ref [] in - Hashtbl.iter (fun _ m -> - deps := m.path :: !deps - ) m.deps; - PMap.iter (fun i t -> - idents := i :: !idents - ) m.idents; - Hashtbl.add h p (e,!deps,!idents) - ) ctx.modules; - h - -let open_file ctx file p = - let rec loop = function - | [] -> error (Custom ("File not found " ^ file)) p - | p :: l -> - try - let f = p ^ file in - f , open_in f - with - _ -> loop l - in - loop ctx.classpath - -let load_module ctx m p = - try - Hashtbl.find ctx.modules m - with - Not_found -> - let file , ch = open_file ctx (String.concat "/" m ^ ".nml") p in - let is_core , core = (try - false , Hashtbl.find ctx.modules ["Core"] - with Not_found -> - true , ctx.current - ) in - let ctx = { ctx with - tmptypes = Hashtbl.create 0; - functions = []; - opens = [core]; - current = (if is_core then ctx.current else { - path = m; - constrs = Hashtbl.create 0; - records = Hashtbl.create 0; - types = Hashtbl.create 0; - expr = None; - idents = PMap.empty; - deps = Hashtbl.create 0; - }) - } in - Hashtbl.add ctx.modules m ctx.current; - let ast = Mlparser.parse (Lexing.from_channel ch) file in - if !verbose then print_endline ("Parsed " ^ file); - let e = (match ast with - | EBlock (e :: l) , p -> - let e = type_block ctx e in - let el , t = List.fold_left (fun (l,t) e -> - let e = type_block ctx e in - e :: l , e.etype - ) ([e] , e.etype) l in - type_functions ctx; - mk (TBlock (List.rev el)) t p - | _ -> - type_expr ctx ast - ) in - ctx.current.expr <- Some e; - if !verbose then print_endline ("Typing done with " ^ file); - ctx.current - -let context cpath = - let ctx = { - gen = generator(); - tmptypes = Hashtbl.create 0; - modules = Hashtbl.create 0; - functions = []; - opens = []; - mink = 0; - classpath = cpath; - curfunction = "anonymous"; - current = { - path = ["Core"]; - expr = None; - idents = PMap.empty; - constrs = Hashtbl.create 0; - types = Hashtbl.create 0; - deps = Hashtbl.create 0; - records = Hashtbl.create 0; - }; - } in - let add_type args name t = - ignore(type_expr ctx (ETypeDecl (args,name,t) , null_pos)); - in - let add_variable name t = - ctx.current.idents <- PMap.add name t ctx.current.idents - in - add_type [] "bool" EAbstract; - add_type ["a"] "list" (EUnion ["[]",None;"::",Some (ETuple [ - EPoly "a"; - EType (Some (EPoly "a"),[],"list"); - ])]); - add_variable "neko" (mk_fun ctx.gen [t_polymorph ctx.gen] (t_polymorph ctx.gen)); - let core = load_module ctx ["Core"] null_pos in - ctx - -;; -Mlmatch.error_ref := (fun msg p -> error (Custom msg) p); -load_module_ref := load_module \ No newline at end of file diff --git a/libs/include/ocaml/neko/bytecode.ml b/libs/include/ocaml/neko/bytecode.ml deleted file mode 100644 index dfbb7380..00000000 --- a/libs/include/ocaml/neko/bytecode.ml +++ /dev/null @@ -1,505 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -type opcode = - (* getters *) - | AccNull - | AccTrue - | AccFalse - | AccThis - | AccInt of int - | AccStack of int - | AccGlobal of int - | AccEnv of int - | AccField of string - | AccArray - | AccIndex of int - | AccBuiltin of string - (* setters *) - | SetStack of int - | SetGlobal of int - | SetEnv of int - | SetField of string - | SetArray - | SetIndex of int - | SetThis - (* stack ops *) - | Push - | Pop of int - | Call of int - | ObjCall of int - | Jump of int - | JumpIf of int - | JumpIfNot of int - | Trap of int - | EndTrap - | Ret of int - | MakeEnv of int - | MakeArray of int - (* value ops *) - | Bool - | IsNull - | IsNotNull - | Add - | Sub - | Mult - | Div - | Mod - | Shl - | Shr - | UShr - | Or - | And - | Xor - | Eq - | Neq - | Gt - | Gte - | Lt - | Lte - | Not - | TypeOf - | Compare - | Hash - | New - -type global = - | GlobalVar of string - | GlobalFunction of int * int - | GlobalString of string - | GlobalFloat of string - -exception Invalid_file - -let trap_stack_delta = 5 -let max_call_args = 5 - -let hash_field s = - let acc = ref 0 in - for i = 0 to String.length s - 1 do - acc := 223 * !acc + Char.code (String.unsafe_get s i) - done; - acc := !acc land ((1 lsl 31) - 1); - !acc - -let op_param = function - | AccInt _ - | AccStack _ - | AccGlobal _ - | AccEnv _ - | AccField _ - | AccBuiltin _ - | SetStack _ - | SetGlobal _ - | SetEnv _ - | SetField _ - | Pop _ - | Call _ - | ObjCall _ - | Jump _ - | JumpIf _ - | JumpIfNot _ - | Trap _ - | MakeEnv _ - | MakeArray _ - | Ret _ - | AccIndex _ - | SetIndex _ - -> true - | AccNull - | AccTrue - | AccFalse - | AccThis - | AccArray - | SetArray - | SetThis - | Push - | EndTrap - | Bool - | Add - | Sub - | Mult - | Div - | Mod - | Shl - | Shr - | UShr - | Or - | And - | Xor - | Eq - | Neq - | Gt - | Gte - | Lt - | Lte - | IsNull - | IsNotNull - | Not - | TypeOf - | Compare - | Hash - | New - -> false - -let code_tables ops = - let ids = Hashtbl.create 0 in - Array.iter (function - | AccField s - | SetField s - | AccBuiltin s -> - let id = hash_field s in - (try - let f = Hashtbl.find ids id in - if f <> s then failwith ("Field hashing conflict " ^ s ^ " and " ^ f); - with - Not_found -> - Hashtbl.add ids id s) - | _ -> () - ) ops; - let p = ref 0 in - let pos = Array.create (Array.length ops + 1) 0 in - Array.iteri (fun i op -> - Array.unsafe_set pos i !p; - p := !p + (if op_param op then 2 else 1); - ) ops; - Array.unsafe_set pos (Array.length ops) !p; - ids , pos , !p - -let write ch (globals,ops) = - IO.nwrite ch "NEKO"; - let globals = DynArray.of_array globals in - let ids , pos , csize = code_tables ops in - IO.write_i32 ch (DynArray.length globals); - IO.write_i32 ch (Hashtbl.length ids); - IO.write_i32 ch csize; - DynArray.iter (function - | GlobalVar s -> IO.write_byte ch 1; IO.nwrite ch s; IO.write ch '\000'; - | GlobalFunction (p,nargs) -> IO.write_byte ch 2; IO.write_i32 ch (pos.(p) lor (nargs lsl 24)) - | GlobalString s -> IO.write_byte ch 3; IO.write_ui16 ch (String.length s); IO.nwrite ch s - | GlobalFloat s -> IO.write_byte ch 4; IO.nwrite ch s; IO.write ch '\000' - ) globals; - Hashtbl.iter (fun _ s -> - IO.nwrite ch s; - IO.write ch '\000'; - ) ids; - Array.iteri (fun i op -> - let pop = ref None in - let opid = (match op with - | AccNull -> 0 - | AccTrue -> 1 - | AccFalse -> 2 - | AccThis -> 3 - | AccInt n -> pop := Some n; 4 - | AccStack n -> pop := Some n; 5 - | AccGlobal n -> pop := Some n; 6 - | AccEnv n -> pop := Some n; 7 - | AccField s -> pop := Some (hash_field s); 8 - | AccArray -> 9 - | AccIndex n -> pop := Some n; 10 - | AccBuiltin s -> pop := Some (hash_field s); 11 - | SetStack n -> pop := Some n; 12 - | SetGlobal n -> pop := Some n; 13 - | SetEnv n -> pop := Some n; 14 - | SetField s -> pop := Some (hash_field s); 15 - | SetArray -> 16 - | SetIndex n -> pop := Some n; 17 - | SetThis -> 18 - | Push -> 19 - | Pop n -> pop := Some n; 20 - | Call n -> pop := Some n; 21 - | ObjCall n -> pop := Some n; 22 - | Jump n -> pop := Some (pos.(i+n) - pos.(i)); 23 - | JumpIf n -> pop := Some (pos.(i+n) - pos.(i)); 24 - | JumpIfNot n -> pop := Some (pos.(i+n) - pos.(i)); 25 - | Trap n -> pop := Some (pos.(i+n) - pos.(i)); 26 - | EndTrap -> 27 - | Ret n -> pop := Some n; 28 - | MakeEnv n -> pop := Some n; 29 - | MakeArray n -> pop := Some n; 30 - | Bool -> 31 - | IsNull -> 32 - | IsNotNull -> 33 - | Add -> 34 - | Sub -> 35 - | Mult -> 36 - | Div -> 37 - | Mod -> 38 - | Shl -> 39 - | Shr -> 40 - | UShr -> 41 - | Or -> 42 - | And -> 43 - | Xor -> 44 - | Eq -> 45 - | Neq -> 46 - | Gt -> 47 - | Gte -> 48 - | Lt -> 49 - | Lte -> 50 - | Not -> 51 - | TypeOf -> 52 - | Compare -> 53 - | Hash -> 54 - | New -> 55 - ) in - match !pop with - | None -> IO.write_byte ch (opid lsl 2) - | Some n when opid < 32 && (n = 0 || n = 1) -> IO.write_byte ch ((opid lsl 3) lor (n lsl 2) lor 1) - | Some n when n >= 0 && n <= 0xFF -> IO.write_byte ch ((opid lsl 2) lor 2); IO.write_byte ch n - | Some n -> IO.write_byte ch ((opid lsl 2) lor 3); IO.write_i32 ch n - ) ops - -let read_string ch = - let b = Buffer.create 5 in - let rec loop() = - let c = IO.read ch in - if c = '\000' then - Buffer.contents b - else begin - Buffer.add_char b c; - loop() - end; - in - loop() - -let read ch = - try - let head = IO.nread ch 4 in - if head <> "NEKO" then raise Invalid_file; - let nglobals = IO.read_i32 ch in - let nids = IO.read_i32 ch in - let csize = IO.read_i32 ch in - if nglobals < 0 || nglobals > 0xFFFF || nids < 0 || nids > 0xFFFF || csize < 0 || csize > 0xFFFFFF then raise Invalid_file; - let globals = Array.init nglobals (fun _ -> - match IO.read_byte ch with - | 1 -> GlobalVar (read_string ch) - | 2 -> let v = IO.read_i32 ch in GlobalFunction (v land 0xFFFFFF, v lsr 24) - | 3 -> let len = IO.read_ui16 ch in GlobalString (IO.nread ch len) - | 4 -> GlobalFloat (read_string ch) - | _ -> raise Invalid_file - ) in - let ids = Hashtbl.create 0 in - let rec loop n = - if n = 0 then - () - else - let s = read_string ch in - let id = hash_field s in - try - let s2 = Hashtbl.find ids id in - if s <> s2 then raise Invalid_file; - with - Not_found -> - Hashtbl.add ids id s; - loop (n-1) - in - loop nids; - let pos = Array.create (csize+1) (-1) in - let cpos = ref 0 in - let jumps = ref [] in - let ops = DynArray.create() in - while !cpos < csize do - let code = IO.read_byte ch in - let op , p = (match code land 3 with - | 0 -> code lsr 2 , 0 - | 1 -> code lsr 3 , ((code lsr 2) land 1) - | 2 -> code lsr 2 , IO.read_byte ch - | 3 -> code lsr 2 , IO.read_i32 ch - | _ -> assert false - ) in - let op = (match op with - | 0 -> AccNull - | 1 -> AccTrue - | 2 -> AccFalse - | 3 -> AccThis - | 4 -> AccInt p - | 5 -> AccStack p - | 6 -> AccGlobal p - | 7 -> AccEnv p - | 8 -> AccField (try Hashtbl.find ids p with Not_found -> raise Invalid_file) - | 9 -> AccArray - | 10 -> AccIndex p - | 11 -> AccBuiltin (try Hashtbl.find ids p with Not_found -> raise Invalid_file) - | 12 -> SetStack p - | 13 -> SetGlobal p - | 14 -> SetEnv p - | 15 -> SetField (try Hashtbl.find ids p with Not_found -> raise Invalid_file) - | 16 -> SetArray - | 17 -> SetIndex p - | 18 -> SetThis - | 19 -> Push - | 20 -> Pop p - | 21 -> Call p - | 22 -> ObjCall p - | 23 -> jumps := (!cpos , DynArray.length ops) :: !jumps; Jump p - | 24 -> jumps := (!cpos , DynArray.length ops) :: !jumps; JumpIf p - | 25 -> jumps := (!cpos , DynArray.length ops) :: !jumps; JumpIfNot p - | 26 -> jumps := (!cpos , DynArray.length ops) :: !jumps; Trap p - | 27 -> EndTrap - | 28 -> Ret p - | 29 -> MakeEnv p - | 30 -> MakeArray p - | 31 -> Bool - | 32 -> IsNull - | 33 -> IsNotNull - | 34 -> Add - | 35 -> Sub - | 36 -> Mult - | 37 -> Div - | 38 -> Mod - | 39 -> Shl - | 40 -> Shr - | 41 -> UShr - | 42 -> Or - | 43 -> And - | 44 -> Xor - | 45 -> Eq - | 46 -> Neq - | 47 -> Gt - | 48 -> Gte - | 49 -> Lt - | 50 -> Lte - | 51 -> Not - | 52 -> TypeOf - | 53 -> Compare - | 54 -> Hash - | 55 -> New - | _ -> raise Invalid_file - ) in - pos.(!cpos) <- DynArray.length ops; - cpos := !cpos + (if op_param op then 2 else 1); - DynArray.add ops op; - done; - if !cpos <> csize then raise Invalid_file; - pos.(!cpos) <- DynArray.length ops; - let pos_index i sadr = - let idx = pos.(sadr) in - if idx = -1 then raise Invalid_file; - idx - i - in - List.iter (fun (a,i) -> - DynArray.set ops i (match DynArray.get ops i with - | Jump p -> Jump (pos_index i (a+p)) - | JumpIf p -> JumpIf (pos_index i (a+p)) - | JumpIfNot p -> JumpIfNot (pos_index i (a+p)) - | Trap p -> Trap (pos_index i (a+p)) - | _ -> assert false) - ) !jumps; - Array.iteri (fun i g -> - match g with - | GlobalFunction (f,n) -> globals.(i) <- GlobalFunction (pos_index 0 f,n) - | _ -> () - ) globals; - globals , DynArray.to_array ops - with - | IO.No_more_input - | IO.Overflow _ -> raise Invalid_file - -let escape str = - String.escaped str - -let dump ch (globals,ops) = - let ids, pos , csize = code_tables ops in - IO.printf ch "nglobals : %d\n" (Array.length globals); - IO.printf ch "nfields : %d\n" (Hashtbl.length ids); - IO.printf ch "codesize : %d ops , %d total\n" (Array.length ops) csize; - IO.printf ch "GLOBALS =\n"; - let marks = Array.create csize false in - Array.iteri (fun i g -> - IO.printf ch " global %d : %s\n" i - (match g with - | GlobalVar s -> "var " ^ s - | GlobalFunction (p,n) -> - if p >= 0 && p < csize then marks.(p) <- true; - "function " ^ string_of_int p ^ " nargs " ^ string_of_int n - | GlobalString s -> "string \"" ^ escape s ^ "\"" - | GlobalFloat s -> "float " ^ s) - ) globals; - IO.printf ch "FIELDS =\n"; - Hashtbl.iter (fun h f -> - IO.printf ch " %s%s%.8X\n" f (if String.length f >= 24 then " " else String.make (24 - String.length f) ' ') h; - ) ids; - IO.printf ch "CODE =\n"; - let str s i = s ^ " " ^ string_of_int i in - let bpos = ref 0 in - Array.iteri (fun pos op -> - if marks.(pos) then IO.write ch '\n'; - IO.printf ch "%.6X %6d %s\n" (!bpos) pos (match op with - | AccNull -> "AccNull" - | AccTrue -> "AccTrue" - | AccFalse -> "AccFalse" - | AccThis -> "AccThis" - | AccInt i -> str "AccInt" i - | AccStack i -> str "AccStack" i - | AccGlobal i -> str "AccGlobal" i - | AccEnv i -> str "AccEnv" i - | AccField s -> "AccField " ^ s - | AccArray -> "AccArray" - | AccIndex i -> str "AccIndex" i - | AccBuiltin s -> "AccBuiltin " ^ s - | SetStack i -> str "SetStack" i - | SetGlobal i -> str "SetGlobal" i - | SetEnv i -> str "SetEnv" i - | SetField f -> "SetField " ^ f - | SetArray -> "SetArray" - | SetIndex i -> str "SetIndex" i - | SetThis -> "SetThis" - | Push -> "Push" - | Pop i -> str "Pop" i - | Call i -> str "Call" i - | ObjCall i -> str "ObjCall" i - | Jump i -> str "Jump" (pos + i) - | JumpIf i -> str "JumpIf" (pos + i) - | JumpIfNot i -> str "JumpIfNot" (pos + i) - | Trap i -> str "Trap" (pos + i) - | EndTrap -> "EndTrap" - | Ret i -> str "Ret" i - | MakeEnv i -> str "MakeEnv" i - | MakeArray i -> str "MakeArray" i - | Bool -> "Bool" - | IsNull -> "IsNull" - | IsNotNull -> "IsNotNull" - | Add -> "Add" - | Sub -> "Sub" - | Mult -> "Mult" - | Div -> "Div" - | Mod -> "Mod" - | Shl -> "Shl" - | Shr -> "Shr" - | UShr -> "UShr" - | Or -> "Or" - | And -> "And" - | Xor -> "Xor" - | Eq -> "Eq" - | Neq -> "Neq" - | Gt -> "Gt" - | Gte -> "Gte" - | Lt -> "Lt" - | Lte -> "Lte" - | Not -> "Not" - | TypeOf -> "TypeOf" - | Compare -> "Compare" - | Hash -> "Hash" - | New -> "New" - ); - bpos := !bpos + if op_param op then 2 else 1; - ) ops; - IO.printf ch "END\n" - diff --git a/libs/include/ocaml/neko/compile.ml b/libs/include/ocaml/neko/compile.ml deleted file mode 100644 index 7841cf48..00000000 --- a/libs/include/ocaml/neko/compile.ml +++ /dev/null @@ -1,713 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Ast -open Bytecode - -type label = { - lname : string; - ltraps : int; - lstack : int; - mutable lpos : int option; - mutable lwait : (unit -> unit) list; -} - -type context = { - mutable ops : opcode DynArray.t; - mutable locals : (string,int) PMap.t; - globals : (global,int) Hashtbl.t; - gobjects : (string list,int) Hashtbl.t; - mutable env : (string,int) PMap.t; - mutable nenv : int; - mutable stack : int; - mutable loop_limit : int; - mutable limit : int; - mutable ntraps : int; - mutable breaks : ((unit -> unit) * pos) list; - mutable continues : ((unit -> unit) * pos) list; - mutable functions : (opcode DynArray.t * int * int) list; - mutable gtable : global DynArray.t; - labels : (string,label) Hashtbl.t; -} - -type error_msg = - | Custom of string - -exception Error of error_msg * pos - -let error e p = raise (Error (e,p)) - -let error_msg = function - | Custom s -> s - -let stack_delta = function - | AccNull - | AccTrue - | AccFalse - | AccThis - | AccInt _ - | AccStack _ - | AccGlobal _ - | AccEnv _ - | AccField _ - | AccBuiltin _ - | AccIndex _ - | JumpIf _ - | JumpIfNot _ - | Jump _ - | Ret _ - | SetGlobal _ - | SetStack _ - | SetEnv _ - | SetThis - | Bool - | EndTrap - | IsNull - | IsNotNull - | Not - | Hash - | TypeOf - | New - -> 0 - | Add - | Sub - | Mult - | Div - | Mod - | Shl - | Shr - | UShr - | Or - | And - | Xor - | Eq - | Neq - | Gt - | Gte - | Lt - | Lte - -> -1 - | AccArray -> -1 - | SetField _ | SetIndex _ | Compare -> -1 - | SetArray -> -2 - | Push -> 1 - | Pop x -> -x - | Call nargs -> -nargs - | ObjCall nargs -> -(nargs + 1) - | MakeEnv size | MakeArray size -> -size - | Trap _ -> trap_stack_delta - -let pos ctx = - DynArray.length ctx.ops - -let write ctx op = - ctx.stack <- ctx.stack + stack_delta op; - DynArray.add ctx.ops op - -let jmp ?cond ctx = - let p = pos ctx in - write ctx (Jump 0); - (fun() -> - DynArray.set ctx.ops p - (match cond with - | None -> Jump (pos ctx - p) - | Some true -> JumpIf (pos ctx - p) - | Some false -> JumpIfNot (pos ctx -p)) - ) - -let goto ctx p = - write ctx (Jump (p - pos ctx)) - -let global ctx g = - try - Hashtbl.find ctx.globals g - with - Not_found -> - let gid = DynArray.length ctx.gtable in - Hashtbl.add ctx.globals g gid; - DynArray.add ctx.gtable g; - gid - -let save_breaks ctx = - let oldc = ctx.continues in - let oldb = ctx.breaks in - let oldl = ctx.loop_limit in - ctx.loop_limit <- ctx.stack; - ctx.breaks <- []; - ctx.continues <- []; - ctx , oldc, oldb , oldl - -let process_continues (ctx,oldc,_,_) = - List.iter (fun (f,_) -> f()) ctx.continues; - ctx.continues <- oldc - -let process_breaks (ctx,_,oldb,oldl) = - List.iter (fun (f,_) -> f()) ctx.breaks; - ctx.loop_limit <- oldl; - ctx.breaks <- oldb - -let check_breaks ctx = - List.iter (fun (_,p) -> error (Custom "Break outside a loop") p) ctx.breaks; - List.iter (fun (_,p) -> error (Custom "Continue outside a loop") p) ctx.continues - -let rec scan_labels ctx supported e = - match fst e with - | EFunction (args,e) -> - let nargs = List.length args in - let ntraps = ctx.ntraps in - ctx.ntraps <- 0; - ctx.stack <- ctx.stack + nargs; - scan_labels ctx supported e; - ctx.stack <- ctx.stack - nargs; - ctx.ntraps <- ntraps - | EBlock _ -> - let old = ctx.stack in - Ast.iter (scan_labels ctx supported) e; - ctx.stack <- old - | EVars l -> - List.iter (fun (_,e) -> - (match e with - | None -> () - | Some e -> scan_labels ctx supported e); - ctx.stack <- ctx.stack + 1 - ) l - | ELabel l when not supported -> - error (Custom "Label is not supported in this part of the program") (snd e); - | ELabel l when Hashtbl.mem ctx.labels l -> - error (Custom ("Duplicate label " ^ l)) (snd e) - | ELabel l -> - Hashtbl.add ctx.labels l { - lname = l; - ltraps = ctx.ntraps; - lstack = ctx.stack; - lpos = None; - lwait = []; - } - | ETry (e,_,e2) -> - ctx.stack <- ctx.stack + trap_stack_delta; - ctx.ntraps <- ctx.ntraps + 1; - scan_labels ctx supported e; - ctx.stack <- ctx.stack - trap_stack_delta; - ctx.ntraps <- ctx.ntraps - 1; - ctx.stack <- ctx.stack + 1; - scan_labels ctx supported e2; - ctx.stack <- ctx.stack - 1; - | EBinop ("=",e1,e2) -> - let rec is_extended (e,_) = - match e with - | EParenthesis e -> is_extended e - | EArray _ - | EField _ -> - true - | _ -> - false - in - let ext = is_extended e1 in - if ext then ctx.stack <- ctx.stack + 1; - scan_labels ctx supported e2; - ctx.stack <- ctx.stack + 1; - scan_labels ctx supported e1; - ctx.stack <- ctx.stack - (if ext then 2 else 1); - | ECall ((EConst (Builtin x),_),el) when x <> "array" && x <> "apply" -> - Ast.iter (scan_labels ctx false) e - | ECall (_,el) -> - List.iter (fun e -> - scan_labels ctx supported e; - ctx.stack <- ctx.stack + 1; - ) el; - ctx.stack <- ctx.stack - List.length el - | EObject fl -> - ctx.stack <- ctx.stack + 2; - List.iter (fun (s,e) -> - scan_labels ctx supported e - ) fl; - ctx.stack <- ctx.stack - 2; - | EConst _ - | EContinue - | EBreak _ - | EReturn _ - | EIf _ - | EWhile _ - | EParenthesis _ - | ENext _ -> - Ast.iter (scan_labels ctx supported) e - | EBinop _ - | EArray _ - | EField _ -> - Ast.iter (scan_labels ctx false) e - -let compile_constant ctx c p = - match c with - | True -> write ctx AccTrue - | False -> write ctx AccFalse - | Null -> write ctx AccNull - | This -> write ctx AccThis - | Int n -> write ctx (AccInt n) - | Float f -> write ctx (AccGlobal (global ctx (GlobalFloat f))) - | String s -> write ctx (AccGlobal (global ctx (GlobalString s))) - | Builtin s -> - (match s with - | "tnull" -> write ctx (AccInt 0) - | "tint" -> write ctx (AccInt 1) - | "tfloat" -> write ctx (AccInt 2) - | "tbool" -> write ctx (AccInt 3) - | "tstring" -> write ctx (AccInt 4) - | "tobject" -> write ctx (AccInt 5) - | "tarray" -> write ctx (AccInt 6) - | "tfunction" -> write ctx (AccInt 7) - | "tabstract" -> write ctx (AccInt 8) - | s -> - write ctx (AccBuiltin s)) - | Ident s -> - try - let e = PMap.find s ctx.env in - write ctx (AccEnv e); - with Not_found -> try - let l = PMap.find s ctx.locals in - if l <= ctx.limit then begin - let e = ctx.nenv in - ctx.nenv <- ctx.nenv + 1; - ctx.env <- PMap.add s e ctx.env; - write ctx (AccEnv e); - end else - write ctx (AccStack (ctx.stack - l)); - with Not_found -> - let g = global ctx (GlobalVar s) in - write ctx (AccGlobal g) - -let rec compile_binop ctx op e1 e2 p = - match op with - | "=" -> - (match fst e1 with - | EConst (Ident s) -> - compile ctx e2; - (try - let e = PMap.find s ctx.env in - write ctx (SetEnv e); - with Not_found -> try - let l = PMap.find s ctx.locals in - if l <= ctx.limit then begin - let e = ctx.nenv in - ctx.nenv <- ctx.nenv + 1; - ctx.env <- PMap.add s e ctx.env; - write ctx (SetEnv e); - end else - write ctx (SetStack (ctx.stack - l)) - with - Not_found -> - let g = global ctx (GlobalVar s) in - write ctx (SetGlobal g)) - | EField (e,f) -> - compile ctx e; - write ctx Push; - compile ctx e2; - write ctx (SetField f) - | EArray (e1,(EConst (Int n),_)) -> - compile ctx e1; - write ctx Push; - compile ctx e2; - write ctx (SetIndex n) - | EArray (ea,ei) -> - compile ctx ei; - write ctx Push; - compile ctx ea; - write ctx Push; - compile ctx e2; - write ctx SetArray - | EConst This -> - compile ctx e2; - write ctx SetThis - | _ -> - error (Custom "Invalid assign") p) - | "&&" -> - compile ctx e1; - let jnext = jmp ~cond:false ctx in - compile ctx e2; - jnext() - | "||" -> - compile ctx e1; - let jnext = jmp ~cond:true ctx in - compile ctx e2; - jnext() - | _ -> - match op , e1 , e2 with - | "==" , _ , (EConst Null,_) -> - compile ctx e1; - write ctx IsNull - | "!=" , _ , (EConst Null,_) -> - compile ctx e1; - write ctx IsNotNull - | "==" , (EConst Null,_) , _ -> - compile ctx e2; - write ctx IsNull - | "!=" , (EConst Null,_) , _ -> - compile ctx e2; - write ctx IsNotNull - | _ -> - compile ctx e1; - write ctx Push; - compile ctx e2; - match op with - | "+" -> write ctx Add - | "-" -> write ctx Sub - | "/" -> write ctx Div - | "*" -> write ctx Mult - | "%" -> write ctx Mod - | "<<" -> write ctx Shl - | ">>" -> write ctx Shr - | ">>>" -> write ctx UShr - | "|" -> write ctx Or - | "&" -> write ctx And - | "^" -> write ctx Xor - | "==" -> write ctx Eq - | "!=" -> write ctx Neq - | ">" -> write ctx Gt - | ">=" -> write ctx Gte - | "<" -> write ctx Lt - | "<=" -> write ctx Lte - | _ -> error (Custom "Unknown operation") p - -and compile_function ctx params e = - let limit = ctx.limit in - let ops = ctx.ops in - let breaks = ctx.breaks in - let continues = ctx.continues in - let locals = ctx.locals in - let env = ctx.env in - let nenv = ctx.nenv in - let ntraps = ctx.ntraps in - ctx.ops <- DynArray.create(); - ctx.breaks <- []; - ctx.continues <- []; - ctx.env <- PMap.empty; - ctx.nenv <- 0; - ctx.ntraps <- 0; - ctx.limit <- ctx.stack; - List.iter (fun v -> - ctx.stack <- ctx.stack + 1; - ctx.locals <- PMap.add v ctx.stack ctx.locals; - ) params; - let s = ctx.stack in - compile ctx e; - write ctx (Ret (ctx.stack - ctx.limit)); - assert( ctx.stack = s ); - check_breaks ctx; - ctx.stack <- ctx.limit; - ctx.limit <- limit; - ctx.breaks <- breaks; - ctx.continues <- continues; - ctx.locals <- locals; - let gid = DynArray.length ctx.gtable in - ctx.functions <- (ctx.ops,gid,List.length params) :: ctx.functions; - DynArray.add ctx.gtable (GlobalFunction (gid,-1)); - ctx.ops <- ops; - let local_env = ctx.env in - let local_nenv = ctx.nenv in - ctx.env <- env; - ctx.ntraps <- ntraps; - ctx.nenv <- nenv; - if local_nenv > 0 then begin - let a = Array.create local_nenv "" in - PMap.iter (fun v i -> a.(i) <- v) local_env; - Array.iter (fun v -> - compile_constant ctx (Ident v) null_pos; - write ctx Push; - ) a; - write ctx (AccGlobal gid); - write ctx (MakeEnv local_nenv); - end else - write ctx (AccGlobal gid); - -and compile_builtin ctx b el p = - match b , el with - | "istrue" , [e] -> - compile ctx e; - write ctx Bool - | "not" , [e] -> - compile ctx e; - write ctx Not - | "typeof" , [e] -> - compile ctx e; - write ctx TypeOf - | "hash" , [e] -> - compile ctx e; - write ctx Hash - | "compare" , [e1;e2] -> - compile ctx e1; - write ctx Push; - compile ctx e2; - write ctx Compare - | "goto" , [ EConst (Ident l) , _ ] -> - let l = (try Hashtbl.find ctx.labels l with Not_found -> error (Custom ("Unknown label " ^ l)) p) in - let os = ctx.stack in - let ntraps = ref ctx.ntraps in - let etraps = ref [] in - while !ntraps > l.ltraps do - write ctx EndTrap; - ctx.stack <- ctx.stack - trap_stack_delta; - ntraps := !ntraps - 1; - done; - while !ntraps < l.ltraps do - etraps := (pos ctx) :: !etraps; - write ctx (Trap 0); - ntraps := !ntraps + 1; - done; - if ctx.stack > l.lstack then write ctx (Pop (ctx.stack - l.lstack)); - while ctx.stack < l.lstack do - write ctx Push; - done; - ctx.stack <- os; - (match l.lpos with - | None -> l.lwait <- jmp ctx :: l.lwait - | Some p -> write ctx (Jump p)); - if !etraps <> [] then begin - List.iter (fun p -> - DynArray.set ctx.ops p (Trap (pos ctx - p)); - ) !etraps; - write ctx Push; - compile_constant ctx (Builtin "throw") p; - write ctx (Call 1); - end; - | "goto" , _ -> - error (Custom "Invalid $goto statement") p - | _ -> - List.iter (fun e -> - compile ctx e; - write ctx Push; - ) el; - compile_constant ctx (Builtin b) p; - write ctx (Call (List.length el)) - -and compile ctx (e,p) = - match e with - | EConst c -> - compile_constant ctx c p - | EBlock [] -> - write ctx AccNull - | EBlock el -> - let locals = ctx.locals in - let stack = ctx.stack in - List.iter (compile ctx) el; - if stack < ctx.stack then write ctx (Pop (ctx.stack - stack)); - assert( stack = ctx.stack ); - ctx.locals <- locals - | EParenthesis e -> - compile ctx e - | EField (e,f) -> - compile ctx e; - write ctx (AccField f) - | ECall ((EConst (Builtin "array"),_),el) -> - List.iter (fun e -> - compile ctx e; - write ctx Push; - ) el; - write ctx (MakeArray (List.length el)); - | ECall (_,el) when List.length el > max_call_args -> - error (Custom "Too many arguments") p - | ECall ((EField (e,f),_),el) -> - List.iter (fun e -> - compile ctx e; - write ctx Push; - ) el; - compile ctx e; - write ctx Push; - write ctx (AccField f); - write ctx (ObjCall (List.length el)) - | ECall ((EConst (Builtin b),_),el) -> - compile_builtin ctx b el p - | ECall (e,el) -> - List.iter (fun e -> - compile ctx e; - write ctx Push; - ) el; - compile ctx e; - write ctx (Call (List.length el)) - | EArray (e1,(EConst (Int n),_)) -> - compile ctx e1; - write ctx (AccIndex n) - | EArray (e1,e2) -> - compile ctx e1; - write ctx Push; - compile ctx e2; - write ctx AccArray - | EVars vl -> - List.iter (fun (v,o) -> - (match o with - | None -> write ctx AccNull - | Some e -> compile ctx e); - write ctx Push; - ctx.locals <- PMap.add v ctx.stack ctx.locals; - ) vl - | EWhile (econd,e,NormalWhile) -> - let start = pos ctx in - compile ctx econd; - let jend = jmp ~cond:false ctx in - let save = save_breaks ctx in - compile ctx e; - process_continues save; - goto ctx start; - process_breaks save; - jend(); - | EWhile (econd,e,DoWhile) -> - let start = pos ctx in - let save = save_breaks ctx in - compile ctx e; - process_continues save; - compile ctx econd; - write ctx (JumpIf (start - pos ctx)); - process_breaks save - | EIf (e,e1,e2) -> - let stack = ctx.stack in - compile ctx e; - let jelse = jmp ~cond:false ctx in - compile ctx e1; - assert( stack = ctx.stack ); - (match e2 with - | None -> - jelse() - | Some e2 -> - let jend = jmp ctx in - jelse(); - compile ctx e2; - assert( stack = ctx.stack ); - jend()); - | ETry (e,v,ecatch) -> - let start = pos ctx in - write ctx (Trap 0); - ctx.ntraps <- ctx.ntraps + 1; - compile ctx e; - ctx.ntraps <- ctx.ntraps - 1; - ctx.stack <- ctx.stack - trap_stack_delta; - write ctx EndTrap; - let jend = jmp ctx in - DynArray.set ctx.ops start (Trap (pos ctx - start)); - write ctx Push; - let locals = ctx.locals in - ctx.locals <- PMap.add v ctx.stack ctx.locals; - compile ctx ecatch; - write ctx (Pop 1); - ctx.locals <- locals; - jend() - | EBinop ("-",(EConst (Int 0),_),(EConst (Int i),_)) -> - compile ctx (EConst (Int (-i)),p) - | EBinop (op,e1,e2) -> - compile_binop ctx op e1 e2 p - | EReturn None -> - write ctx AccNull; - for i = 1 to ctx.ntraps do - write ctx EndTrap; - done; - write ctx (Ret (ctx.stack - ctx.limit)); - | EReturn (Some e) -> - compile ctx e; - for i = 1 to ctx.ntraps do - write ctx EndTrap; - done; - write ctx (Ret (ctx.stack - ctx.limit - ctx.ntraps * trap_stack_delta)); - | EBreak e -> - assert (ctx.ntraps = 0); - (match e with - | None -> () - | Some e -> compile ctx e); - if ctx.loop_limit <> ctx.stack then DynArray.add ctx.ops (Pop (ctx.stack - ctx.loop_limit)); - ctx.breaks <- (jmp ctx , p) :: ctx.breaks - | EContinue -> - assert (ctx.ntraps = 0); - if ctx.loop_limit <> ctx.stack then DynArray.add ctx.ops (Pop (ctx.stack - ctx.loop_limit)); - ctx.continues <- (jmp ctx , p) :: ctx.continues - | EFunction (params,e) -> - compile_function ctx params e - | ENext (e1,e2) -> - compile ctx e1; - compile ctx e2 - | EObject [] -> - write ctx AccNull; - write ctx New - | EObject fl -> - let fields = List.sort compare (List.map fst fl) in - let id = (try - Hashtbl.find ctx.gobjects fields - with Not_found -> - let id = global ctx (GlobalVar ("o:" ^ string_of_int (Hashtbl.length ctx.gobjects))) in - Hashtbl.add ctx.gobjects fields id; - id - ) in - write ctx (AccGlobal id); - write ctx New; - write ctx Push; - List.iter (fun (f,e) -> - write ctx Push; - compile ctx e; - write ctx (SetField f); - write ctx (AccStack 0); - ) fl; - write ctx (Pop 1) - | ELabel l -> - let l = (try Hashtbl.find ctx.labels l with Not_found -> assert false) in - if ctx.stack <> l.lstack then assert false; - if ctx.ntraps <> l.ltraps then assert false; - List.iter (fun f -> f()) l.lwait; - l.lwait <- []; - l.lpos <- Some (pos ctx) - -let compile file ast = - let ctx = { - stack = 0; - loop_limit = 0; - limit = -1; - globals = Hashtbl.create 0; - gobjects = Hashtbl.create 0; - gtable = DynArray.create(); - locals = PMap.empty; - ops = DynArray.create(); - breaks = []; - continues = []; - functions = []; - env = PMap.empty; - nenv = 0; - ntraps = 0; - labels = Hashtbl.create 0; - } in - scan_labels ctx true ast; - compile ctx ast; - check_breaks ctx; - if ctx.functions <> [] || Hashtbl.length ctx.gobjects <> 0 then begin - let ctxops = ctx.ops in - let ops = DynArray.create() in - ctx.ops <- ops; - write ctx (Jump 0); - List.iter (fun (fops,gid,nargs) -> - DynArray.set ctx.gtable gid (GlobalFunction (DynArray.length ops,nargs)); - DynArray.append fops ops; - ) (List.rev ctx.functions); - DynArray.set ops 0 (Jump (DynArray.length ops)); - Hashtbl.iter (fun fl g -> - write ctx AccNull; - write ctx New; - write ctx (SetGlobal g); - List.iter (fun f -> - write ctx (AccGlobal g); - write ctx Push; - write ctx (SetField f); - ) fl - ) ctx.gobjects; - DynArray.append ctxops ops; - end; - DynArray.to_array ctx.gtable, DynArray.to_array ctx.ops - diff --git a/libs/include/ocaml/neko/lexer.mll b/libs/include/ocaml/neko/lexer.mll deleted file mode 100644 index 7213d5ea..00000000 --- a/libs/include/ocaml/neko/lexer.mll +++ /dev/null @@ -1,191 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) -{ -open Ast -open Lexing - -type error_msg = - | Invalid_character of char - | Unterminated_string - | Unclosed_comment - | Invalid_escaped_character of int - | Invalid_escape - -exception Error of error_msg * pos - -let error_msg = function - | Invalid_character c when int_of_char c > 32 && int_of_char c < 128 -> Printf.sprintf "Invalid character '%c'" c - | Invalid_character c -> Printf.sprintf "Invalid character 0x%.2X" (int_of_char c) - | Unterminated_string -> "Unterminated string" - | Unclosed_comment -> "Unclosed comment" - | Invalid_escaped_character n -> Printf.sprintf "Invalid escaped character %d" n - | Invalid_escape -> "Invalid escape sequence" - -let cur_file = ref "" -let all_lines = Hashtbl.create 0 -let lines = ref [] -let buf = Buffer.create 100 - -let error e pos = - raise (Error (e,{ pmin = pos; pmax = pos; pfile = !cur_file })) - -let keywords = - let h = Hashtbl.create 3 in - List.iter (fun k -> Hashtbl.add h (s_keyword k) k) - [Var;While;Do;If;Else;Function;Return;Break;Continue;Try;Catch] - ; h - -let init file = - cur_file := file; - lines := [] - -let save_lines() = - Hashtbl.replace all_lines !cur_file !lines - -let save() = - save_lines(); - !cur_file - -let restore file = - save_lines(); - cur_file := file; - lines := Hashtbl.find all_lines file - -let newline lexbuf = - lines := (lexeme_end lexbuf) :: !lines - -let find_line p lines = - let rec loop n delta = function - | [] -> n , p - delta - | lp :: l when lp > p -> n , p - delta - | lp :: l -> loop (n+1) lp l - in - loop 1 0 lines - -let get_error_line p = - let lines = List.rev (try Hashtbl.find all_lines p.pfile with Not_found -> []) in - let l, _ = find_line p.pmin lines in - l - -let get_error_pos printer p = - if p.pmin = -1 then - "(unknown)" - else - let lines = List.rev (try Hashtbl.find all_lines p.pfile with Not_found -> []) in - let l1, p1 = find_line p.pmin lines in - let l2, p2 = find_line p.pmax lines in - if l1 = l2 then begin - let s = (if p1 = p2 then Printf.sprintf " %d" p1 else Printf.sprintf "s %d-%d" p1 p2) in - Printf.sprintf "%s character%s" (printer p.pfile l1) s - end else - Printf.sprintf "%s lines %d-%d" (printer p.pfile l1) l1 l2 - -let reset() = Buffer.reset buf -let contents() = Buffer.contents buf -let store lexbuf = Buffer.add_string buf (lexeme lexbuf) -let add c = Buffer.add_string buf c - -let mk_tok t pmin pmax = - t , { pfile = !cur_file; pmin = pmin; pmax = pmax } - -let mk lexbuf t = - mk_tok t (lexeme_start lexbuf) (lexeme_end lexbuf) - -let mk_ident lexbuf = - let s = lexeme lexbuf in - mk lexbuf (try Keyword (Hashtbl.find keywords s) with Not_found -> Const (Ident s)) - -} - -let ident = ['a'-'z' 'A'-'Z' '_' '@'] ['a'-'z' 'A'-'Z' '0'-'9' '_' '@']* -let binop = ['!' '=' '*' '/' '<' '>' '&' '|' '^' '%' '+' ':' '-'] -let number = ['0'-'9'] - -rule token = parse - | eof { mk lexbuf Eof } - | ';' { mk lexbuf Semicolon } - | '.' { mk lexbuf Dot } - | ',' { mk lexbuf Comma } - | '{' { mk lexbuf BraceOpen } - | '}' { mk lexbuf BraceClose } - | '(' { mk lexbuf ParentOpen } - | ')' { mk lexbuf ParentClose } - | '[' { mk lexbuf BracketOpen } - | ']' { mk lexbuf BracketClose } - | "=>" { mk lexbuf Arrow } - | [' ' '\r' '\t']+ { token lexbuf } - | '\n' { newline lexbuf; token lexbuf } - | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ - | number+ { mk lexbuf (Const (Int (int_of_string (lexeme lexbuf)))) } - | number+ '.' number* - | '.' number+ { mk lexbuf (Const (Float (lexeme lexbuf))) } - | '$' (ident as v) { mk lexbuf (Const (Builtin v)) } - | "true" { mk lexbuf (Const True) } - | "false" { mk lexbuf (Const False) } - | "null" { mk lexbuf (Const Null) } - | "this" { mk lexbuf (Const This) } - | ident { mk_ident lexbuf } - | '"' { - reset(); - let pmin = lexeme_start lexbuf in - let pmax = (try string lexbuf with Exit -> error Unterminated_string pmin) in - mk_tok (Const (String (contents()))) pmin pmax; - } - | "/*" { - reset(); - let pmin = lexeme_start lexbuf in - let pmax = (try comment lexbuf with Exit -> error Unclosed_comment pmin) in - mk_tok (Comment (contents())) pmin pmax; - } - | "//" [^'\n']* { - let s = lexeme lexbuf in - let n = (if s.[String.length s - 1] = '\r' then 3 else 2) in - mk lexbuf (CommentLine (String.sub s 2 ((String.length s)-n))) - } - | binop binop? | ">>>" { mk lexbuf (Binop (lexeme lexbuf)) } - | _ { - error (Invalid_character (lexeme_char lexbuf 0)) (lexeme_start lexbuf) - } - -and comment = parse - | eof { raise Exit } - | '\r' { comment lexbuf } - | '\n' { newline lexbuf; store lexbuf; comment lexbuf } - | "*/" { lexeme_end lexbuf } - | '*' { store lexbuf; comment lexbuf } - | [^'*' '\n' '\r']+ { store lexbuf; comment lexbuf } - -and string = parse - | eof { raise Exit } - | '\n' { newline lexbuf; store lexbuf; string lexbuf } - | "\\\"" { add "\""; string lexbuf } - | "\\\\" { add "\\"; string lexbuf } - | "\\n" { add "\n"; string lexbuf } - | "\\t" { add "\t"; string lexbuf } - | "\\r" { add "\r"; string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { - let i = int_of_string (String.sub (lexeme lexbuf) 1 3) in - if i >= 256 then error (Invalid_escaped_character i) (lexeme_start lexbuf); - add (String.make 1 (char_of_int i)); - string lexbuf - } - | '\\' { error Invalid_escape (lexeme_start lexbuf) } - | '"' { lexeme_end lexbuf } - | [^'"' '\\' '\n']+ { store lexbuf; string lexbuf } - \ No newline at end of file diff --git a/libs/include/ocaml/neko/main.ml b/libs/include/ocaml/neko/main.ml deleted file mode 100644 index 738240d0..00000000 --- a/libs/include/ocaml/neko/main.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Printf - -type p_style = - | StyleJava - | StyleMSVC - -let print_style = ref StyleJava - -let normalize_path p = - let l = String.length p in - if l = 0 then - "./" - else match p.[l-1] with - | '\\' | '/' -> p - | _ -> p ^ "/" - -let report inf = - let pos file line = (match !print_style with - | StyleJava -> sprintf "%s:%d:" file line - | StyleMSVC -> sprintf "%s(%d):" file line - ) in - prerr_endline (sprintf "%s : %s %s" (inf.Plugin.exn_pos pos) inf.Plugin.exn_name inf.Plugin.exn_message); - exit 1 - -let dump file ch out = - let data = (try Bytecode.read ch with Bytecode.Invalid_file -> IO.close_in ch; failwith ("Invalid bytecode file " ^ file)) in - IO.close_in ch; - Bytecode.dump out data; - IO.close_out out - -let dump_exn = function - | e -> raise e - -let compile file ch out = - let ast = Parser.parse (Lexing.from_function (fun s p -> try IO.input ch s 0 p with IO.No_more_input -> 0)) file in - IO.close_in ch; - let data = Compile.compile file ast in - Bytecode.write out data; - IO.close_out out - -let compile_exn = function - | Lexer.Error (m,p) -> Plugin.exn_infos "syntax error" (Lexer.error_msg m) (fun f -> Lexer.get_error_pos f p) - | Parser.Error (m,p) -> Plugin.exn_infos "parse error" (Parser.error_msg m) (fun f -> Lexer.get_error_pos f p) - | Compile.Error (m,p) -> Plugin.exn_infos "compile error" (Compile.error_msg m) (fun f -> Lexer.get_error_pos f p) - | e -> raise e - -let main() = - try - let usage = "Neko v0.4 - (c)2005 Nicolas Cannasse\n Usage : neko.exe [options] \n Options :" in - let output = ref "n" in - let args_spec = [ - ("-msvc",Arg.Unit (fun () -> print_style := StyleMSVC),": use MSVC style errors"); - ("-p", Arg.String (fun p -> Plugin.add_path p)," : add the file to path"); - ("-o", Arg.String (fun ext -> output := String.lowercase ext)," : specify output extension"); - ("-v", Arg.Unit (fun () -> Plugin.verbose := true),": verbose mode"); - ] in - Arg.parse args_spec (fun file -> - Plugin.generate file !output - ) usage; - with - | Plugin.Error inf -> - report inf - | Failure msg -> - prerr_endline msg; - exit 1 - -;; -Plugin.register "neko" "n" compile compile_exn; -Plugin.register "n" "dump" dump dump_exn; -at_exit main \ No newline at end of file diff --git a/libs/include/ocaml/neko/neko.vcproj b/libs/include/ocaml/neko/neko.vcproj deleted file mode 100644 index 6830ef5f..00000000 --- a/libs/include/ocaml/neko/neko.vcproj +++ /dev/null @@ -1,104 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/libs/include/ocaml/neko/parser.ml b/libs/include/ocaml/neko/parser.ml deleted file mode 100644 index 98b159b2..00000000 --- a/libs/include/ocaml/neko/parser.ml +++ /dev/null @@ -1,192 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Ast - -type error_msg = - | Unexpected of token - | Unclosed of string - | Duplicate_default - | Unknown_macro of string - | Invalid_macro_parameters of string * int - -exception Error of error_msg * pos - -let error_msg = function - | Unexpected t -> "Unexpected "^(s_token t) - | Unclosed s -> "Unclosed " ^ s - | Duplicate_default -> "Duplicate default declaration" - | Unknown_macro m -> "Unknown macro " ^ m - | Invalid_macro_parameters (m,n) -> "Invalid number of parameters for macro " ^ m ^ " : " ^ string_of_int n ^ " required" - -let error m p = raise (Error (m,p)) - -let priority = function - | "=" | "+=" | "-=" | "*=" | "/=" | "|=" | "&=" | "^=" -> -3 - | "&&" | "||" -> -2 - | "==" | "!=" | ">" | "<" | "<=" | ">=" -> -1 - | "+" | "-" -> 0 - | "*" | "/" -> 1 - | "|" | "&" | "^" -> 2 - | "<<" | ">>" | "%" | ">>>" -> 3 - | _ -> 4 - -let rec make_binop op e ((v,p2) as e2) = - match v with - | EBinop (_op,_e,_e2) when priority _op <= priority op -> - let _e = make_binop op e _e in - EBinop (_op,_e,_e2) , punion (pos _e) (pos _e2) - | _ -> - EBinop (op,e,e2) , punion (pos e) (pos e2) - -let rec program = parser - | [< e = expr; p = program >] -> e :: p - | [< '(Semicolon,_); p = program >] -> p - | [< '(Eof,_) >] -> [] - -and expr = parser - | [< '(Const ((Ident k) as i),p); s >] -> - (match s with parser - | [< '(Binop ":",p2); >] -> ELabel k , punion p p2 - | [< s >] -> expr_next (EConst i,p) s) - | [< '(Const c,p); s >] -> - expr_next (EConst c,p) s - | [< '(BraceOpen,p1); e = block1; s >] -> - (match s with parser - | [< '(BraceClose,p2); s >] -> expr_next (e,punion p1 p2) s - | [< >] -> error (Unclosed "{") p1) - | [< '(ParentOpen,p1); e = expr; s >] -> - (match s with parser - | [< '(ParentClose,p2); s >] -> expr_next (EParenthesis e,punion p1 p2) s - | [< >] -> error (Unclosed "(") p1) - | [< '(Keyword Var,p1); v, p2 = variables p1; s >] -> - expr_next (EVars v,punion p1 p2) s - | [< '(Keyword While,p1); cond = expr; e = expr; s >] -> - expr_next (EWhile (cond,e,NormalWhile), punion p1 (pos e)) s - | [< '(Keyword Do,p1); e = expr; '(Keyword While,_); cond = expr; s >] -> - expr_next (EWhile (cond,e,DoWhile), punion p1 (pos cond)) s - | [< '(Keyword If,p1); cond = expr; e = expr; s >] -> - let rec loop s = - match s with parser - | [< '(Keyword Else,_); e2 = expr; s >] -> expr_next (EIf (cond,e,Some e2),punion p1 (pos e2)) s - | [< '(Semicolon,_); s >] -> loop s - | [< >] -> expr_next (EIf (cond,e,None),punion p1 (pos e)) s - in - loop s - | [< '(Keyword Function,p1); '(ParentOpen,po); p = parameter_names; s >] -> - (match s with parser - | [< '(ParentClose,_); e = expr; s >] -> expr_next (EFunction (p,e),punion p1 (pos e)) s - | [< >] -> error (Unclosed "(") po) - | [< '(Keyword Return,p1); s >] -> - (match s with parser - | [< e = expr; s >] -> expr_next (EReturn (Some e), punion p1 (pos e)) s - | [< '(Semicolon,_); s >] -> expr_next (EReturn None,p1) s) - | [< '(Keyword Break,p1); s >] -> - (match s with parser - | [< e = expr; s >] -> expr_next (EBreak (Some e), punion p1 (pos e)) s - | [< '(Semicolon,_); s >] -> expr_next (EBreak None,p1) s) - | [< '(Keyword Continue,p1); s >] -> - expr_next (EContinue,p1) s - | [< '(Keyword Try,p1); e = expr; '(Keyword Catch,_); '(Const (Ident name),_); e2 = expr; s >] -> - expr_next (ETry (e,name,e2),punion p1 (pos e2)) s - -and expr_next e = parser - | [< '(Dot,_); '(Const (Ident name),p); s >] -> - expr_next (EField (e,name),punion (pos e) p) s - | [< '(ParentOpen,po); pl = parameters; s >] -> - (match s with parser - | [< '(ParentClose,p); s >] -> expr_next (ECall (e,pl),punion (pos e) p) s - | [< >] -> error (Unclosed "(") po) - | [< '(BracketOpen,po); e2 = expr; s >] -> - (match s with parser - | [< '(BracketClose,p); s >] -> expr_next (EArray (e,e2),punion (pos e) p) s - | [< >] -> error (Unclosed "[") po) - | [< '(Binop op,_); e2 = expr; s >] -> - make_binop op e e2 - | [< >] -> - e - -and block1 = parser - | [< '(Const (Ident name),p); s >] -> - (match s with parser - | [< '(Arrow,_); e = expr; l = object_fields >] -> EObject ((name,e) :: l) - | [< '(Binop ":",p2); b = block >] -> EBlock ( (ELabel name, punion p p2) :: b ) - | [< e = expr_next (EConst (Ident name),p); b = block >] -> EBlock (e :: b)) - | [< b = block >] -> - EBlock b - -and block = parser - | [< e = expr; b = block >] -> e :: b - | [< '(Semicolon,_); b = block >] -> b - | [< >] -> [] - -and object_fields = parser - | [< '(Const (Ident name),_); '(Arrow,_); e = expr; l = object_fields >] -> (name,e) :: l - | [< '(Comma,_); l = object_fields >] -> l - | [< >] -> [] - -and parameter_names = parser - | [< '(Const (Ident name),_); p = parameter_names >] -> name :: p - | [< '(Comma,_); p = parameter_names >] -> p - | [< >] -> [] - -and parameters = parser - | [< e = expr; p = parameters_next >] -> e :: p - | [< >] -> [] - -and parameters_next = parser - | [< '(Comma,_); p = parameters >] -> p - | [< >] -> [] - -and variables sp = parser - | [< '(Const (Ident name),p); s >] -> - (match s with parser - | [< '(Binop "=",_); e = expr; v , p = variables_next (pos e) >] -> (name, Some e) :: v , p - | [< v , p = variables_next p >] -> (name, None) :: v , p) - -and variables_next sp = parser - | [< '(Comma,p); v = variables p >] -> v - | [< >] -> [] , sp - -let parse code file = - let old = Lexer.save() in - Lexer.init file; - let last = ref (Eof,null_pos) in - let rec next_token x = - let t, p = Lexer.token code in - match t with - | Comment s | CommentLine s -> - next_token x - | _ -> - last := (t , p); - Some (t , p) - in - try - let l = program (Stream.from next_token) in - Lexer.restore old; - EBlock l, { pmin = 0; pmax = (pos !last).pmax; pfile = file } - with - | Stream.Error _ - | Stream.Failure -> - Lexer.restore old; - error (Unexpected (fst !last)) (pos !last) - | e -> - Lexer.restore old; - raise e - diff --git a/libs/include/ocaml/neko/plugin.ml b/libs/include/ocaml/neko/plugin.ml deleted file mode 100644 index 13fa3e22..00000000 --- a/libs/include/ocaml/neko/plugin.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -type exn_infos = { - exn_name : string; - exn_message : string; - exn_pos : (string -> int -> string) -> string; -} - -type filter = { - ext_in : string; - ext_out : string; - transform : string -> IO.input -> unit IO.output -> unit; - exceptions : exn -> exn_infos; -} - -exception Error of exn_infos - -let paths = ref [""] -let plugins = ref [] -let verbose = ref false - -let register source dest trans exc = - plugins := { - ext_in = String.lowercase source; - ext_out = String.lowercase dest; - transform = trans; - exceptions = exc; - } :: !plugins - -let exn_infos name msg pos = - { - exn_name = name; - exn_pos = pos; - exn_message = msg; - } - -let open_file ?(bin=false) f = - let rec loop = function - | [] -> None - | path :: l -> - let file = path ^ f in - try - let ch = (if bin then open_in_bin else open_in) file in - Some (file, IO.input_channel ch) - with - _ -> loop l - in - loop (!paths) - -let switch_ext file ext = - try - Filename.chop_extension file ^ ext - with - _ -> file ^ ext - -let add_path path = - let l = String.length path in - if l > 0 && path.[l-1] != '\\' && path.[l-1] != '/' then - paths := (path ^ "/") :: !paths - else - paths := path :: !paths - -let generate_loop file ch fext ext = - if ext = fext then - () - else - let rec loop fext acc = function - | [] -> raise Not_found - | x :: l when x.ext_in = fext && not (List.exists (fun p -> p.ext_in = x.ext_out) acc) -> - if x.ext_out = ext then - x :: acc - else - (try - let l1 = loop x.ext_out (x :: acc) (!plugins) in - (try - let l2 = loop fext acc l in - if List.length l2 < List.length l1 then l2 else l1 - with - Not_found -> l1) - with - Not_found -> loop fext acc l) - | x :: l -> - loop fext acc l - in - let ftarget = switch_ext file ("." ^ ext) in - let genlist = (try - List.rev (loop fext [] (!plugins)) - with Not_found -> - let fbase = Filename.basename file in - failwith ("Don't know how to generate " ^ Filename.basename ftarget ^ " from " ^ fbase) - ) in - let execute x file ch out = - try - x.transform file ch out - with - e -> raise (Error (x.exceptions e)) - in - let rec loop file ch = function - | [] -> assert false - | [x] -> - let out = IO.output_channel (open_out_bin ftarget) in - execute x file ch out; - (try IO.close_in ch with IO.Input_closed -> ()); - (try IO.close_out out with IO.Output_closed -> ()); - | x :: l -> - let chin , out = IO.pipe() in - execute x file ch out; - (try IO.close_in ch with IO.Input_closed -> ()); - (try IO.close_out out with IO.Output_closed -> ()); - loop ("." ^ x.ext_out) chin l - in - loop file ch genlist - -let generate file ext = - let fext = (try - let p = String.rindex file '.' in - String.sub file (p + 1) (String.length file - (p + 1)) - with - Not_found -> file - ) in - match open_file ~bin:true file with - | None -> failwith ("File not found : " ^ file) - | Some (file,ch) -> generate_loop file ch fext ext diff --git a/libs/include/ocaml/neko/printer.ml b/libs/include/ocaml/neko/printer.ml deleted file mode 100644 index deec2800..00000000 --- a/libs/include/ocaml/neko/printer.ml +++ /dev/null @@ -1,219 +0,0 @@ -(* - * Neko Compiler - * Copyright (c)2005 Nicolas Cannasse - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - *) - -open Ast - -type 'a ctx = { - ch : 'a IO.output; - mutable level : int; - mutable tabs : bool; -} - -let create ch = { - ch = ch; - level = 0; - tabs = true; -} - -let newline ctx = - IO.write ctx.ch '\n'; - ctx.tabs <- false - -let level ctx b = - ctx.level <- ctx.level + (if b then 1 else -1); - newline ctx - -let print ctx = - if not ctx.tabs then begin - IO.nwrite ctx.ch (String.make (ctx.level * 4) ' '); - ctx.tabs <- true; - end; - IO.printf ctx.ch - -let rec print_list ctx sep f = function - | [] -> () - | x :: [] -> f x - | x :: l -> f x; print ctx "%s" sep; print_list ctx sep f l - -let rec print_ast ?(binop=false) ctx (e,p) = - match e with - | EConst c -> - print ctx "%s" (s_constant c) - | EBlock el -> - print ctx "{"; - level ctx true; - List.iter (fun e -> - print_ast ctx e; - if ctx.tabs then begin - print ctx ";"; - newline ctx; - end - ) el; - ctx.level <- ctx.level - 1; - print ctx "}"; - newline ctx; - | EParenthesis e when not ctx.tabs -> - print ctx "{ "; - print_ast ctx e; - print ctx " }"; - | EParenthesis e -> - print ctx "( "; - print_ast ctx e; - print ctx " )"; - | EField (e,s) -> - print_ast ctx e; - print ctx ".%s" s; - | ECall (e,el) -> - print_ast ctx e; - print ctx "("; - print_list ctx "," (print_ast ctx) el; - print ctx ")"; - | EArray (e1,e2) -> - print_ast ctx e1; - print ctx "["; - print_ast ctx e2; - print ctx "]" - | EVars vl -> - print ctx "var "; - print_list ctx ", " (fun (n,v) -> - print ctx "%s" n; - match v with - | None -> () - | Some e -> - print ctx " = "; - print_ast ctx e - ) vl; - print ctx ";"; - newline ctx - | EWhile (cond,e,NormalWhile) -> - print ctx "while "; - print_ast ctx cond; - level_expr ctx e; - | EWhile (cond,e,DoWhile) -> - print ctx "do "; - level_expr ctx e; - print ctx "while "; - print_ast ctx cond; - newline ctx - | EIf (cond,e,e2) -> - print ctx "if "; - print_ast ctx cond; - level_expr ~closed:(e2=None) ctx e; - (match e2 with - | None -> () - | Some e -> - print ctx "else"; - level_expr ctx e) - | ETry (e,id,e2) -> - print ctx "try"; - level_expr ctx e; - print ctx "catch %s" id; - level_expr ctx e2; - | EFunction (params,e) -> - print ctx "function("; - print_list ctx "," (print ctx "%s") params; - print ctx ")"; - level_expr ctx e; - | EBinop (op,e1,e2) -> - let tabs = ctx.tabs in - if binop then (if tabs then print ctx "(" else print ctx "{"); - print_ast ~binop:true ctx e1; - print ctx " %s " op; - print_ast ~binop:true ctx e2; - if binop then (if tabs then print ctx ")" else print ctx "}"); - | EReturn None -> - print ctx "return;"; - | EReturn (Some e) -> - print ctx "return "; - print_ast ctx e; - | EBreak None -> - print ctx "break;"; - | EBreak (Some e) -> - print ctx "break "; - print_ast ctx e; - | EContinue -> - print ctx "continue" - | ENext (e1,e2) -> - print_ast ctx e1; - print ctx ";"; - newline ctx; - print_ast ctx e2 - | EObject [] -> - print ctx "$new(null)" - | EObject fl -> - print ctx "{"; - level ctx true; - let rec loop = function - | [] -> assert false - | [f,e] -> - print ctx "%s => " f; - print_ast ctx e; - newline ctx; - | (f,e) :: l -> - print ctx "%s => " f; - print_ast ctx e; - print ctx ", "; - newline ctx; - loop l - in - loop fl; - level ctx false; - print ctx "}" - | ELabel s -> - print ctx "%s:" s - -and level_expr ?(closed=false) ctx (e,p) = - match e with - | EBlock _ -> - if ctx.tabs then print ctx " "; - print_ast ctx (e,p) - | ENext _ -> - if ctx.tabs then print ctx " "; - print_ast ctx (EBlock [(e,p)],p) - | EParenthesis e -> - if ctx.tabs then print ctx " "; - print ctx "{"; - level ctx true; - print_ast ctx e; - level ctx false; - print ctx "}"; - | _ -> - level ctx true; - print_ast ctx (e,p); - if closed then print ctx ";"; - level ctx false - -let print ctx ast = - match fst ast with - | EBlock el -> - List.iter (fun e -> - print_ast ctx e; - if ctx.tabs then begin - print ctx ";"; - newline ctx; - end - ) el; - | _ -> - print_ast ctx ast - -let to_string ast = - let ch = IO.output_string() in - let ctx = create ch in - print ctx ast; - IO.close_out ch \ No newline at end of file diff --git a/mkrelease.bat b/mkrelease.bat deleted file mode 100644 index 0d214e63..00000000 --- a/mkrelease.bat +++ /dev/null @@ -1,12 +0,0 @@ -@echo off - -set VERSION=neko-1.0.5 -set FILES=libs neko bin vm mk LICENSE INSTALL CHANGES Makefile configure - -tar --exclude=neko/lexer.ml --exclude=.cvsignore --exclude=neko/*.cm* --exclude=neko/*.o* --exclude=*.tgz --exclude=CVS --exclude=libs/mtypes --exclude=bin/* --exclude=*.sln --exclude=*.vcproj --exclude=*.suo --exclude=*.ncb --exclude=debug --exclude=release --exclude=libs/include -zcf %VERSION%.tgz %FILES% -mkdir %VERSION% -tar -C %VERSION% -zxf %VERSION%.tgz -tar -zcf %VERSION%.tgz %VERSION% -rm -rf %VERSION% - -pause \ No newline at end of file diff --git a/mysql.neko b/mysql.neko deleted file mode 100644 index d1cf0203..00000000 --- a/mysql.neko +++ /dev/null @@ -1,110 +0,0 @@ -std = $loader.loadmodule("mtypes/std",$loader); -sys = $loader.loadmodule("mtypes/sys",$loader); - -String = std.String; -List = std.List; -Date = sys.Date; - -sql_connect = $loader.loadprim("mysql@connect",1); -sql_select_db = $loader.loadprim("mysql@selectDB",2); -sql_request = $loader.loadprim("mysql@request",2); -sql_close = $loader.loadprim("mysql@close",1); -sql_escape = $loader.loadprim("mysql@escape",2); - -result_get_length = $loader.loadprim("mysql@result_get_length",1); -result_get_nfields = $loader.loadprim("mysql@result_get_nfields",1); -result_next = $loader.loadprim("mysql@result_next",1); -result_get = $loader.loadprim("mysql@result_get",2); -result_get_int = $loader.loadprim("mysql@result_get_int",2); -result_get_float = $loader.loadprim("mysql@result_get_float",2); -result_set_conv_date = $loader.loadprim("mysql@result_set_conv_date",2); - -Sql = $new(null); - -Sql.connect = function(params) { - var o = $new(null); - o.host = params.host.@s; - o.port = params.port; - o.user = params.user.@s; - o.pass = params.pass.@s; - o.socket = params.socket.@s; - var c = sql_connect(o); - if( c == null ) - return null; - var s = $new(@Connection); - s.@c = c; - return s; -} - -@Connection = $new(null); -@Connection.@c = null; - -@Connection.selectDB = function(db) { - return sql_select_db(this.@c,db.@s); -} - -@Connection.request = function(s) { - var r = sql_request(this.@c,s.@s); - result_set_conv_date(r,function(d) { return Date.new1(d) }); - var o = $new(@Result); - o.@r = r; - return o; -} - -@Connection.close = function() { - sql_close(this.@c); -} - -@Connection.escape = function(s) { - return String.new(sql_escape(this.@c,s.@s)); -} - -@Result = $new(null); -@Result.@r = null; -@Result.current = null; - -@Result.get_length = function() { - return result_get_length(this.@r); -} - -@Result.get_nfields = function() { - return result_get_nfields(this.@r); -} - -@Result.next = function() { - var c = result_next(this.@r); - this.current = c; - if( c == null ) - return false; - var f = $objfields(c); - var i = 0; - var l = $asize(f); - while( i < l ) { - var v = $objget(c,f[i]); - if( $typeof(v) == $tstring ) - $objset(c,f[i],String.new(v)); - i = i + 1; - } - return true; -} - -@Result.getResult = function(n) { - return String.new(result_get(this.@r,n)); -} - -@Result.getIntResult = function(n) { - return result_get_int(this.@r,n); -} - -@Result.getFloatResult = function(n) { - return result_get_float(this.@r,n); -} - -@Result.results = function() { - var l = List.new(); - while( this.next() ) - l.add(this.current); - return l; -} - -$exports.Sql = Sql; \ No newline at end of file diff --git a/regexp.neko b/regexp.neko deleted file mode 100644 index fd4de890..00000000 --- a/regexp.neko +++ /dev/null @@ -1,47 +0,0 @@ - -Std = $loader.loadmodule("mtypes/std",$loader); -String = Std.String; - -regexp_new = $loader.loadprim("regexp@regexp_new",1); -regexp_match = $loader.loadprim("regexp@regexp_match",2); -regexp_exact_match = $loader.loadprim("regexp@regexp_exact_match",2); -regexp_replace = $loader.loadprim("regexp@regexp_replace",3); -regexp_replace_all = $loader.loadprim("regexp@regexp_replace_all",3); -regexp_matched = $loader.loadprim("regexp@regexp_matched",2); -regexp_matched_pos = $loader.loadprim("regexp@regexp_matched_pos",2); -Regexp = $new(null); - -Regexp.new = function(s) { - var o = $new(@Regexp); - o.@r = regexp_new(s.@s); - return o; -} - -@Regexp = $new(null); -@Regexp.@r = null; - -@Regexp.match = function(s) { - return regexp_match(this.@r,s.@s); -} - -@Regexp.exactMatch = function(s) { - return regexp_exact_match(this.@r,s.@s); -} - -@Regexp.matched = function(n) { - return String.new(regexp_matched(this.@r,n)); -} - -@Regexp.matchedPos = function(n) { - return regexp_matched_pos(this.@r,n); -} - -@Regexp.replace = function(s,s2) { - return String.new(regexp_replace(this.@r,s.@s,s2.@s)); -} - -@Regexp.replaceAll = function(s,s2) { - return String.new(regexp_replace_all(this.@r,s.@s,s2.@s)); -} - -$exports.Regexp = Regexp; diff --git a/sys.neko b/sys.neko deleted file mode 100644 index 1aba3f27..00000000 --- a/sys.neko +++ /dev/null @@ -1,296 +0,0 @@ -// ---------------------------------------------------------------------- -// Dependencies - -std = $loader.loadmodule("mtypes/std",$loader); -String = std.String; -Array = std.Array; -Int32 = std.Int32; - -// ---------------------------------------------------------------------- -// Date - -date_new = $loader.loadprim("std@date_new",1); -date_now = $loader.loadprim("std@date_now",0); -date_set_hour = $loader.loadprim("std@date_set_hour",4); -date_set_day = $loader.loadprim("std@date_set_day",4); -date_get_hour = $loader.loadprim("std@date_get_hour",1); -date_get_day = $loader.loadprim("std@date_get_day",1); -date_format = $loader.loadprim("std@date_format",2); - -Date = $new(null); - -Date.new = function(f) { - var o = $new(@Date); - o.@d = date_new(f.@s); - return o; -} - -Date.now = function() { - var o = $new(@Date); - o.@d = date_now(); - return o; -} - -Date.new1 = function(d) { - var o = $new(@Date); - o.@d = d; - return o; -} - -@Date = $new(null); -@Date.@d = null; - -@Date.setTime = function(h,m,s) { - this.@d = date_set_hour(this.@d,h,m,s); -}; - -@Date.setDay = function(y,m,d) { - this.@d = date_set_day(this.@d,y,m,d); -} - -@Date.getTime = function() { - return date_get_hour(this.@d); -} - -@Date.getDay = function() { - return date_get_day(this.@d); -} - -@Date.format = function(fmt) { - return String.new(date_format(this.@d,fmt.@s)); -} - -@Date.sub = function(d) { - return Date.new1(Int32.sub(this.@d,d.@d)); -} - -@Date.add = function(d) { - return Date.new1(Int32.add(this.@d,d.@d)); -} - -@Date.delta = function(d) { - this.@d = Int32.add(this.@d,d); -} - -@Date.compare = function(d) { - return Int32.compare(this.@d,d.@d); -} - -@Date.toString = function() { - return String.new(this.__string()); -} - -@Date.__string = function() { - return date_format(this.@d,null); -} - -@Date.get_time = function() { - return Int32.to_int(this.@d); -} - -@Date.set_time = function(t) { - this.@d = t; -} - -$exports.Date = Date; - - -// ---------------------------------------------------------------------- -// Socket - -socket_new = $loader.loadprim("std@socket_new",0); -socket_connect = $loader.loadprim("std@socket_connect",3); -socket_write = $loader.loadprim("std@socket_write",2); -socket_read = $loader.loadprim("std@socket_read",1); -socket_close = $loader.loadprim("std@socket_close",1); -socket_set_timeout = $loader.loadprim("std@socket_set_timeout",2); - -host_resolve = $loader.loadprim("std@host_resolve",1); - -Socket = $new(null); -Socket.new = function() { - var o = $new(@Socket); - o.@s = socket_new(); - return o; -} - -@Socket = $new(null); -@Socket.@s = null; - -@Socket.connect = function(host,port) { - socket_connect(this.@s,host_resolve(host.@s),port); -} - -@Socket.send = function(data) { - socket_write(this.@s,data.@s); -} - -@Socket.receive = function() { - return String.new(socket_read(this.@s)); -} - -@Socket.close = function() { - socket_close(this.@s); -} - -@Socket.set_timeout = function(t) { - socket_set_timeout(this.@s,t); -} - -$exports.Socket = Socket; - -// ---------------------------------------------------------------------- -// File - -file_contents = $loader.loadprim("std@file_contents",1); -file_open = $loader.loadprim("std@file_open",2); -file_close = $loader.loadprim("std@file_close",1); -file_read = $loader.loadprim("std@file_read",4); -file_write = $loader.loadprim("std@file_write",4); -file_exists = $loader.loadprim("std@file_exists",1); -file_full_path = $loader.loadprim("std@file_full_path",1); -std_file_name = $loader.loadprim("std@file_name",1); - -file_name = function(f) { - if( $typeof(f) == $tstring ) - return f; - return std_file_name(f); -} - -File = $new(null); - -File.new = function(name) { - var o = $new(@File); - o.@f = name.@s; - return o; -} - -@File = $new(null); -@File.@f = null; - -@File.contents = function() { - return String.new(file_contents(this.@f)); -} - -@File.create = function() { - this.@f = file_open(this.@f,"wb"); -} - -@File.open = function() { - this.@f = file_open(this.@f,"rb"); -} - -@File.append = function() { - this.@f = file_open(this.@f,"ab"); -} - -@File.close = function() { - var f = this.@f; - if( $typeof(f) != $tstring ) - this.@f = std_file_name(f); - file_close(f); -} - -@File.read = function(n) { - var s = $smake(n); - var l = file_read(this.@f,s,0,n) - if( l == n ) - return String.new(s); - if( l == 0 ) - $throw(String.new("File.read")); - return String.new( $ssub(s,0,l) ); -} - -@File.write = function(s) { - s = s.@s; - var len = $ssize(s); - if file_write(this.@f,s,0,len) != len - $throw(String.new("File.write")); -} - -@File.toString = function() { - return String.new(this.__string()); -} - -@File.__string = function() { - return "#file:"+ file_name(this.@f); -} - -@File.name = function() { - return String.new(file_name(this.@f)); -} - -@File.absoluteName = function() { - return file_full_path(file_name(this.@f)); -} - -@File.exists = function() { - return file_exists(this.@f); -} - -$exports.File = File; - -// ---------------------------------------------------------------------- -// Sys - -set_locale = $loader.loadprim("std@set_time_locale",1); -sys_command = $loader.loadprim("std@sys_command",1); -get_cwd = $loader.loadprim("std@get_cwd",0); -set_cwd = $loader.loadprim("std@set_cwd",1); - -Sys = $new(null); - -Sys.getCwd = function() { - return String.new(get_cwd()); -} - -Sys.setLocale = function(l) { - return set_locale(l.@s); -} - -Sys.command = function(cmd) { - return sys_command(cmd.@s); -} - -Sys.setCwd = function(cwd) { - set_cwd(cwd.@s); -} - -Sys.args = function() { - var a = $args(); - var s = $asize(a); - var i = 0; - while( i < s ) { - a[i] = String.new(a[i]); - i = i + 1; - } - return Array.new1(a); -} - -toArray = function(a) { - var i = 0; - var l = $asize(a); - while( i < l ) { - var k = a[i]; - a[i] = if( k == null ) - "Called from a C function"; - else if( $typeof(k) == $tarray ) - "Called from "+k[0]+" line "+k[1]; - else - "Called from "+k; - i = i + 1; - } - return Array.new1(a); -} - -Sys.callstack = function() { - return toArray($callstack()); -} - -Sys.excstack = function() { - return toArray($excstack()); -} - -$exports.Sys = Sys; - -// ----------------------------------------------------------------------