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

implemented 'case'

Browse Source
This commit is contained in:
hyung-hwan 2014-02-14 15:47:10 +00:00
parent 21b0dd665f
commit 38ca4baf8f
5 changed files with 250 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -106,6 +106,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr");
Return_Frame (Interp, A);
end Apply_Setcdr_Procedure;
-- -------------------------------------------------------------
-- Arithmetic procedures
-- -------------------------------------------------------------
@ -278,11 +279,11 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
return Pointer_To_Integer(X) <= Pointer_To_Integer(Y);
end Less_Or_Equal;
procedure Apply_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To);
procedure Apply_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than);
procedure Apply_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than);
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);
procedure Apply_N_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To);
procedure Apply_N_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than);
procedure Apply_N_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than);
procedure Apply_N_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal);
procedure Apply_N_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
-- -------------------------------------------------------------
-- Questioning procedures
@ -338,12 +339,28 @@ Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON");
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);
procedure Apply_Q_Null_Procedure is new Apply_Question_Procedure (Is_Null_Class);
procedure Apply_Q_Number_Procedure is new Apply_Question_Procedure (Is_Number_Class);
procedure Apply_Q_Procedure_Procedure is new Apply_Question_Procedure (Is_Procedure_Class);
procedure Apply_Q_String_Procedure is new Apply_Question_Procedure (Is_String_Class);
procedure Apply_Q_Symbol_Procedure is new Apply_Question_Procedure (Is_Symbol_Class);
procedure Apply_Q_Eq_Procedure is
begin
null;
end Apply_Q_Eq_Procedure;
procedure Apply_Q_Eqv_Procedure is
begin
null;
end Apply_Q_Eqv_Procedure;
procedure Apply_Not_Procedure is
begin
null;
end Apply_Not_Procedure;
-- -------------------------------------------------------------
-- Closure
@ -555,44 +572,50 @@ begin
when Setcdr_Procedure =>
Apply_Setcdr_Procedure;
when Add_Procedure =>
when N_Add_Procedure =>
Apply_Add_Procedure;
when Subtract_Procedure =>
when N_Subtract_Procedure =>
Apply_Subtract_Procedure;
when Multiply_Procedure =>
when N_Multiply_Procedure =>
Apply_Multiply_Procedure;
when Quotient_Procedure =>
when N_Quotient_Procedure =>
Apply_Quotient_Procedure;
when Remainder_Procedure =>
when N_Remainder_Procedure =>
--Apply_Remainder_Procedure;
ada.text_io.put_line ("NOT IMPLEMENTED");
raise Evaluation_Error;
when EQ_Procedure =>
Apply_EQ_Procedure;
when GT_Procedure =>
Apply_GT_Procedure;
when LT_Procedure =>
Apply_LT_Procedure;
when GE_Procedure =>
Apply_GE_Procedure;
when LE_Procedure =>
Apply_LE_Procedure;
when N_EQ_Procedure =>
Apply_N_EQ_Procedure;
when N_GT_Procedure =>
Apply_N_GT_Procedure;
when N_LT_Procedure =>
Apply_N_LT_Procedure;
when N_GE_Procedure =>
Apply_N_GE_Procedure;
when N_LE_Procedure =>
Apply_N_LE_Procedure;
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 Q_Eq_Procedure =>
Apply_Q_Eq_Procedure;
when Q_Eqv_Procedure =>
Apply_Q_Eqv_Procedure;
when Q_Null_Procedure =>
Apply_Q_Null_Procedure;
when Q_Number_Procedure =>
Apply_Q_Number_Procedure;
when Q_Procedure_Procedure =>
Apply_Q_Procedure_Procedure;
when Q_String_Procedure =>
Apply_Q_String_Procedure;
when Q_Symbol_Procedure =>
Apply_Q_Symbol_Procedure;
when Not_Procedure =>
Apply_Not_Procedure;
-- when others =>
-- raise Internal_Error;
end case;
when Closure_Object =>

13
lib/h2-scheme-execute-evaluate.adb
View File

@ -109,7 +109,7 @@ procedure Evaluate is
raise Syntax_Error;
end if;
--Key := Get_Car(Operand);
--Key := Get_Car(Operand); -- <key>
Ptr1 := Get_Cdr(Operand); -- <clause> list.
while Is_Cons(Ptr1) loop
@ -119,7 +119,7 @@ procedure Evaluate is
raise Syntax_Error;
end if;
Ptr3 := Get_Car(Ptr2); -- <datum>
Ptr3 := Get_Car(Ptr2); -- <datum> list or 'else'
if Is_Cons(Ptr3) then
if Get_Last_Cdr(Ptr3) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("FUCKING CDR FOR CASE DATUM");
@ -136,6 +136,11 @@ procedure Evaluate is
raise Syntax_Error;
end if;
if Get_Cdr(Ptr2) = Nil_Pointer then
Ada.Text_IO.Put_Line ("NO EXPRESSION IN CASE CLAUSE");
raise Syntax_Error;
end if;
Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
end loop;
@ -147,8 +152,8 @@ procedure Evaluate is
Synlist.Flags := Synlist.Flags or Syntax_Checked;
end if;
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
raise Evaluation_Error;
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <key>
Push_Subframe (Interp, Opcode_Case_Finish, Get_Cdr(Operand)); -- <clause> list
end Evaluate_Case_Syntax;
-- ----------------------------------------------------------------

38
lib/h2-scheme-execute.adb
View File

@ -66,6 +66,41 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Do_And_Finish is new Evaluate_While(Is_True_Class);
procedure Do_Or_Finish is new Evaluate_While(Is_False_Class);
-- ----------------------------------------------------------------
procedure Do_Case_Finish is
pragma Inline (Do_Case_Finish);
R: Object_Pointer;
O: Object_Pointer;
C: Object_Pointer;
D: Object_Pointer;
begin
R := Get_Frame_Result(Interp.Stack); -- <test> result
O := Get_Frame_Operand(Interp.Stack); -- <clause> list
while Is_Cons(O) loop
C := Get_Car(O); -- <clause>
D := Get_Car(C); -- <datum> list
if D = Interp.Else_Symbol then
Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C));
return;
end if;
while Is_Cons(D) loop
if Equal_Values(R, Get_Car(D)) then -- <datum>
Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C));
return;
end if;
D := Get_Cdr(D);
end loop;
O := Get_Cdr(O);
end loop;
-- no match found;
Pop_Frame (Interp);
end Do_Case_Finish;
-- ----------------------------------------------------------------
procedure Do_Cond_Finish is
pragma Inline (Do_Cond_Finish);
@ -936,6 +971,9 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_And_Finish =>
Do_And_Finish;
when Opcode_Case_Finish =>
Do_Case_Finish;
when Opcode_Cond_Finish =>
Do_Cond_Finish;

170
lib/h2-scheme.adb
View File

@ -21,6 +21,38 @@ package body H2.Scheme is
-- PRIMITIVE DEFINITIONS
-----------------------------------------------------------------------------
type Procedure_Code is (
Callcc_Procedure,
Car_Procedure,
Cdr_Procedure,
Cons_Procedure,
Not_Procedure,
N_EQ_Procedure,
N_GT_Procedure,
N_LT_Procedure,
N_GE_Procedure,
N_LE_Procedure,
N_Add_Procedure,
N_Multiply_Procedure,
N_Quotient_Procedure,
N_Remainder_Procedure,
N_Subtract_Procedure,
Q_Eq_Procedure,
Q_Eqv_Procedure,
Q_Null_Procedure,
Q_Number_Procedure,
Q_Procedure_Procedure,
Q_String_Procedure,
Q_Symbol_Procedure,
Setcar_Procedure,
Setcdr_Procedure
);
for Procedure_Code'Size use Object_Integer'Size;
-- I define these constants to word around the limitation of not being
-- able to use a string literal when the string type is a generic parameter.
-- Why doesn't ada include a formal type support for different character
@ -52,23 +84,31 @@ package body H2.Scheme is
Label_Car: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car"
Label_Cdr: constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr"
Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons"
Label_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "="
Label_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">="
Label_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">"
Label_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<="
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_N_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "="
Label_N_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">="
Label_N_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">"
Label_N_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<="
Label_N_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
Label_N_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
Label_N_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
Label_N_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
Label_N_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_N_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_Q_Eq: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.Question); -- "eq?"
Label_Q_Eqv: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.LC_V, Ch.Question); -- "eqv?"
Label_Q_Null: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?"
Label_Q_Number: 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_Q_Procedure: 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_Q_String: 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_Q_Symbol: 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_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"
@ -107,6 +147,7 @@ package body H2.Scheme is
Opcode_And_Finish,
Opcode_Or_Finish,
Opcode_Case_Finish,
Opcode_Cond_Finish,
Opcode_Define_Finish,
Opcode_Grouped_Call, -- (begin ...), closure apply, let body
@ -431,6 +472,64 @@ package body H2.Scheme is
end case;
end Token_To_Pointer;
-----------------------------------------------------------------------------
-- COMPARISON
-----------------------------------------------------------------------------
function Equal_Values (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
Ptr_Type: Object_Pointer_Type;
begin
Ptr_Type := Get_Pointer_Type(X);
case Ptr_Type is
when Object_Pointer_Type_Integer |
Object_Pointer_Type_Character |
Object_Pointer_Type_Byte =>
if Get_Pointer_Type(Y) = Ptr_Type then
return X = Y;
else
return Standard.False;
end if;
when others =>
-- TODO: BIGNUM, OTHER NUMERIC DATA.
case X.Kind is
when Character_Object =>
if Y.Kind = X.Kind then
return X.Character_Slot = Y.Character_Slot;
else
return Standard.False;
end if;
when Byte_Object =>
if Y.Kind = X.Kind then
return X.Byte_Slot = Y.Byte_Slot;
else
return Standard.False;
end if;
when Word_Object =>
if Y.Kind = X.Kind then
return X.Word_Slot = Y.Word_Slot;
else
return Standard.False;
end if;
when Pointer_Object =>
return X = Y;
when Moved_Object =>
raise Internal_Error;
end case;
return X = Y;
end case;
end Equal_Values;
-----------------------------------------------------------------------------
-- MEMORY MANAGEMENT
-----------------------------------------------------------------------------
@ -438,7 +537,7 @@ package body H2.Scheme is
-- (define x #())
-- (define x $())
-- (define x #(
-- (#a . 10) ; a is a synbol
-- (#a . 10) ; a is a symbol
-- (b . 20) ; b is a variable. resolve b at the eval-time and use it.
-- ("c" . 30) ; "c" is a string
-- )
@ -1812,27 +1911,36 @@ end if;
procedure Make_Procedure_Objects is
Dummy: Object_Pointer;
begin
Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+"
Dummy := Make_Procedure (Interp.Self, Callcc_Procedure, Label_Callcc); -- "call-with-current-continuation"
Dummy := Make_Procedure (Interp.Self, Car_Procedure, Label_Car); -- "car"
Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr"
Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons"
Dummy := Make_Procedure (Interp.Self, EQ_Procedure, Label_EQ); -- "="
Dummy := Make_Procedure (Interp.Self, GE_Procedure, Label_GE); -- ">="
Dummy := Make_Procedure (Interp.Self, GT_Procedure, Label_GT); -- ">"
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, N_EQ_Procedure, Label_N_EQ); -- "="
Dummy := Make_Procedure (Interp.Self, N_GE_Procedure, Label_N_GE); -- ">="
Dummy := Make_Procedure (Interp.Self, N_GT_Procedure, Label_N_GT); -- ">"
Dummy := Make_Procedure (Interp.Self, N_LE_Procedure, Label_N_LE); -- "<="
Dummy := Make_Procedure (Interp.Self, N_LT_Procedure, Label_N_LT); -- "<"
Dummy := Make_Procedure (Interp.Self, N_Add_Procedure, Label_N_Plus); -- "+"
Dummy := Make_Procedure (Interp.Self, N_Multiply_Procedure, Label_N_Multiply); -- "*"
Dummy := Make_Procedure (Interp.Self, N_Quotient_Procedure, Label_N_Quotient); -- "quotient"
Dummy := Make_Procedure (Interp.Self, N_Remainder_Procedure, Label_N_Remainder); -- "remainder"
Dummy := Make_Procedure (Interp.Self, N_Subtract_Procedure, Label_N_Minus); -- "-"
Dummy := Make_Procedure (Interp.Self, Q_Eq_Procedure, Label_Q_Eq); -- "eq?"
Dummy := Make_Procedure (Interp.Self, Q_Eqv_Procedure, Label_Q_Eqv); -- "eqv?"
Dummy := Make_Procedure (Interp.Self, Q_Null_Procedure, Label_Q_Null); -- "null?"
Dummy := Make_Procedure (Interp.Self, Q_Number_Procedure, Label_Q_Number); -- "number?"
Dummy := Make_Procedure (Interp.Self, Q_Procedure_Procedure, Label_Q_Procedure); -- "procedure?"
Dummy := Make_Procedure (Interp.Self, Q_String_Procedure, Label_Q_String); -- "string?"
Dummy := Make_Procedure (Interp.Self, Q_Symbol_Procedure, Label_Q_Symbol); -- "symbol?"
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;
procedure Make_Common_Symbol_Objects is

26
lib/h2-scheme.ads
View File

@ -183,32 +183,6 @@ package H2.Scheme is
Set_Syntax
);
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,
Cons_Object,