From 3ef11302e14187f73bb3d29b7e1d76aa7dc63a99 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 21 Jan 2014 10:12:15 +0000 Subject: [PATCH] enhanced checks in lambda processing --- lib/h2-scheme-execute-apply.adb | 90 ++++++++++++++++++------------ lib/h2-scheme-execute-evaluate.adb | 38 +++++++++---- lib/h2-scheme.adb | 7 --- 3 files changed, 80 insertions(+), 55 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 3ecbd2f..38daf6b 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -15,12 +15,16 @@ procedure Apply is Ptr: Object_Pointer := Args; A: Object_Pointer; begin - if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then + if not Is_Cons(Ptr) or else Get_Cdr(Ptr) /= Nil_Pointer then Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CAR"); raise Syntax_Error; end if; A := Get_Car(Ptr); -- the first argument + if not Is_Cons(A) then +Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CAR"); + raise Evaluation_Error; + end if; Pop_Frame (Interp); -- Done with the current frame Chain_Frame_Result (Interp, Interp.Stack, Get_Car(A)); @@ -30,12 +34,16 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CAR"); Ptr: Object_Pointer := Args; A: Object_Pointer; begin - if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then + if not Is_Cons(Ptr) or else Get_Cdr(Ptr) /= Nil_Pointer then Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CDR"); raise Syntax_Error; end if; A := Get_Car(Ptr); -- the first argument + if not Is_Cons(A) then +Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CDR"); + raise Evaluation_Error; + end if; Pop_Frame (Interp); -- Done with the current frame Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(A)); @@ -46,7 +54,7 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CDR"); A: Object_Pointer; B: Object_Pointer; begin - if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then + if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS"); raise Syntax_Error; end if; @@ -64,12 +72,16 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS"); A: Object_Pointer; B: Object_Pointer; begin - if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then + if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!"); raise Syntax_Error; end if; A := Get_Car(Ptr); -- the first argument + if not Is_Cons(A) then +Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcar"); + raise Evaluation_Error; + end if; B := Get_Car(Get_Cdr(Ptr)); -- the second argument Set_Car (A, B); -- change car @@ -82,12 +94,16 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!"); A: Object_Pointer; B: Object_Pointer; begin - if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then + if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!"); raise Syntax_Error; end if; A := Get_Car(Ptr); -- the first argument + if not Is_Cons(A) then +Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr"); + raise Evaluation_Error; + end if; B := Get_Car(Get_Cdr(Ptr)); -- the second argument Set_Cdr (A, B); -- change cdr @@ -103,7 +119,7 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!"); Num: Object_Integer := 0; -- TODO: support BIGNUM Car: Object_Pointer; begin - while Ptr /= Nil_Pointer loop + while Is_Cons(Ptr) loop -- TODO: check if car is an integer or bignum or something else. -- if something else, error Car := Get_Car(Ptr); @@ -124,7 +140,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); Num: Object_Integer := 0; -- TODO: support BIGNUM Car: Object_Pointer; begin - if Ptr /= Nil_Pointer then + if Is_Cons(Ptr) then Car := Get_Car(Ptr); if not Is_Integer(Car) then raise Evaluation_Error; @@ -132,7 +148,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); Num := Pointer_To_Integer(Car); Ptr := Get_Cdr(Ptr); - while Ptr /= Nil_Pointer loop + while Is_Cons(Ptr) loop -- TODO: check if car is an integer or bignum or something else. -- if something else, error Car := Get_Car(Ptr); @@ -153,7 +169,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); Num: Object_Integer := 1; -- TODO: support BIGNUM Car: Object_Pointer; begin - while Ptr /= Nil_Pointer loop + while Is_Cons(Ptr) loop -- TODO: check if car is an integer or bignum or something else. -- if something else, error Car := Get_Car(Ptr); @@ -174,7 +190,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); Num: Object_Integer := 1; -- TODO: support BIGNUM Car: Object_Pointer; begin - while Ptr /= Nil_Pointer loop + while Is_Cons(Ptr) loop -- TODO: check if car is an integer or bignum or something else. -- if something else, error Car := Get_Car(Ptr); @@ -192,12 +208,12 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); procedure Apply_Closure is Fbody: aliased Object_Pointer; - Param: aliased Object_Pointer; - Arg: aliased Object_Pointer; + Formal: aliased Object_Pointer; + Actual: aliased Object_Pointer; begin Push_Top (Interp, Fbody'Unchecked_Access); - Push_Top (Interp, Param'Unchecked_Access); - Push_Top (Interp, Arg'Unchecked_Access); + Push_Top (Interp, Formal'Unchecked_Access); + Push_Top (Interp, Actual'Unchecked_Access); -- For a closure created of "(lambda (x y) (+ x y) (* x y))" -- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))" @@ -206,47 +222,47 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func)); Fbody := Get_Closure_Code(Func); - pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this. + pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this. - Param := Get_Car(Fbody); -- Formal argument list - Arg := Args; -- Actual argument list + Formal := Get_Car(Fbody); -- Formal argument list + Actual := Args; -- Actual argument list Fbody := Get_Cdr(Fbody); -- Real function body pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this. - if Is_Symbol(Param) then + if Is_Symbol(Formal) then -- Closure made of a lambda expression with a single formal argument -- e.g) (lambda x (car x)) -- Apply the whole actual argument list to the closure. -Print (Interp, Arg); - Put_Environment (Interp, Param, Arg); + Put_Environment (Interp, Formal, Actual); else - while Is_Cons(Param) loop - if not Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); + while Is_Cons(Formal) loop + if not Is_Cons(Actual) then + Ada.Text_IO.Put_Line (">>>> Too few arguments for CLOSURE <<<<"); raise Evaluation_Error; end if; -- Insert the key/value pair into the environment - Put_Environment (Interp, Get_Car(Param), Get_Car(Arg)); + Put_Environment (Interp, Get_Car(Formal), Get_Car(Actual)); - Param := Get_Cdr(Param); - Arg := Get_Cdr(Arg); + Formal := Get_Cdr(Formal); + Actual := Get_Cdr(Actual); end loop; -- Perform cosmetic checks for the parameter list - if Param /= Nil_Pointer then - Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<"); - raise Syntax_Error; - end if; + if Is_Symbol(Formal) then + -- The last formal argument to the closure is in a CDR. + -- Assign the remaining actual arguments to the last formal argument + -- e.g) ((lambda (x y . z) z) 1 2 3 4 5) + Put_Environment (Interp, Formal, Actual); + else + -- The lambda evaluator must ensure all formal arguments are symbols. + pragma Assert (Formal = Nil_Pointer); - -- Perform cosmetic checks for the argument list - if Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<"); - raise Evaluation_Error; - elsif Arg /= Nil_Pointer then - Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); - raise Syntax_Error; + if Actual /= Nil_Pointer then + Ada.Text_IO.Put_Line (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<"); + raise Evaluation_Error; + end if; end if; end if; diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 5e9104b..70b3bb2 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -119,18 +119,34 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- (lambda x ...) null; elsif Is_Cons(Car) then - Cdr := Car; - loop - Cdr := Get_Cdr(Cdr); - exit when not Is_Cons(Cdr); + declare + Formals: Object_Pointer := Car; + V: Object_Pointer; + begin + Cdr := Formals; + loop + Car := Get_Car(Cdr); -- + if not Is_Symbol(Car) then + Ada.Text_IO.Put_Line ("WRONG FORMAL FOR LAMBDA"); + raise Syntax_Error; + end if; - Car := Get_Car(Cdr); - if not Is_Symbol(Car) then - Ada.Text_IO.Put_Line ("WRONG FORMALS FOR LAMBDA"); - raise Syntax_Error; - end if; --- TODO: Check duplicate symbol names??? - end loop; + V := Formals; + loop + exit when V = Cdr; + + if Get_Car(V) = Car then + Ada.Text_IO.Put_Line ("DUPLICATE FORMAL FOR LAMBDA"); + raise Syntax_Error; + end if; + + V := Get_Cdr(V); + end loop; + + Cdr := Get_Cdr(Cdr); + exit when not Is_Cons(Cdr); + end loop; + end; if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 3d301a5..db8debe 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -1668,19 +1668,12 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- TODO: disallow garbage collecion during initialization. Initialize_Heap (Initial_Heap_Size); -ada.text_io.put_line ("kkkkkkkkkkkkkk"); Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evaluation -ada.text_io.put_line ("xxxxxxxxxxxxxx"); Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer); -ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz"); Interp.Environment := Interp.Root_Environment; Make_Syntax_Objects; -print (interp, interp.mark); -ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00"); Make_Procedure_Objects; -ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00--00"); Make_Common_Symbol_Objects; -ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 11"); exception when others =>