st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 14:58:50 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Standard infix capturing

Browse source
This commit is contained in:
Dmitry Boulytchev 2020-01-14 05:15:19 +03:00
parent 25ec856fba
commit a12f9337e9
7 changed files with 184 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

3
regression/x86only/orig/test006.log Normal file
View file

@ -0,0 +1,3 @@
3
{1}
{1}

3
regression/x86only/test006.expr Normal file
View file

@ -0,0 +1,3 @@
printf ("%d\n", infix + (1, 2));
printf ("%s\n", (1 : 2).string);
printf ("%s\n", (infix : (1, 2)).string)

14
runtime/Std.i
View file

@ -21,5 +21,19 @@ F,read;
F,write;
F,compare;
F,i__Infix_4343;
F,s__Infix_58;
F,s__Infix_3333;
F,s__Infix_3838;
F,s__Infix_6161;
F,s__Infix_3361;
F,s__Infix_6061;
F,s__Infix_60;
F,s__Infix_6261;
F,s__Infix_62;
F,s__Infix_43;
F,s__Infix_45;
F,s__Infix_42;
F,s__Infix_47;
F,s__Infix_37;
L,"++",T,"+";

118
runtime/runtime.c
View file

@ -93,6 +93,124 @@ typedef struct {
} sexp;
extern void* alloc (size_t);
extern void* Bsexp (int n, ...);
// Functional synonym for built-in operator ":";
void* Ls__Infix_58 (void *p, void *q) {
void *res;
__pre_gc ();
res = Bsexp (3, p, q, 848787);
__post_gc ();
return res;
}
// Functional synonym for built-in operator "!!";
int Ls__Infix_3333 (void *p, void *q) {
ASSERT_UNBOXED("captured !!:1", p);
ASSERT_UNBOXED("captured !!:2", q);
return BOX(UNBOX(p) || UNBOX(q));
}
// Functional synonym for built-in operator "&&";
int Ls__Infix_3838 (void *p, void *q) {
ASSERT_UNBOXED("captured &&:1", p);
ASSERT_UNBOXED("captured &&:2", q);
return BOX(UNBOX(p) && UNBOX(q));
}
// Functional synonym for built-in operator "==";
int Ls__Infix_6161 (void *p, void *q) {
ASSERT_UNBOXED("captured ==:1", p);
ASSERT_UNBOXED("captured ==:2", q);
return BOX(UNBOX(p) == UNBOX(q));
}
// Functional synonym for built-in operator "!=";
int Ls__Infix_3361 (void *p, void *q) {
ASSERT_UNBOXED("captured !=:1", p);
ASSERT_UNBOXED("captured !=:2", q);
return BOX(UNBOX(p) != UNBOX(q));
}
// Functional synonym for built-in operator "<=";
int Ls__Infix_6061 (void *p, void *q) {
ASSERT_UNBOXED("captured <=:1", p);
ASSERT_UNBOXED("captured <=:2", q);
return BOX(UNBOX(p) <= UNBOX(q));
}
// Functional synonym for built-in operator "<";
int Ls__Infix_60 (void *p, void *q) {
ASSERT_UNBOXED("captured <:1", p);
ASSERT_UNBOXED("captured <:2", q);
return BOX(UNBOX(p) < UNBOX(q));
}
// Functional synonym for built-in operator ">=";
int Ls__Infix_6261 (void *p, void *q) {
ASSERT_UNBOXED("captured >=:1", p);
ASSERT_UNBOXED("captured >=:2", q);
return BOX(UNBOX(p) >= UNBOX(q));
}
// Functional synonym for built-in operator ">";
int Ls__Infix_62 (void *p, void *q) {
ASSERT_UNBOXED("captured >:1", p);
ASSERT_UNBOXED("captured >:2", q);
return BOX(UNBOX(p) > UNBOX(q));
}
// Functional synonym for built-in operator "+";
int Ls__Infix_43 (void *p, void *q) {
ASSERT_UNBOXED("captured +:1", p);
ASSERT_UNBOXED("captured +:2", q);
return BOX(UNBOX(p) + UNBOX(q));
}
// Functional synonym for built-in operator "-";
int Ls__Infix_45 (void *p, void *q) {
ASSERT_UNBOXED("captured -:1", p);
ASSERT_UNBOXED("captured -:2", q);
return BOX(UNBOX(p) - UNBOX(q));
}
// Functional synonym for built-in operator "*";
int Ls__Infix_42 (void *p, void *q) {
ASSERT_UNBOXED("captured *:1", p);
ASSERT_UNBOXED("captured *:2", q);
return BOX(UNBOX(p) * UNBOX(q));
}
// Functional synonym for built-in operator "/";
int Ls__Infix_47 (void *p, void *q) {
ASSERT_UNBOXED("captured /:1", p);
ASSERT_UNBOXED("captured /:2", q);
return BOX(UNBOX(p) / UNBOX(q));
}
// Functional synonym for built-in operator "%";
int Ls__Infix_37 (void *p, void *q) {
ASSERT_UNBOXED("captured %:1", p);
ASSERT_UNBOXED("captured %:2", q);
return BOX(UNBOX(p) % UNBOX(q));
}
extern int Blength (void *p) {
data *a = (data*) BOX (NULL);

4
src/Driver.ml
View file

@ -110,7 +110,7 @@ class options args =
end
let main =
try
(* try *)
let cmd = new options Sys.argv in
match (try parse cmd with Language.Semantic_error msg -> `Fail msg) with
| `Ok prog ->
@ -137,5 +137,5 @@ let main =
List.iter (fun i -> Printf.printf "%d\n" i) output
)
| `Fail er -> Printf.eprintf "Error: %s\n" er
with Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg
(*with Language.Semantic_error msg -> Printf.printf "Error: %s\n" msg *)

56
src/Language.ml
View file

@ -180,12 +180,7 @@ module State =
(* Undefined state *)
let undefined x =
(* let ops =
List.map (fun op -> infix_name op, op)
in
try Value.Var (Value.Fun (List.assoc x ops)) with
Not_found -> *) report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
(* Create a state from bindings list *)
let from_list l = fun x -> try List.assoc x l with Not_found -> report_error ~loc:(Loc.get x) (Printf.sprintf "undefined name \"%s\"" x)
@ -617,6 +612,9 @@ module Expr =
let atr' = atr
let not_a_reference s = new Reason.t (Msg.make "not a reference" [||] (Msg.Locator.Point s#coord))
(* UGLY! *)
let predefined_op : (Obj.t -> Obj.t -> Obj.t) ref = Pervasives.ref (fun _ _ -> invalid_arg "must not happen")
(* ======= *)
ostap (
@ -681,7 +679,18 @@ module Expr =
| l:$ c:(%"true" {Const 1} | %"false" {Const 0}) => {notRef atr} :: (not_a_reference l) => {ignore atr c}
| l:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => {let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name)}
| l:$ %"infix" s:INFIX => {notRef atr} :: (not_a_reference l) => {
if ((* UGLY! *) Obj.magic !predefined_op) infix s
then (
if s = ":="
then report_error ~loc:(Some l#coord) (Printf.sprintf "can not capture predefined operator \":=\"")
else
let name = sys_infix_name s in Loc.attach name l#coord; ignore atr (Var name)
)
else (
let name = infix_name s in Loc.attach name l#coord; ignore atr (Var name)
)
}
| l:$ %"fun" "(" args:!(Util.list0)[ostap (l:$ x:LIDENT {Loc.attach x l#coord; x})] ")"
"{" body:scope[def][infix][Weak][parse def] "}"=> {notRef atr} :: (not_a_reference l) => {ignore atr (Lambda (args, body))}
| l:$ "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} :: (not_a_reference l) => {ignore atr (Array es)}
@ -722,10 +731,10 @@ module Expr =
module Infix =
struct
@type kind = Predefined | Public | Local with show
@type ass = [`Lefta | `Righta | `Nona] with show
@type loc = [`Before of string | `After of string | `At of string] with show
@type export = (ass * string * loc) list with show
@type kind = Predefined | Public | Local with show
@type ass = [`Lefta | `Righta | `Nona] with show
@type loc = [`Before of string | `After of string | `At of string] with show
@type export = (ass * string * loc) list with show
@type showable = (ass * string * kind) list array with show
type t = ([`Lefta | `Righta | `Nona] * ((Expr.atr -> (Expr.atr * Expr.atr)) * ((string * kind * (Expr.t -> Expr.atr -> Expr.t -> Expr.t)) list))) array
@ -765,6 +774,19 @@ module Infix =
let is_predefined op =
List.exists (fun x -> op = x) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"; ":="]
(*
List.iter (fun op ->
Printf.eprintf "F,%s\n" (sys_infix_name op);
(*
Printf.eprintf "// Functional synonym for built-in operator \"%s\";\n" op;
Printf.eprintf "int L%s (void *p, void *q) {\n" (sys_infix_name op);
Printf.eprintf " ASSERT_UNBOXED(\"captured %s:1\", p);\n" op;
Printf.eprintf " ASSERT_UNBOXED(\"captured %s:2\", q);\n\n" op;
Printf.eprintf " return BOX(UNBOX(p) %s UNBOX(q));\n" op;
Printf.eprintf "}\n\n" *)
) [":"; "!!"; "&&"; "=="; "!="; "<="; "<"; ">="; ">"; "+"; "-"; "*" ; "/"; "%"]
*)
let default : t =
Array.map (fun (a, s) ->
a,
@ -782,13 +804,23 @@ module Infix =
|]
exception Break of [`Ok of t | `Fail of string]
let find_op infix op cb ce =
try
Array.iteri (fun i (_, (_, l)) -> if List.exists (fun (s, _, _) -> s = op) l then raise (Break (cb i))) infix;
ce ()
with Break x -> x
let predefined_op infix op =
Array.exists
(fun (_, (_, l)) ->
List.exists (fun (s, p, _) -> s = op && p = Predefined) l
)
infix;;
(* UGLY!!! *)
Expr.predefined_op := (Obj.magic) predefined_op;;
let no_op op coord = `Fail (Printf.sprintf "infix \"%s\" not found in the scope" op)
let kind_of = function true -> Public | _ -> Local

2
src/SM.ml
View file

@ -271,8 +271,6 @@ let check_name_and_add names name mut =
| Top of fundef list
| Item of fundef * fundef list * context
with show
(* @type funinfo = {parent : string; closure : Value.designation list} with show *)
let init_scope st = {
st = st;