implemented cond
This commit is contained in:
parent
d7e25ac8ca
commit
cbf8d0e54e
@ -30,7 +30,7 @@ procedure Evaluate is
|
||||
elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then
|
||||
-- (and . 10)
|
||||
-- (and 1 2 . 10)
|
||||
Ada.Text_IO.Put_LINE ("FUCKING cDR FOR DEFINE");
|
||||
Ada.Text_IO.Put_LINE ("FUCKING CDR FOR DEFINE");
|
||||
raise Syntax_Error;
|
||||
else
|
||||
--Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- <test2> onwards
|
||||
@ -88,6 +88,76 @@ raise Syntax_Error;
|
||||
end if;
|
||||
end Evaluate_Define_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
procedure Evaluate_Case_Syntax is
|
||||
pragma Inline (Evaluate_Case_Syntax);
|
||||
begin
|
||||
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
|
||||
raise Evaluation_Error;
|
||||
end Evaluate_Case_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
procedure Evaluate_Cond_Syntax is
|
||||
pragma Inline (Evaluate_Cond_Syntax);
|
||||
Ptr: Object_Pointer;
|
||||
begin
|
||||
-- cond <clause 1> <clause 2> ...
|
||||
-- A clause should be of the form:
|
||||
-- (<test> <expression> ...)
|
||||
-- the last clause may be an else clause of the form:
|
||||
-- (else <expression> ...)
|
||||
--
|
||||
-- (cond ((> 3 2) 'greater)
|
||||
-- ((< 3 2) 'less)) => greater
|
||||
-- (cond ((> 3 3) 'greater)
|
||||
-- ((< 3 3) 'less)
|
||||
-- (else 'equal)) => equal
|
||||
|
||||
Operand := Cdr; -- Skip "cond"
|
||||
if Not Is_Cons(Operand) then
|
||||
-- e.g) (cond)
|
||||
-- (cond . 10)
|
||||
Ada.Text_IO.Put_LINE ("NO CLAUSE FOR COND");
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
|
||||
-- Check clauses
|
||||
-- TODO: Skip this check of clauses that have been checked previously.
|
||||
Ptr := Operand;
|
||||
loop
|
||||
Car := Get_Car(Ptr); -- <clause>
|
||||
if not Is_Cons(Car) then
|
||||
Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND");
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
If Get_Last_Cdr(Car) /= Nil_Pointer then
|
||||
Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE");
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
Ptr := Get_Cdr(Ptr);
|
||||
exit when not Is_Cons(Ptr);
|
||||
end loop;
|
||||
if Ptr /= Nil_Pointer then
|
||||
Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND");
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
|
||||
Car := Get_Car(Operand); -- first <clause>
|
||||
|
||||
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Car), Nil_Pointer); -- first <test>
|
||||
Push_Subframe (Interp, Opcode_Cond_Finish, Operand);
|
||||
end Evaluate_Cond_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
procedure Evaluate_Do_Syntax is
|
||||
pragma Inline (Evaluate_Do_Syntax);
|
||||
begin
|
||||
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
|
||||
raise Evaluation_Error;
|
||||
end Evaluate_Do_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
procedure Evaluate_If_Syntax is
|
||||
@ -426,6 +496,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
|
||||
end if;
|
||||
end Evaluate_Letrec_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
procedure Evaluate_Quasiquote_Syntax is
|
||||
pragma Inline (Evaluate_Quasiquote_Syntax);
|
||||
begin
|
||||
Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
|
||||
raise Evaluation_Error;
|
||||
end Evaluate_Quasiquote_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
procedure Evaluate_Quote_Syntax is
|
||||
@ -564,9 +642,18 @@ end;
|
||||
-- goto Start_Over; -- for optimization only. not really needed.
|
||||
--end if;
|
||||
|
||||
when Case_Syntax =>
|
||||
Evaluate_Case_Syntax;
|
||||
|
||||
when Cond_Syntax =>
|
||||
Evaluate_Cond_Syntax;
|
||||
|
||||
when Define_Syntax =>
|
||||
Evaluate_Define_Syntax;
|
||||
|
||||
when Do_Syntax =>
|
||||
Evaluate_Do_Syntax;
|
||||
|
||||
when If_Syntax =>
|
||||
Evaluate_If_Syntax;
|
||||
|
||||
@ -585,16 +672,15 @@ end;
|
||||
when Or_Syntax =>
|
||||
Evaluate_Or_Syntax;
|
||||
|
||||
when Quasiquote_Syntax =>
|
||||
Evaluate_Quasiquote_Syntax;
|
||||
|
||||
when Quote_Syntax =>
|
||||
Evaluate_Quote_Syntax;
|
||||
|
||||
when Set_Syntax => -- set!
|
||||
Evaluate_Set_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
|
||||
-- procedure call
|
||||
|
||||
@ -51,20 +51,61 @@ procedure Execute (Interp: in out Interpreter_Record) is
|
||||
end if;
|
||||
end Evaluate_While;
|
||||
|
||||
function Is_False (X: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_False);
|
||||
function Is_False_Class (X: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_False_Class);
|
||||
begin
|
||||
return X = False_Pointer;
|
||||
end Is_False;
|
||||
end Is_False_Class;
|
||||
|
||||
function Is_True (X: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_True);
|
||||
function Is_True_Class (X: in Object_Pointer) return Standard.Boolean is
|
||||
pragma Inline (Is_True_Class);
|
||||
begin
|
||||
return X /= False_Pointer;
|
||||
end Is_True;
|
||||
end Is_True_Class;
|
||||
|
||||
procedure Do_And_Finish is new Evaluate_While(Is_True_Class);
|
||||
procedure Do_Or_Finish is new Evaluate_While(Is_False_Class);
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
procedure Do_Cond_Finish is
|
||||
pragma Inline (Do_Cond_Finish);
|
||||
R: Object_Pointer;
|
||||
O: Object_Pointer;
|
||||
begin
|
||||
R := Get_Frame_Result(Interp.Stack); -- <test> result
|
||||
O := Get_Frame_Operand(Interp.Stack); -- <clause> list
|
||||
|
||||
if Is_True_Class(R) then
|
||||
O := Get_Cdr(Get_Car(O)); -- <expression> list in <clause>
|
||||
if Is_Cons(O) then
|
||||
Reload_Frame (Interp, Opcode_Grouped_Call, O);
|
||||
else
|
||||
Pop_Frame (Interp);
|
||||
end if;
|
||||
else
|
||||
O := Get_Cdr(O); -- next <clause> list
|
||||
|
||||
if not Is_Cons(O) then
|
||||
-- no more <clause>
|
||||
Pop_Frame (Interp);
|
||||
else
|
||||
R := Get_Car(O); -- next <clause>
|
||||
if Get_Car(R) = Interp.Else_Symbol then
|
||||
-- else <clause>
|
||||
O := Get_Cdr(R); -- <expression> list in else <clause>
|
||||
if Is_Cons(O) then
|
||||
Reload_Frame (Interp, Opcode_Grouped_Call, O);
|
||||
else
|
||||
Pop_Frame (Interp);
|
||||
end if;
|
||||
else
|
||||
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(R), Nil_Pointer);
|
||||
Push_Subframe (Interp, Opcode_Cond_Finish, O);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end Do_Cond_Finish;
|
||||
|
||||
procedure Do_And_Finish is new Evaluate_While(Is_True);
|
||||
procedure Do_Or_Finish is new Evaluate_While(Is_False);
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
procedure Do_Define_Finish is
|
||||
@ -766,7 +807,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
|
||||
begin
|
||||
V := Get_Frame_Result(Interp.Stack);
|
||||
V := Make_Cons(Interp.Self, V, Nil_Pointer);
|
||||
V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
|
||||
V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V);
|
||||
Pop_Frame (Interp);
|
||||
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
|
||||
end Close_Quote_In_List;
|
||||
@ -777,7 +818,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
|
||||
begin
|
||||
V := Get_Frame_Result(Interp.Stack);
|
||||
V := Make_Cons(Interp.Self, V, Nil_Pointer);
|
||||
V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
|
||||
V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V);
|
||||
Return_Frame (Interp, V);
|
||||
end Close_Quote;
|
||||
|
||||
@ -895,8 +936,8 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
|
||||
when Opcode_And_Finish =>
|
||||
Do_And_Finish;
|
||||
|
||||
--when Opcode_Finish_Case_Syntax =>
|
||||
--when Opcode_Finish_Cond_Syntax =>
|
||||
when Opcode_Cond_Finish =>
|
||||
Do_Cond_Finish;
|
||||
|
||||
when Opcode_Define_Finish =>
|
||||
Do_Define_Finish;
|
||||
|
||||
@ -75,6 +75,8 @@ package body H2.Scheme is
|
||||
Label_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space"
|
||||
|
||||
Label_Arrow: constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>"
|
||||
Label_Else: constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else"
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- EXCEPTIONS
|
||||
-----------------------------------------------------------------------------
|
||||
@ -105,6 +107,7 @@ package body H2.Scheme is
|
||||
|
||||
Opcode_And_Finish,
|
||||
Opcode_Or_Finish,
|
||||
Opcode_Cond_Finish,
|
||||
Opcode_Define_Finish,
|
||||
Opcode_Grouped_Call, -- (begin ...), closure apply, let body
|
||||
Opcode_If_Finish,
|
||||
@ -808,9 +811,10 @@ ada.text_io.put_line ("[GC BEGIN]");
|
||||
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);
|
||||
Interp.Arrow_Symbol := Move_One_Object(Interp.Arrow_Symbol);
|
||||
Interp.Else_Symbol := Move_One_Object(Interp.Else_Symbol);
|
||||
Interp.Quasiquote_Symbol := Move_One_Object(Interp.Quasiquote_Symbol);
|
||||
Interp.Quote_Symbol := Move_One_Object(Interp.Quote_Symbol);
|
||||
|
||||
--Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
|
||||
-- Scan the heap
|
||||
@ -908,7 +912,7 @@ end if;
|
||||
Kind => Pointer_Object,
|
||||
Size => Size,
|
||||
Flags => 0,
|
||||
Scode => 0,
|
||||
Scode => Syntax_Code'Val(0),
|
||||
Tag => Unknown_Object,
|
||||
Pointer_Slot => (others => Initial)
|
||||
);
|
||||
@ -939,7 +943,7 @@ end if;
|
||||
Kind => Character_Object,
|
||||
Size => Size,
|
||||
Flags => 0,
|
||||
Scode => 0,
|
||||
Scode => Syntax_Code'Val(0),
|
||||
Tag => Unknown_Object,
|
||||
Character_Slot => (others => Ch.NUL),
|
||||
Character_Terminator => Ch.NUL
|
||||
@ -980,7 +984,7 @@ end if;
|
||||
Kind => Byte_Object,
|
||||
Size => Size,
|
||||
Flags => 0,
|
||||
Scode => 0,
|
||||
Scode => Syntax_Code'Val(0),
|
||||
Tag => Unknown_Object,
|
||||
Byte_Slot => (others => 0)
|
||||
);
|
||||
@ -1123,10 +1127,8 @@ end if;
|
||||
Source: in Object_Character_Array) return Object_Pointer is
|
||||
Result: Object_Pointer;
|
||||
begin
|
||||
Ada.Text_IO.Put_Line ("Make_String...");
|
||||
Result := Allocate_Character_Object(Interp, Source);
|
||||
Result.Tag := String_Object;
|
||||
--Print_Object_Pointer ("Make_String Result - " & Source, Result);
|
||||
return Result;
|
||||
end Make_String;
|
||||
|
||||
@ -1802,8 +1804,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
|
||||
Dummy := Make_Syntax (Interp.Self, Letast_Syntax, Label_Letast); -- "let*"
|
||||
Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrec"
|
||||
Dummy := Make_Syntax (Interp.Self, Or_Syntax, Label_Or); -- "or"
|
||||
Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
|
||||
Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote"
|
||||
Interp.Quote_Symbol := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote"
|
||||
Interp.Quasiquote_Symbol := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote"
|
||||
Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!"
|
||||
end Make_Syntax_Objects;
|
||||
|
||||
@ -1835,7 +1837,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
|
||||
|
||||
procedure Make_Common_Symbol_Objects is
|
||||
begin
|
||||
Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow);
|
||||
Interp.Arrow_Symbol := Make_Symbol (Interp.Self, Label_Arrow);
|
||||
Interp.Else_Symbol := Make_Symbol (Interp.Self, Label_Else);
|
||||
end Make_Common_Symbol_Objects;
|
||||
begin
|
||||
declare
|
||||
|
||||
@ -164,24 +164,24 @@ package H2.Scheme is
|
||||
type Object_Flags is mod 2 ** 4;
|
||||
Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
|
||||
|
||||
type Syntax_Code is mod 2 ** 4;
|
||||
And_Syntax: constant Syntax_Code := Syntax_Code'(0);
|
||||
Begin_Syntax: constant Syntax_Code := Syntax_Code'(1);
|
||||
Case_Syntax: constant Syntax_Code := Syntax_Code'(2);
|
||||
Cond_Syntax: constant Syntax_Code := Syntax_Code'(3);
|
||||
Define_Syntax: constant Syntax_Code := Syntax_Code'(4);
|
||||
Do_Syntax: constant Syntax_Code := Syntax_Code'(5);
|
||||
If_Syntax: constant Syntax_Code := Syntax_Code'(6);
|
||||
Lambda_Syntax: constant Syntax_Code := Syntax_Code'(7);
|
||||
Let_Syntax: constant Syntax_Code := Syntax_Code'(8);
|
||||
Letast_Syntax: constant Syntax_Code := Syntax_Code'(9);
|
||||
Letrec_Syntax: constant Syntax_Code := Syntax_Code'(10);
|
||||
Or_Syntax: constant Syntax_Code := Syntax_Code'(11);
|
||||
Quasiquote_Syntax: constant Syntax_Code := Syntax_Code'(12);
|
||||
Quote_Syntax: constant Syntax_Code := Syntax_Code'(13);
|
||||
Set_Syntax: constant Syntax_Code := Syntax_Code'(14);
|
||||
type Syntax_Code is (
|
||||
And_Syntax,
|
||||
Begin_Syntax,
|
||||
Case_Syntax,
|
||||
Cond_Syntax,
|
||||
Define_Syntax,
|
||||
Do_Syntax,
|
||||
If_Syntax,
|
||||
Lambda_Syntax,
|
||||
Let_Syntax,
|
||||
Letast_Syntax,
|
||||
Letrec_Syntax,
|
||||
Or_Syntax,
|
||||
Quasiquote_Syntax,
|
||||
Quote_Syntax,
|
||||
Set_Syntax
|
||||
);
|
||||
|
||||
--subtype Procedure_Code is Object_Integer;
|
||||
type Procedure_Code is (
|
||||
Add_Procedure,
|
||||
Callcc_Procedure,
|
||||
@ -224,7 +224,7 @@ package H2.Scheme is
|
||||
|
||||
type Object_Record(Kind: Object_Kind; Size: Object_Size) is record
|
||||
Flags: Object_Flags := 0;
|
||||
Scode: Syntax_Code := 0;
|
||||
Scode: Syntax_Code := Syntax_Code'Val(0);
|
||||
Tag: Object_Tag := Unknown_Object;
|
||||
|
||||
-- Object payload:
|
||||
@ -503,12 +503,6 @@ private
|
||||
Data: Top_Array(1 .. 100) := (others => null);
|
||||
end record;
|
||||
|
||||
type Common_Symbol_Record is record
|
||||
Arrow: Object_Pointer := Nil_Pointer;
|
||||
Quasiquote: Object_Pointer := Nil_Pointer;
|
||||
Quote: Object_Pointer := Nil_Pointer;
|
||||
end record;
|
||||
|
||||
--type Interpreter_Record is tagged limited record
|
||||
type Interpreter_Record is limited record
|
||||
Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
|
||||
@ -525,7 +519,11 @@ private
|
||||
Root_Frame: Object_Pointer := Nil_Pointer;
|
||||
Stack: Object_Pointer := Nil_Pointer;
|
||||
|
||||
Symbol: Common_Symbol_Record;
|
||||
Arrow_Symbol: Object_Pointer := Nil_Pointer;
|
||||
Else_Symbol: Object_Pointer := Nil_Pointer;
|
||||
Quasiquote_Symbol: Object_Pointer := Nil_Pointer;
|
||||
Quote_Symbol: Object_Pointer := Nil_Pointer;
|
||||
|
||||
Top: Top_Record; -- temporary object pointers
|
||||
|
||||
Base_Input: aliased IO_Record;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user