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

implemented symbol defining

Browse Source
This commit is contained in:
hyung-hwan
2014-01-19 15:47:45 +00:00
parent f970a410fd
commit 097dcd6a1f
6 changed files with 420 additions and 262 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -77,236 +77,38 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 3);
end Evaluate_Group;
procedure Evaluate_Object is
pragma Inline (Evaluate_Object);
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
procedure Finish_Define_Symbol is
pragma Inline (Finish_Define_Symbol);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
<<Start_Over>>
Operand := Get_Frame_Operand(Interp.Stack);
X := Get_Frame_Operand(Interp.Stack);
Y := Get_Car(Get_Frame_Result(Interp.Stack));
pragma Assert (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
if not Is_Normal_Pointer(Operand) then
-- integer, character, specal pointers
-- TODO: some normal pointers may point to literal objects. e.g.) bignum
goto Literal;
end if;
case Operand.Tag is
when Symbol_Object => -- Is_Symbol(Operand)
-- TODO: find it in the Environment hierarchy.. not in the current environemnt.
Car := Get_Environment (Interp.Self, Operand);
if Car = null then
-- unbound
Ada.Text_IO.Put_Line ("Unbound symbol....");
Print (Interp, Operand);
raise Evaluation_Error;
else
-- symbol found in the environment
Operand := Car;
goto Literal; -- In fact, this is not a literal, but can be handled in the same way
end if;
Set_Environment (Interp, X, Y);
when Cons_Object => -- Is_Cons(Operand)
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Syntax(Car) then
-- special syntax symbol. normal evaluate rule doesn't
-- apply for special syntax objects.
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Y);
case Car.Scode is
when Begin_Syntax =>
Operand := Cdr; -- Skip "begin"
if not Is_Cons(Operand) then
-- e.g) (begin)
-- (begin . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
else
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Operand);
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
-- I call Evaluate_Group for optimization here.
Evaluate_Group; -- for optimization only. not really needed.
-- I can jump to Start_Over because Evaluate_Group called
-- above pushes an Opcode_Evaluate_Object frame.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if;
when Define_Syntax =>
-- (define x 10)
-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
Operand := Cdr; -- Skip "define"
if not Is_Cons(Operand) then
-- e.g) (define)
-- (define . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR DEFINE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
-- TODO: IMPLEMENT OTHER CHECK
null;
end if;
--Pop_Frame (Interp); -- Done
--Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
-- TODO: IMPLEMENT DEFINE.
when Lambda_Syntax =>
-- (lambda (x y) (+ x y));
Operand := Cdr; -- Skip "lambda"
if not Is_Cons(Operand) then
-- e.g) (lambda)
-- (lambda . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
else
if not Is_Cons(Get_Car(Operand)) then
Ada.Text_IO.Put_Line ("INVALID PARRAMETER LIST");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
end if;
--Print (Interp, Get_Cdr(Operand));
if not Is_Cons(Get_Cdr(Operand)) then
Ada.Text_IO.Put_Line ("NO BODY");
raise Syntax_Error;
--Pop_Frame (Interp); -- Done
end if;
declare
Closure: Object_Pointer;
begin
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure);
end;
end if;
when Quote_Syntax =>
Operand := Cdr; -- Skip "quote"
if not Is_Cons(Operand) then
-- e.g) (quote)
-- (quote . 10)
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR QUOTE");
raise Syntax_Error;
elsif Get_Cdr(Operand) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("WRONG NUMBER OF ARGUMENTS FOR QUOTE");
raise Syntax_Error;
end if;
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
when others =>
Ada.Text_IO.Put_Line ("Unknown syntax");
--Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation
raise Internal_Error;
end case;
else
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
while not Is_Normal_Pointer(Car) loop
-- This while block is for optimization only. It's not really needed.
-- If I know that the next object to evaluate is a literal object,
-- I can simply reverse-chain it to the return field of the current
-- frame without pushing another frame dedicated for it.
-- TODO: some normal pointers may point to a literal object. e.g.) bignum
Chain_Frame_Result (Interp, Interp.Stack, Car);
if Is_Cons(Cdr) then
Operand := Cdr;
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
else
-- last cons
Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand);
goto Done;
end if;
end loop;
end if;
if Is_Cons(Cdr) then
-- Not the last cons cell yet
Set_Frame_Operand (Interp.Stack, Cdr); -- change the operand for the next call
else
-- Reached the last cons cell
if Cdr /= Nil_Pointer then
-- The last CDR is not Nil.
Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR.....................$$$$");
-- raise Syntax_Error;
end if;
-- Change the operand to a mark object so that the call to this
-- procedure after the evaluation of the last car goes to the
-- Mark_Object case.
Set_Frame_Operand (Interp.Stack, Interp.Mark);
end if;
-- Arrange to evaluate the car object
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if;
when Mark_Object =>
-- TODO: you can use the mark context to differentiate context
-- Get the evaluation result stored in the current stack frame by
-- various sub-Opcode_Evaluate_Object frames. the return value
-- chain must be reversed Chain_Frame_Result reverse-chains values.
Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
-- Refresh the current stack frame to Opcode_Apply.
-- This should be faster than Popping the current frame and pushing
-- a new frame.
-- Envir := Get_Frame_Environment(Interp.Stack);
-- Pop_Frame (Interp); -- done
-- Push_Frame (Interp, Opcode_Apply, Operand, Envir);
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand);
when others =>
-- normal literal object
goto Literal;
end case;
goto Done;
<<Literal>>
Pop_Frame (Interp); -- done
Ada.Text_IO.Put ("Return => ");
Print (Interp, Operand);
Chain_Frame_Result (Interp, Interp.Stack, Operand);
goto Done;
<<Done>>
Pop_Tops (Interp, 3);
end Evaluate_Object;
procedure Evaluate_Procedure is
pragma Inline (Evaluate_Procedure);
begin
null;
end Evaluate_Procedure;
Pop_Tops (Interp, 2);
end Finish_Define_Symbol;
procedure Evaluate is separate;
procedure Apply is separate;
procedure Unfetch_Character is
pragma Inline (Unfetch_Character);
pragma Assert (not Interp.LC_Unfetched);
begin
Interp.LC_Unfetched := Standard.True;
end Unfetch_Character;
procedure Fetch_Character is
begin
-- TODO: calculate Interp.Input.Row, Interp.Input.Column
@ -349,13 +151,12 @@ Print (Interp, Operand);
X = Ch.CR or else X = Ch.LF or else X = Ch.FF;
end Is_White_Space;
function Is_Identifier_Stopper (X: in Object_Character) return Standard.Boolean is
function Is_Delimiter (X: in Object_Character) return Standard.Boolean is
begin
return X = Ch.Left_Parenthesis or else X = Ch.Right_Parenthesis or else
X = Ch.Apostrophe or else LC.Value = Ch.Quotation or else
X = Ch.Number_Sign or else LC.Value = Ch.Semicolon or else
X = Ch.Quotation or else X = Ch.Semicolon or else
Is_White_Space(X);
end Is_Identifier_Stopper;
end Is_Delimiter;
procedure Skip_Spaces_And_Comments is
begin
@ -416,6 +217,86 @@ Print (Interp, Operand);
when Ch.Pos.Apostrophe =>
Token.Set (Interp, Single_Quote_Token, LC.Value);
when Ch.Pos.Number_Sign =>
Fetch_Character;
if LC.Kind /= Normal_Character then
-- ended prematurely.
-- TODO: Set Error code, Error Number.... Error location
raise Syntax_Error;
end if;
-- #t
-- #f
-- #\C -- character
-- #( ) -- vector
-- #[ ] -- list
-- #{ } -- hash table
-- #< > -- xxx
case Object_Character'Pos(LC.Value) is
when Ch.Pos.LC_T => -- #t
Token.Set (Interp, True_Token, Ch.Number_Sign);
Token.Append_Character (Interp, LC.Value);
when Ch.Pos.LC_F => -- #f
Token.Set (Interp, False_Token, Ch.Number_Sign);
Token.Append_Character (Interp, LC.Value);
when Ch.Pos.Backslash => -- #\C, #\space, #\newline
Fetch_Character;
if LC.Kind /= Normal_Character then
ada.text_io.put_line ("ERROR: NO CHARACTER AFTER #\");
raise Syntax_Error;
end if;
Token.Set (Interp, Character_Token, LC.Value);
loop
Fetch_Character;
if LC.Kind /= Normal_Character or else
Is_Delimiter(LC.Value) then
Unfetch_Character;
exit;
end if;
Token.Append_Character (Interp, LC.Value);
end loop;
if Interp.Token.Value.Last > 1 then
-- TODO: case insensitive match. binary search for more diverse words
if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then
Token.Set (Interp, Character_Token, Ch.LF); -- reset the token to LF
elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then
Token.Set (Interp, Character_Token, Ch.Space); -- reset the token to Space
else
-- unknown character name.
ada.text_io.put ("ERROR: UNKNOWN CHARACTER NAME ");
for I in 1 .. interp.token.value.last loop
ada.text_io.put (standard.character'val(object_character'pos(interp.token.value.ptr.all(i))));
end loop;
ada.text_io.new_line;
raise Syntax_Error;
end if;
end if;
--when Ch.Pos.Left_Parenthesis => -- #(
-- Token.Set (Interp, Vector_Token, Ch.Number_Sign);
-- Token.Append_Character (Interp, LC.Value);
--when Ch.Pos.Left_Bracket => -- $[
-- Token.Set (Interp, List_Token, Ch.Number_Sign);
-- Token.Append_Character (Interp, LC.Value);
--when Ch.Pos.Left_Bracket => -- ${
-- Token.Set (Interp, Table_Token, Ch.Number_Sign);
-- Token.Append_Character (Interp, LC.Value);
when others =>
-- unknown #letter
-- TODO: Set Error code, Error Number.... Error location
raise Syntax_Error;
end case;
when Ch.Pos.Quotation =>
Fetch_Character;
Token.Set (Interp, String_Token);
@ -443,9 +324,6 @@ Print (Interp, Operand);
end if;
end loop;
when Ch.Pos.Number_Sign =>
Fetch_Character;
-- TODO: t, false, etc
when Ch.Pos.Zero .. Ch.Pos.Nine =>
-- TODO; negative number, floating-point number, bignum, hexdecimal, etc
@ -456,7 +334,7 @@ Print (Interp, Operand);
if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
Unfetch_Character;
exit;
end if;
end loop;
@ -474,8 +352,7 @@ Print (Interp, Operand);
Fetch_Character;
if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
Unfetch_Character;
exit;
end if;
end loop;
@ -483,10 +360,9 @@ Print (Interp, Operand);
Token.Set (Interp, Identifier_Token, Tmp(1..1));
loop
-- TODO: more characters
if LC.Kind /= Normal_Character or else
Is_Identifier_Stopper(LC.Value) then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
if LC.Kind /= Normal_Character or else
Is_Delimiter(LC.Value) then
Unfetch_Character;
exit;
end if;
@ -503,9 +379,8 @@ Print (Interp, Operand);
--exit when not Is_Ident_Char(C.Value);
-- TODO: more characters
if LC.Kind /= Normal_Character or else
Is_Identifier_Stopper(LC.Value) then
-- Unfetch the last character
Interp.LC_Unfetched := Standard.True;
Is_Delimiter(LC.Value) then
Unfetch_Character;
exit;
end if;
end loop;
@ -561,12 +436,17 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
V := Make_String(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V);
when others =>
@ -610,6 +490,12 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
@ -708,6 +594,12 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V);
when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Pop_Frame (Interp); -- Done with the current frame
@ -802,14 +694,14 @@ begin
Evaluate_Result;
when Opcode_Evaluate_Object =>
Evaluate_Object;
Evaluate;
when Opcode_Evaluate_Group =>
Evaluate_Group;
when Opcode_Evaluate_Procedure =>
Evaluate_Procedure;
when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol;
when Opcode_Apply =>
Apply;