diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 38daf6b..f231cb8 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -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; @@ -219,7 +303,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); -- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))" -- Push a new environmen for the closure - Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func)); + Interp.Environment := Make_Environment(Interp.Self, Get_Closure_Environment(Func)); Fbody := Get_Closure_Code(Func); pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this. @@ -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; diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 2f07517..14baa13 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -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,10 +116,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; Car := Get_Car(Operand); -- - if Is_Symbol(Car) then - -- (lambda x ...) - -- nothing to do. - null; + if Car = Nil_Pointer or else Is_Symbol(Car) then + -- (lambda () ...) or (lambda x ...) + -- nothing to do + null; elsif Is_Cons(Car) then declare Formals: Object_Pointer := Car; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index da5ac0f..4950e53 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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 @@ -1626,16 +1623,21 @@ Ada.Text_IO.Put_Line ("Make_String..."); procedure Make_Procedure_Objects is Dummy: Object_Pointer; begin - Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" - 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, Multiply_Procedure, Label_Multiply); -- "*" - 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, Subtract_Procedure, Label_Minus); -- "-" + Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" + 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" + 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, Subtract_Procedure, Label_Minus); -- "-" end Make_Procedure_Objects; procedure Make_Common_Symbol_Objects is diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index bdd6229..8ddca3f 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -182,16 +182,21 @@ package H2.Scheme is Set_Syntax: constant Syntax_Code := Syntax_Code'(14); subtype Procedure_Code is Object_Integer; - Add_Procedure: constant Procedure_Code := Procedure_Code'(0); - 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); + Add_Procedure: constant Procedure_Code := Procedure_Code'(0); + Car_Procedure: constant Procedure_Code := Procedure_Code'(1); + Cdr_Procedure: constant Procedure_Code := Procedure_Code'(2); + Cons_Procedure: constant Procedure_Code := Procedure_Code'(3); + 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,