kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-20 01:57:09 +03:00
Code Issues Projects Releases Wiki Activity

Ada: quieter + dont crash when arith op with nil

Browse Source
This commit is contained in:
Chris M Moore 2015-06-09 20:59:05 +01:00
parent 4594c34d34
commit c3244bcfc2
7 changed files with 196 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
ada/envs.adb
View File

@ -107,8 +107,9 @@ package body Envs is
-- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding
-- expression in Exprs.
procedure Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type) is
-- expression in Exprs. Returns true if all the parameters were bound.
function Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type)
return Boolean is
use Types;
S, Expr : List_Mal_Type;
First_Sym : Atom_Ptr;
@ -116,18 +117,23 @@ package body Envs is
S := Syms;
Expr := Exprs;
while not Is_Null (S) loop
First_Sym := Deref_Atom (Car (S));
if First_Sym.Get_Atom = "&" then
S := Deref_List (Cdr (S)).all;
First_Sym := Deref_Atom (Car (S));
Set (E, First_Sym.Get_Atom, New_List_Mal_Type (Expr));
exit;
return True;
end if;
Set (E, First_Sym.Get_Atom, Car (Expr));
S := Deref_List (Cdr (S)).all;
exit when Is_Null (Expr);
Expr := Deref_List (Cdr (Expr)).all;
end loop;
return Is_Null (S);
end Bind;

5
ada/envs.ads
View File

@ -29,8 +29,9 @@ package Envs is
Not_Found : exception;
-- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding
-- expression in Exprs.
procedure Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type);
-- expression in Exprs. Returns true if all the parameters were bound.
function Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type)
return Boolean;
-- Create a New_Env. The previous one is pushed to the stack and the
-- new one becomes the current one.

259
ada/evaluation.adb
View File

@ -25,7 +25,7 @@ package body Evaluation is
function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
return Mal_Handle is
return Mal_Handle is
Name, Fn_Body, Res : Mal_Handle;
begin
Name := Car (Args);
@ -39,7 +39,7 @@ package body Evaluation is
function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
return Mal_Handle is
return Mal_Handle is
Defs, Expr, Res : Mal_Handle;
begin
Envs.New_Env;
@ -76,7 +76,7 @@ package body Evaluation is
function Eval_Ast
(Ast : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
return Mal_Handle is
function Call_Eval (A : Mal_Handle) return Mal_Handle is
begin
@ -131,7 +131,7 @@ package body Evaluation is
function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
return Mal_Handle is
return Mal_Handle is
D : List_Mal_Type;
Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
begin
@ -148,7 +148,7 @@ package body Evaluation is
function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
return Mal_Handle is
return Mal_Handle is
Param : Mal_Handle;
Env : Envs.Env_Handle;
First_Elem : Mal_Handle;
@ -157,158 +157,163 @@ package body Evaluation is
Param := AParam;
Env := AnEnv;
<<Tail_Call_Opt>>
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).all.Get_List_Type = List_List then
Deref_List (Param).all.Get_List_Type = List_List then
declare
L : Mal_Handle := Param;
LMT, Rest_List : List_Mal_Type;
First_Elem, Rest_Handle : Mal_Handle;
begin
declare
L : Mal_Handle := Param;
LMT, Rest_List : List_Mal_Type;
First_Elem, Rest_Handle : Mal_Handle;
begin
LMT := Deref_List (L).all;
LMT := Deref_List (L).all;
First_Elem := Car (LMT);
First_Elem := Car (LMT);
Rest_Handle := Cdr (LMT);
Rest_Handle := Cdr (LMT);
Rest_List := Deref_List (Rest_Handle).all;
Rest_List := Deref_List (Rest_Handle).all;
case Deref (First_Elem).Sym_Type is
case Deref (First_Elem).Sym_Type is
when Int | Floating | Bool | Str =>
return First_Elem;
when Int | Floating | Bool | Str =>
return First_Elem;
when Atom =>
when Atom =>
declare
Atom_P : Atom_Ptr;
begin
Atom_P := Deref_Atom (First_Elem);
if Atom_P.Get_Atom = "def!" then
return Def_Fn (Rest_List, Env);
elsif Atom_P.Get_Atom = "let*" then
return Let_Processing (Rest_List, Env);
elsif Atom_P.Get_Atom = "do" then
return Do_Processing (Rest_List, Env);
elsif Atom_P.Get_Atom = "if" then
declare
Args : List_Mal_Type := Rest_List;
declare
Atom_P : Atom_Ptr;
begin
Atom_P := Deref_Atom (First_Elem);
if Atom_P.Get_Atom = "def!" then
return Def_Fn (Rest_List, Env);
elsif Atom_P.Get_Atom = "let*" then
return Let_Processing (Rest_List, Env);
elsif Atom_P.Get_Atom = "do" then
return Do_Processing (Rest_List, Env);
elsif Atom_P.Get_Atom = "if" then
declare
Args : List_Mal_Type := Rest_List;
Cond, True_Part, False_Part : Mal_Handle;
Cond_Bool : Boolean;
pragma Assert (Length (Args) = 2 or Length (Args) = 3,
"If_Processing: not 2 or 3 parameters");
L : List_Mal_Type;
begin
Cond := Eval (Car (Args), Env);
Cond, True_Part, False_Part : Mal_Handle;
Cond_Bool : Boolean;
pragma Assert (Length (Args) = 2 or Length (Args) = 3,
"If_Processing: not 2 or 3 parameters");
L : List_Mal_Type;
begin
Cond := Eval (Car (Args), Env);
Cond_Bool := Eval_As_Boolean (Cond);
Cond_Bool := Eval_As_Boolean (Cond);
if Cond_Bool then
L := Deref_List (Cdr (Args)).all;
if Cond_Bool then
L := Deref_List (Cdr (Args)).all;
Param := Car (L);
goto Tail_Call_Opt;
-- return Eval (Car (L), Env);
Param := Car (L);
goto Tail_Call_Opt;
-- was: return Eval (Car (L), Env);
else
if Length (Args) = 3 then
L := Deref_List (Cdr (Args)).all;
L := Deref_List (Cdr (L)).all;
Param := Car (L);
goto Tail_Call_Opt;
-- was: return Eval (Car (L), Env);
else
return New_Atom_Mal_Type ("nil");
end if;
end if;
end;
else -- not a special form
-- Apply section
declare
Res : Mal_Handle;
begin
-- Eval the atom.
Res := Eval_Ast (L, Env);
Param := Res;
goto Tail_Call_Opt;
-- was: return Eval (Res, Env);
end;
end if;
end;
when Func =>
return Call_Func
(Deref_Func (First_Elem).all,
Rest_Handle,
Env);
when Lambda =>
declare
LP : Lambda_Ptr := Deref_Lambda (First_Elem);
Fn_List : Mal_Handle := Cdr (LMT);
Params : List_Mal_Type;
E : Envs.Env_Handle;
begin
E := Envs.New_Env (LP.Get_Env);
Params := Deref_List (LP.Get_Params).all;
if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
Param := LP.Get_Expr;
Env := E;
goto Tail_Call_Opt;
-- was: return Eval (LP.Get_Expr, E);
else
if Length (Args) = 3 then
L := Deref_List (Cdr (Args)).all;
L := Deref_List (Cdr (L)).all;
Param := Car (L);
goto Tail_Call_Opt;
-- return Eval (Car (L), Env);
else
return New_Atom_Mal_Type ("nil");
end if;
return First_Elem;
end if;
end;
else -- not a special form
end;
-- Apply section
declare
Res : Mal_Handle;
begin
-- Eval the atom.
Res := Eval_Ast (L, Env);
Param := Res;
goto Tail_Call_Opt;
-- return Eval (Res, Env);
end;
when List =>
end if;
end;
-- First elem in the list is a list.
-- Eval it and then insert it as first elem in the list and
-- go again.
declare
Evaled_List : Mal_Handle;
E : Envs.Env_Handle;
begin
Evaled_List := Eval (First_Elem, Env);
if Is_Null (Evaled_List) then
return Evaled_List;
elsif Deref (Evaled_List).Sym_Type = Lambda then
E := Deref_Lambda (Evaled_List).Get_Env;
else
E := Env;
end if;
when Func =>
Param := Prepend (Evaled_List, Rest_List);
Env := E;
goto Tail_Call_Opt;
-- was:
-- Evaled_List := Prepend (Evaled_List, Rest_List);
-- return Eval (Evaled_List, E);
end;
return Call_Func
(Deref_Func (First_Elem).all,
Rest_Handle,
Env);
when Error => return First_Elem;
when Lambda =>
when Node => return New_Error_Mal_Type ("Evaluating a node");
declare
LP : Lambda_Ptr := Deref_Lambda (First_Elem);
Fn_List : Mal_Handle := Cdr (LMT);
Params : List_Mal_Type;
E : Envs.Env_Handle;
begin
E := Envs.New_Env (LP.Get_Env);
Params := Deref_List (LP.Get_Params).all;
Envs.Bind (E, Params, Deref_List (Fn_List).all);
when Unitary => null; -- Not yet impl
Param := LP.Get_Expr;
Env := E;
goto Tail_Call_Opt;
--return Eval (LP.Get_Expr, E);
end case;
end;
when List =>
-- First elem in the list is a list.
-- Eval it and then insert it as first elem in the list and
-- go again.
declare
Evaled_List : Mal_Handle;
E : Envs.Env_Handle;
begin
Evaled_List := Eval (First_Elem, Env);
if Is_Null (Evaled_List) then
return Evaled_List;
elsif Deref (Evaled_List).Sym_Type = Lambda then
E := Deref_Lambda (Evaled_List).Get_Env;
else
E := Env;
end if;
Param := Prepend (Evaled_List, Rest_List);
Env := E;
goto Tail_Call_Opt;
-- Evaled_List := Prepend (Evaled_List, Rest_List);
-- return Eval (Evaled_List, E);
end;
when Error => return First_Elem;
when Node => return New_Error_Mal_Type ("Evaluating a node");
when Unitary => null; -- Not yet impl
end case;
end;
end;
else

8
ada/smart_pointers.adb
View File

@ -30,9 +30,11 @@ package body Smart_Pointers is
overriding procedure Finalize (Object : in out Smart_Pointer) is
begin
if Object.Pointer /= null then
Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1;
if Object.Pointer.Ref_Count = 0 then
Free (Object.Pointer);
if Object.Pointer.Ref_Count > 0 then
Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1;
if Object.Pointer.Ref_Count = 0 then
Free (Object.Pointer);
end if;
end if;
end if;
end Finalize;

4
ada/step5_tco.adb
View File

@ -9,7 +9,7 @@ with Printer;
with Reader;
with Types;
procedure Step5_CTO is
procedure Step5_TCO is
function Read (Param : String) return Types.Mal_Handle is
begin
@ -78,4 +78,4 @@ begin
exception
when Ada.IO_Exceptions.End_Error => null;
-- i.e. exit without textual output
end Step5_CTO;
end Step5_TCO;

33
ada/step6_file.adb
View File

@ -46,12 +46,24 @@ procedure Step6_File is
Cmd_Args : Natural;
Command_Args : Types.Mal_Handle;
Command_List : Types.List_Ptr;
File_Processed : Boolean := False;
begin
-- Core init also creates the first environment.
-- This is needed for the def!'s below.
Core.Init;
declare
Not_S : String :=
Rep ("(def! not (fn* (a) (if a false true)))");
LF_S : String :=
Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
pragma Unreferenced (Not_S, LF_S);
begin
null;
end;
Cmd_Args := 0;
Command_Args := Types.New_List_Mal_Type (Types.List_List);
Command_List := Types.Deref_List (Command_Args);
@ -64,17 +76,26 @@ begin
elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
Envs.Debug := True;
else
Command_List.Append
(Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
if not File_Processed then
-- declare
-- F_S : String :=
ADa.Text_IO.Put_Line (
Rep ("(load-file """ & Ada.Command_Line.Argument (Cmd_Args) & """)")
);
-- begin
-- null;
-- end;
File_Processed := True;
else
Command_List.Append
(Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
end if;
end if;
end loop;
Envs.Set (Envs.Get_Current, "*ARGV*", Command_Args);
Ada.Text_IO.Put_Line (Rep ("(def! not (fn* (a) (if a false true)))"));
Ada.Text_IO.Put_Line (Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))"));
loop
begin
Ada.Text_IO.Put ("user> ");

20
ada/types.adb
View File

@ -804,9 +804,25 @@ package body Types is
function Arith_Op (A, B : Mal_Handle) return Mal_Handle is
use Types;
A_Sym_Type : Sym_Types := Deref (A).Sym_Type;
B_Sym_Type : Sym_Types := Deref (B).Sym_Type;
A_Sym_Type : Sym_Types;
B_Sym_Type : Sym_Types;
begin
if Is_Null (A) then
if Is_Null (B) then
-- both null, gotta be zero.
return New_Int_Mal_Type (0);
else -- A is null but B is not.
return Arith_Op (New_Int_Mal_Type (0), B);
end if;
elsif Is_Null (B) then
-- A is not null but B is.
return Arith_Op (A, New_Int_Mal_Type (0));
end if;
-- else both A and B and not null.:wq
A_Sym_Type := Deref (A).Sym_Type;
B_Sym_Type := Deref (B).Sym_Type;
if A_Sym_Type = Int and B_Sym_Type = Int then
return New_Int_Mal_Type
(Int_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val));