hyung-hwan/hak
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added some query procedures

Browse Source
This commit is contained in:
hyung-hwan
2014-02-10 08:33:18 +00:00
parent 9024a9be81
commit c0e533339a
3 changed files with 160 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

88
h2/lib/h2-scheme-execute-apply.adb
View File

@ -197,6 +197,10 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Return_Frame (Interp, Integer_To_Pointer(Num));
end Apply_Quotient_Procedure;
-- -------------------------------------------------------------
-- Comparions procedures
-- -------------------------------------------------------------
generic
with function Validate (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
with function Compare (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
@ -280,6 +284,67 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
procedure Apply_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal);
procedure Apply_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
-- -------------------------------------------------------------
-- Questioning procedures
-- -------------------------------------------------------------
generic
with function Question (X: in Object_Pointer) return Standard.Boolean;
procedure Apply_Question_Procedure;
procedure Apply_Question_Procedure is
Bool: Object_Pointer;
begin
if Is_Cons(Args) and then not Is_Cons(Get_Cdr(Args)) then
-- 1 actual argument
if Question(Get_Car(Args)) then
Bool := True_Pointer;
else
Bool := False_Pointer;
end if;
Return_Frame (Interp, Bool);
else
Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON");
raise Syntax_Error;
end if;
end Apply_Question_Procedure;
function Is_Null_Class (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Null_Class);
begin
return X = Nil_Pointer;
end Is_Null_Class;
function Is_Number_Class (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Number_Class);
begin
return Is_Integer(X); -- TODO bignum
end Is_Number_Class;
function Is_Procedure_Class (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Procedure_Class);
begin
return Is_Closure(X) or else Is_Procedure(X) or else Is_Continuation(X);
end Is_Procedure_Class;
function Is_String_Class (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_String_Class);
begin
return Is_String(X);
end Is_String_Class;
function Is_Symbol_Class (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Symbol_Class);
begin
return Is_Symbol(X);
end Is_Symbol_Class;
procedure Apply_NullQ_Procedure is new Apply_Question_Procedure (Is_Null_Class);
procedure Apply_NumberQ_Procedure is new Apply_Question_Procedure (Is_Number_Class);
procedure Apply_ProcedureQ_Procedure is new Apply_Question_Procedure (Is_Procedure_Class);
procedure Apply_StringQ_Procedure is new Apply_Question_Procedure (Is_String_Class);
procedure Apply_SymbolQ_Procedure is new Apply_Question_Procedure (Is_Symbol_Class);
-- -------------------------------------------------------------
-- Closure
-- -------------------------------------------------------------
@ -498,8 +563,10 @@ begin
Apply_Multiply_Procedure;
when Quotient_Procedure =>
Apply_Quotient_Procedure;
--when Remainder_Procedure =>
-- Apply_Remainder_Procedure;
when Remainder_Procedure =>
--Apply_Remainder_Procedure;
ada.text_io.put_line ("NOT IMPLEMENTED");
raise Evaluation_Error;
when EQ_Procedure =>
Apply_EQ_Procedure;
@ -511,8 +578,21 @@ begin
Apply_GE_Procedure;
when LE_Procedure =>
Apply_LE_Procedure;
when others =>
raise Internal_Error;
when NullQ_Procedure =>
Apply_NullQ_Procedure;
when NumberQ_Procedure =>
Apply_NumberQ_Procedure;
when ProcedureQ_Procedure =>
Apply_ProcedureQ_Procedure;
when StringQ_Procedure =>
Apply_StringQ_Procedure;
when SymbolQ_Procedure =>
Apply_SymbolQ_Procedure;
-- when others =>
-- raise Internal_Error;
end case;
when Closure_Object =>

40
h2/lib/h2-scheme.adb
View File

@ -59,11 +59,16 @@ package body H2.Scheme is
Label_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
Label_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
Label_NullQ: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?"
Label_NumberQ: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_M, Ch.LC_B, Ch.LC_E, Ch.LC_R, Ch.Question); -- "number?"
Label_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
Label_ProcedureQ: constant Object_Character_Array := (Ch.LC_P, Ch.LC_R, Ch.LC_O, Ch.LC_C, Ch.LC_E, Ch.LC_D, Ch.LC_U, Ch.LC_R, Ch.LC_E, Ch.Question); -- "procedure?"
Label_Quotient: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient"
Label_Remainder: constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder"
Label_Setcar: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!"
Label_Setcdr: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!"
Label_StringQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Question); -- "string?"
Label_SymbolQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_Y, Ch.LC_M, Ch.LC_B, Ch.LC_O, Ch.LC_L, Ch.Question); -- "symbol?"
Label_Newline: constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline"
@ -381,6 +386,19 @@ package body H2.Scheme is
return Integer_To_Pointer(Opcode_Type'Pos(Opcode));
end Opcode_To_Pointer;
function Pointer_To_Procedure_Code (Pointer: in Object_Pointer) return Procedure_Code is
pragma Inline (Pointer_To_Procedure_Code);
begin
return Procedure_Code'Val(Pointer_To_Integer(Pointer));
end Pointer_To_Procedure_Code;
function Procedure_Code_To_Pointer (Opcode: in Procedure_Code) return Object_Pointer is
pragma Inline (Procedure_Code_To_Pointer);
begin
return Integer_To_Pointer(Procedure_Code'Pos(Opcode));
end Procedure_Code_To_Pointer;
function Token_To_Pointer (Interp: access Interpreter_Record;
Token: in Token_Record) return Object_Pointer is
begin
@ -1094,12 +1112,19 @@ end if;
end Reverse_Cons;
-----------------------------------------------------------------------------
function Is_String (Source: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_String);
begin
return Is_Normal_Pointer(Source) and then
Source.Tag = String_Object;
end Is_String;
function Make_String (Interp: access Interpreter_Record;
Source: in Object_Character_Array) return Object_Pointer is
Result: Object_Pointer;
begin
Ada.Text_IO.Put_Line ("Make_String...");
Result := Allocate_Character_Object (Interp, Source);
Result := Allocate_Character_Object(Interp, Source);
Result.Tag := String_Object;
--Print_Object_Pointer ("Make_String Result - " & Source, Result);
return Result;
@ -1108,7 +1133,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Symbol);
begin
return Is_Normal_Pointer (Source) and then
return Is_Normal_Pointer(Source) and then
Source.Tag = Symbol_Object;
end Is_Symbol;
@ -1538,7 +1563,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
end Is_Syntax;
function Make_Procedure (Interp: access Interpreter_Record;
Opcode: in Procedure_Code;
Code: in Procedure_Code;
Name: in Object_Character_Array) return Object_Pointer is
-- this procedure is for internal use only
Symbol: aliased Object_Pointer;
@ -1553,7 +1578,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Make the actual procedure object
Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer);
Proc.Tag := Procedure_Object;
Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode);
Proc.Pointer_Slot(Procedure_Opcode_Index) := Procedure_Code_To_Pointer(Code);
-- Link it to the top environement
pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment);
@ -1576,7 +1601,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
pragma Assert (Is_Procedure(Proc));
pragma Assert (Proc.Size = Procedure_Object_Size);
begin
return Pointer_To_Integer(Proc.Pointer_Slot(Procedure_Opcode_Index));
return Pointer_To_Procedure_Code(Proc.Pointer_Slot(Procedure_Opcode_Index));
end Get_Procedure_Opcode;
-----------------------------------------------------------------------------
@ -1796,10 +1821,15 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy := Make_Procedure (Interp.Self, LE_Procedure, Label_LE); -- "<="
Dummy := Make_Procedure (Interp.Self, LT_Procedure, Label_LT); -- "<"
Dummy := Make_Procedure (Interp.Self, Multiply_Procedure, Label_Multiply); -- "*"
Dummy := Make_Procedure (Interp.Self, NumberQ_Procedure, Label_NumberQ); -- "number?"
Dummy := Make_Procedure (Interp.Self, NullQ_Procedure, Label_NullQ); -- "null?"
Dummy := Make_Procedure (Interp.Self, Quotient_Procedure, Label_Quotient); -- "quotient"
Dummy := Make_Procedure (Interp.Self, Remainder_Procedure, Label_Remainder); -- "remainder"
Dummy := Make_Procedure (Interp.Self, Setcar_Procedure, Label_Setcar); -- "set-car!"
Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "set-cdr!"
Dummy := Make_Procedure (Interp.Self, ProcedureQ_Procedure, Label_ProcedureQ); -- "procedure?"
Dummy := Make_Procedure (Interp.Self, StringQ_Procedure, Label_StringQ); -- "string?"
Dummy := Make_Procedure (Interp.Self, SymbolQ_Procedure, Label_SymbolQ); -- "symbol?"
Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-"
end Make_Procedure_Objects;

43
h2/lib/h2-scheme.ads
View File

@ -181,23 +181,32 @@ package H2.Scheme is
Quote_Syntax: constant Syntax_Code := Syntax_Code'(13);
Set_Syntax: constant Syntax_Code := Syntax_Code'(14);
subtype Procedure_Code is Object_Integer;
Add_Procedure: constant Procedure_Code := Procedure_Code'(0);
Callcc_Procedure: constant Procedure_Code := Procedure_Code'(1);
Car_Procedure: constant Procedure_Code := Procedure_Code'(2);
Cdr_Procedure: constant Procedure_Code := Procedure_Code'(3);
Cons_Procedure: constant Procedure_Code := Procedure_Code'(4);
EQ_Procedure: constant Procedure_Code := Procedure_Code'(5);
GT_Procedure: constant Procedure_Code := Procedure_Code'(6);
LT_Procedure: constant Procedure_Code := Procedure_Code'(7);
GE_Procedure: constant Procedure_Code := Procedure_Code'(8);
LE_Procedure: constant Procedure_Code := Procedure_Code'(9);
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(10);
Quotient_Procedure: constant Procedure_Code := Procedure_Code'(11);
Remainder_Procedure: constant Procedure_Code := Procedure_Code'(12);
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(13);
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(14);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(15);
--subtype Procedure_Code is Object_Integer;
type Procedure_Code is (
Add_Procedure,
Callcc_Procedure,
Car_Procedure,
Cdr_Procedure,
Cons_Procedure,
EQ_Procedure,
GT_Procedure,
LT_Procedure,
GE_Procedure,
LE_Procedure,
Multiply_Procedure,
NullQ_Procedure,
NumberQ_Procedure,
ProcedureQ_Procedure,
Quotient_Procedure,
Remainder_Procedure,
Setcar_Procedure,
Setcdr_Procedure,
StringQ_Procedure,
Subtract_Procedure,
SymbolQ_Procedure
);
for Procedure_Code'Size use Object_Integer'Size;
type Object_Tag is (
Unknown_Object,