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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,7 +16,7 @@ procedure Apply is
A: Object_Pointer; A: Object_Pointer;
begin begin
if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then
Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CAR"); Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CAR");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -31,7 +31,7 @@ Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CAR");
A: Object_Pointer; A: Object_Pointer;
begin begin
if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then
Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CDR"); Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CDR");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -47,7 +47,7 @@ Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CDR");
B: Object_Pointer; B: Object_Pointer;
begin begin
if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CONS"); Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -65,7 +65,7 @@ Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CONS");
B: Object_Pointer; B: Object_Pointer;
begin begin
if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!"); Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -83,7 +83,7 @@ Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!");
B: Object_Pointer; B: Object_Pointer;
begin begin
if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then if Ptr = Nil_Pointer or else Get_Cdr(Ptr) = Nil_Pointer or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!"); Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -259,6 +259,7 @@ begin
Operand := Get_Frame_Operand(Interp.Stack); Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand)); pragma Assert (Is_Cons(Operand));
ada.text_io.put ("OPERAND TO APPLY => ");
Print (Interp, Operand); Print (Interp, Operand);
Func := Get_Car(Operand); Func := Get_Car(Operand);
if not Is_Normal_Pointer(Func) then if not Is_Normal_Pointer(Func) then

258
lib/h2-scheme-execute-evaluate.adb Normal file
View File

@ -0,0 +1,258 @@
separate (H2.Scheme.Execute)
procedure Evaluate is
pragma Inline (Evaluate);
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);
begin
-- (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) or else not Is_Cons(Get_Cdr(Operand)) then
-- e.g) (define)
-- (define . 10)
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR DEFINE");
raise Syntax_Error;
end if;
Car := Get_Car(Operand);
Cdr := Get_Cdr(Operand);
if Is_Cons(Car) then
-- define a function: (define (add x y) ...)
null;
elsif Is_Symbol(Car) then
-- define a symbol: (define x ...)
if Get_Cdr(Cdr) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR DEFINE");
raise Syntax_Error;
end if;
Cdr := Get_Car(Cdr); -- Value
-- Arrange to finish defining after value evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol);
Set_Frame_Operand (Interp.Stack, Car);
-- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
else
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE");
raise Syntax_Error;
end if;
end Evaluate_Define_Syntax;
procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax);
begin
-- (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;
end if;
if not Is_Cons(Get_Car(Operand)) then
Ada.Text_IO.Put_Line ("INVALID PARRAMETER LIST");
raise Syntax_Error;
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;
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 Evaluate_Lambda_Syntax;
procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax);
begin
Operand := Cdr; -- Skip "quote". Get the first argument.
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));
end Evaluate_Quote_Syntax;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
<<Start_Over>>
Operand := Get_Frame_Operand(Interp.Stack);
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;
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.
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 =>
Evaluate_Define_Syntax;
when Lambda_Syntax =>
Evaluate_Lambda_Syntax;
when Quote_Syntax =>
Evaluate_Quote_Syntax;
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
-- then it can goto <<Literal>>.
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 ("WARNING: $$$$$$$$$$$$$$$$$$$$$..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;

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

@ -77,236 +77,38 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 3); Pop_Tops (Interp, 3);
end Evaluate_Group; end Evaluate_Group;
procedure Evaluate_Object is procedure Finish_Define_Symbol is
pragma Inline (Evaluate_Object); pragma Inline (Finish_Define_Symbol);
X: aliased Object_Pointer;
Operand: aliased Object_Pointer; Y: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
begin begin
Push_Top (Interp, Operand'Unchecked_Access); Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Push_Top (Interp, Car'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
<<Start_Over>> X := Get_Frame_Operand(Interp.Stack);
Operand := 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 Set_Environment (Interp, X, Y);
-- 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;
when Cons_Object => -- Is_Cons(Operand) Pop_Frame (Interp); -- Done
Car := Get_Car(Operand); Chain_Frame_Result (Interp, Interp.Stack, Y);
Cdr := Get_Cdr(Operand);
if Is_Syntax(Car) then
-- special syntax symbol. normal evaluate rule doesn't
-- apply for special syntax objects.
case Car.Scode is Pop_Tops (Interp, 2);
when Begin_Syntax => end Finish_Define_Symbol;
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;
procedure Evaluate is separate;
procedure Apply 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 procedure Fetch_Character is
begin begin
-- TODO: calculate Interp.Input.Row, Interp.Input.Column -- 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; X = Ch.CR or else X = Ch.LF or else X = Ch.FF;
end Is_White_Space; 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 begin
return X = Ch.Left_Parenthesis or else X = Ch.Right_Parenthesis or else 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.Quotation or else X = Ch.Semicolon or else
X = Ch.Number_Sign or else LC.Value = Ch.Semicolon or else
Is_White_Space(X); Is_White_Space(X);
end Is_Identifier_Stopper; end Is_Delimiter;
procedure Skip_Spaces_And_Comments is procedure Skip_Spaces_And_Comments is
begin begin
@ -416,6 +217,86 @@ Print (Interp, Operand);
when Ch.Pos.Apostrophe => when Ch.Pos.Apostrophe =>
Token.Set (Interp, Single_Quote_Token, LC.Value); 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 => when Ch.Pos.Quotation =>
Fetch_Character; Fetch_Character;
Token.Set (Interp, String_Token); Token.Set (Interp, String_Token);
@ -443,9 +324,6 @@ Print (Interp, Operand);
end if; end if;
end loop; end loop;
when Ch.Pos.Number_Sign =>
Fetch_Character;
-- TODO: t, false, etc
when Ch.Pos.Zero .. Ch.Pos.Nine => when Ch.Pos.Zero .. Ch.Pos.Nine =>
-- TODO; negative number, floating-point number, bignum, hexdecimal, etc -- TODO; negative number, floating-point number, bignum, hexdecimal, etc
@ -456,7 +334,7 @@ Print (Interp, Operand);
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then LC.Value not in Ch.Zero .. Ch.Nine then
-- Unfetch the last character -- Unfetch the last character
Interp.LC_Unfetched := Standard.True; Unfetch_Character;
exit; exit;
end if; end if;
end loop; end loop;
@ -474,8 +352,7 @@ Print (Interp, Operand);
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then LC.Value not in Ch.Zero .. Ch.Nine then
-- Unfetch the last character Unfetch_Character;
Interp.LC_Unfetched := Standard.True;
exit; exit;
end if; end if;
end loop; end loop;
@ -483,10 +360,9 @@ Print (Interp, Operand);
Token.Set (Interp, Identifier_Token, Tmp(1..1)); Token.Set (Interp, Identifier_Token, Tmp(1..1));
loop loop
-- TODO: more characters -- TODO: more characters
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
Is_Identifier_Stopper(LC.Value) then Is_Delimiter(LC.Value) then
-- Unfetch the last character Unfetch_Character;
Interp.LC_Unfetched := Standard.True;
exit; exit;
end if; end if;
@ -503,9 +379,8 @@ Print (Interp, Operand);
--exit when not Is_Ident_Char(C.Value); --exit when not Is_Ident_Char(C.Value);
-- TODO: more characters -- TODO: more characters
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
Is_Identifier_Stopper(LC.Value) then Is_Delimiter(LC.Value) then
-- Unfetch the last character Unfetch_Character;
Interp.LC_Unfetched := Standard.True;
exit; exit;
end if; end if;
end loop; 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)); V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Result (Interp, Interp.Stack, V); 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 => 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); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => 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); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => 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)); V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V); 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 => 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));
@ -708,6 +594,12 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V); 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 => 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));
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
@ -802,14 +694,14 @@ begin
Evaluate_Result; Evaluate_Result;
when Opcode_Evaluate_Object => when Opcode_Evaluate_Object =>
Evaluate_Object; Evaluate;
when Opcode_Evaluate_Group => when Opcode_Evaluate_Group =>
Evaluate_Group; Evaluate_Group;
when Opcode_Evaluate_Procedure =>
Evaluate_Procedure;
when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol;
when Opcode_Apply => when Opcode_Apply =>
Apply; Apply;

27
lib/h2-scheme.adb
View File

@ -51,6 +51,9 @@ package body H2.Scheme is
Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
Label_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" 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"
Label_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space"
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- EXCEPTIONS -- EXCEPTIONS
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -76,18 +79,18 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0); subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 11; subtype Opcode_Type is Object_Integer range 0 .. 11;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2); Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4); Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(5); Opcode_Apply: constant Opcode_Type := Opcode_Type'(5);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(7); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10); Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(11); Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(11);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS

3
lib/h2-scheme.ads
View File

@ -451,6 +451,9 @@ private
Right_Parenthesis_Token, Right_Parenthesis_Token,
Period_Token, Period_Token,
Single_Quote_Token, Single_Quote_Token,
True_Token,
False_Token,
Character_Token,
String_Token, String_Token,
Integer_Token Integer_Token
); );

1
lib/lib.gpr.in
View File

@ -16,6 +16,7 @@ project Lib is
"h2-scheme.ads", "h2-scheme.ads",
"h2-scheme-execute.adb", "h2-scheme-execute.adb",
"h2-scheme-execute-apply.adb", "h2-scheme-execute-apply.adb",
"h2-scheme-execute-evaluate.adb",
"h2-scheme-token.adb", "h2-scheme-token.adb",
"h2-utf8.adb", "h2-utf8.adb",
"h2-utf8.ads", "h2-utf8.ads",