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

added numeric comparison procedures

Browse Source
This commit is contained in:
hyung-hwan 2014-01-22 14:11:30 +00:00
parent 24e62d6f81
commit 7e12af1221
4 changed files with 144 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -206,6 +206,90 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Quotient_Procedure;
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;
procedure Apply_Compare_Procedure;
procedure Apply_Compare_Procedure is
-- TODO: support other values
Ptr: Object_Pointer := Args;
X: Object_Pointer;
Y: Object_Pointer;
Bool: Object_Pointer := True_Pointer;
begin
if Is_Cons(Ptr) and then Is_Cons(Get_Cdr(Ptr)) then
-- at least 2 actual arguments
X := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
while Is_Cons(Ptr) loop
Y := Get_Car(Ptr);
if not Validate(X, Y) then
ADA.TEXT_IO.PUT_LINE ("NON INTEGER FOR COMPARISION");
raise Evaluation_Error;
end if;
if not Compare(X, Y) then
Bool := False_Pointer;
exit;
end if;
X := Y;
Ptr := Get_Cdr(Ptr);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Bool);
else
Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
raise Syntax_Error;
end if;
end Apply_Compare_Procedure;
function Validate_Numeric (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
return Is_Integer(X) and then Is_Integer(Y);
end Validate_Numeric;
function Equal_To (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
return Pointer_To_Integer(X) = Pointer_To_Integer(Y);
end Equal_To;
function Greater_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
return Pointer_To_Integer(X) > Pointer_To_Integer(Y);
end Greater_Than;
function Less_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
return Pointer_To_Integer(X) < Pointer_To_Integer(Y);
end Less_Than;
function Greater_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
return Pointer_To_Integer(X) >= Pointer_To_Integer(Y);
end Greater_Or_Equal;
function Less_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
begin
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_Closure is
Fbody: aliased Object_Pointer;
Formal: aliased Object_Pointer;
@ -307,7 +391,6 @@ Print (Interp, Operand);
when Setcdr_Procedure =>
Apply_Setcdr_Procedure;
when Add_Procedure =>
Apply_Add_Procedure;
when Subtract_Procedure =>
@ -319,6 +402,16 @@ Print (Interp, Operand);
--when Remainder_Procedure =>
-- Apply_Remainder_Procedure;
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 others =>
raise Internal_Error;
end case;

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

@ -10,6 +10,8 @@ procedure Evaluate is
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);
begin
-- TODO: limit the context where define can be used.
-- (define x 10)
-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
Operand := Cdr; -- Skip "define"
@ -114,9 +116,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
Car := Get_Car(Operand); -- <formals>
if Is_Symbol(Car) then
-- (lambda x ...)
-- nothing to do.
if Car = Nil_Pointer or else Is_Symbol(Car) then
-- (lambda () ...) or (lambda x ...)
-- nothing to do
null;
elsif Is_Cons(Car) then
declare

34
lib/h2-scheme.adb
View File

@ -46,13 +46,18 @@ 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_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
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_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
Label_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
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"
@ -548,25 +553,17 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
Original_Symbol_Table: Object_Pointer;
--function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
function Move_One_Object (Source: in Object_Pointer) return Object_Pointer is
begin
pragma Assert (Is_Normal_Pointer(Source));
--if Is_Special_Pointer(Source) then
--Print_Object_Pointer ("Moving special ...", Source);
-- return Source;
--end if;
if Source.Kind = Moved_Object then
--Print_Object_Pointer ("Moving NOT ...", Source);
-- the object has moved to the new heap.
-- the size field has been updated to the new object
-- in the 'else' block below. i can simply return it
-- without further migration.
return Get_New_Location (Source);
else
--Print_Object_Pointer ("Moving REALLY ...", Source);
declare
Bytes: Heap_Size;
@ -608,8 +605,6 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
-- if the object is marked with FLAG_MOVED;
Set_New_Location (Source, Ptr);
--Ada.Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Source)) & Object_Word'Image(Pointer_To_Word(New_Object)));
--Ada.Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Source.Kind) & " New Size " & Object_Size'Image(Source.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Source.New_Pointer)));
-- Return the new object
return New_Object;
end;
@ -728,6 +723,11 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
end if;
end loop;
-- Migrate some known symbols
Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
Interp.Symbol.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
--Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
-- Scan the heap
Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);
@ -742,9 +742,6 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
--Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
-- Migrate the symbol table itself
Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
Interp.Symbol.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
-- Update temporary object pointers that were pointing to the symbol table
if Original_Symbol_Table /= null then
@ -1630,6 +1627,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
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, Quotient_Procedure, Label_Quotient); -- "quotient"
Dummy := Make_Procedure (Interp.Self, Remainder_Procedure, Label_Remainder); -- "remainder"

17
lib/h2-scheme.ads
View File

@ -186,12 +186,17 @@ package H2.Scheme is
Car_Procedure: constant Procedure_Code := Procedure_Code'(1);
Cdr_Procedure: constant Procedure_Code := Procedure_Code'(2);
Cons_Procedure: constant Procedure_Code := Procedure_Code'(3);
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(4);
Quotient_Procedure: constant Procedure_Code := Procedure_Code'(5);
Remainder_Procedure: constant Procedure_Code := Procedure_Code'(6);
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(7);
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(8);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(9);
EQ_Procedure: constant Procedure_Code := Procedure_Code'(4);
GT_Procedure: constant Procedure_Code := Procedure_Code'(5);
LT_Procedure: constant Procedure_Code := Procedure_Code'(6);
GE_Procedure: constant Procedure_Code := Procedure_Code'(7);
LE_Procedure: constant Procedure_Code := Procedure_Code'(8);
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(9);
Quotient_Procedure: constant Procedure_Code := Procedure_Code'(10);
Remainder_Procedure: constant Procedure_Code := Procedure_Code'(11);
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(12);
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(13);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(14);
type Object_Tag is (
Unknown_Object,