From 5fd00968e66dbf4ca44c53c5f43445c15d0beca3 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 19 Jan 2014 06:40:23 +0000 Subject: [PATCH] implemented a few list manipulation procedures --- h2/configure | 3 +- h2/configure.ac | 1 + h2/lib/GNUmakefile.in | 80 ++++++++ h2/lib/Makefile.in | 15 +- h2/lib/h2-scheme-execute-apply.adb | 315 +++++++++++++++++++++++++++++ h2/lib/h2-scheme-execute.adb | 180 +---------------- h2/lib/h2-scheme.adb | 36 ++-- h2/lib/h2-scheme.ads | 18 +- h2/lib/lib.gpr.in | 1 + 9 files changed, 439 insertions(+), 210 deletions(-) create mode 100644 h2/lib/GNUmakefile.in create mode 100644 h2/lib/h2-scheme-execute-apply.adb diff --git a/h2/configure b/h2/configure index a9b7159..0f8b588 100755 --- a/h2/configure +++ b/h2/configure @@ -2519,7 +2519,7 @@ else fi -ac_config_files="$ac_config_files Makefile lib/Makefile lib/lib.gpr lib/libh2.gpr cmd/Makefile cmd/scheme.gpr" +ac_config_files="$ac_config_files Makefile lib/Makefile lib/GNUmakefile lib/lib.gpr lib/libh2.gpr cmd/Makefile cmd/scheme.gpr" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure @@ -3240,6 +3240,7 @@ do case $ac_config_target in "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "lib/Makefile") CONFIG_FILES="$CONFIG_FILES lib/Makefile" ;; + "lib/GNUmakefile") CONFIG_FILES="$CONFIG_FILES lib/GNUmakefile" ;; "lib/lib.gpr") CONFIG_FILES="$CONFIG_FILES lib/lib.gpr" ;; "lib/libh2.gpr") CONFIG_FILES="$CONFIG_FILES lib/libh2.gpr" ;; "cmd/Makefile") CONFIG_FILES="$CONFIG_FILES cmd/Makefile" ;; diff --git a/h2/configure.ac b/h2/configure.ac index b222ee8..66fcb54 100644 --- a/h2/configure.ac +++ b/h2/configure.ac @@ -16,6 +16,7 @@ fi AC_CONFIG_FILES([ Makefile lib/Makefile + lib/GNUmakefile lib/lib.gpr lib/libh2.gpr cmd/Makefile diff --git a/h2/lib/GNUmakefile.in b/h2/lib/GNUmakefile.in new file mode 100644 index 0000000..15a5281 --- /dev/null +++ b/h2/lib/GNUmakefile.in @@ -0,0 +1,80 @@ +all: libh2 + +install: install-exec install-data + +install-data: + +install-exec: + +uninstall: + +@abs_builddir@/@ADA_OBJDIR@: + mkdir -p @abs_builddir@/@ADA_OBJDIR@ + +clean: + rm -rf @abs_builddir@/@ADA_OBJDIR@ + rm -f @abs_builddir@/*.ali + rm -f @abs_builddir@/*.so + rm -f @abs_builddir@/*.a + rm -f @abs_builddir@/*.cgpr + +distclean: clean + + +ADAC := $(CC) +ADAFLAGS := -x ada -gnatA -fPIC -gnata -gnato -gnatN -gnatwl -lgnat95 -gnatW8 -g +BINDFLAGS := -x -shared -n -Lh2 + + +SRCS := h2.ads h2-ascii.ads h2-pool.adb h2-scheme.adb h2-utf8.adb h2-wide.ads +ALIS := $(patsubst %.ads,%.ali,$(patsubst %.adb,%.ali,$(SRCS))) +OBJS := $(ALIS:.ali=.o) + +BINDALI := b~h2.adb + +libh2: $(ALIS) $(BINDALI) + gnatbind ${BINDFLAGS} -o b~h2.adb $(ALIS) + $(ADAC) ${ADAFLAGS} -c b~h2.adb + $(ADAC) -shared -o libh2.so $(OBJS) b~h2.o -L. -lgnat + +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2.ads +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-ascii.ads +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-pool.adb +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-scheme.adb +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-utf8.adb +# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-wide.ads +# gnatbind ${BINDFLAGS} -o b~h2.adb -n -Lh2 h2.ali h2-ascii.ali h2-pool.ali h2-scheme.ali h2-utf8.ali h2-wide.ali +# #gnatbind ${BINDFLAGS} -C -o b~h2.c -n -Lh2 h2.ali h2-scheme.ali h2-pool.ali #for a show +# gcc -c -x ada ${ADAFLAGS} b~h2.adb +# gcc -shared -o libh2.so h2.o h2-ascii.o h2-pool.o h2-scheme.o h2-utf8.o h2-wide.o b~h2.o -L. -lgnat +# #gnatlink -v -v -olibh2.so h2 + + +#h2cmd: +# gcc -c -x ada ${ADAFLAGS} -I../../lib ../../cmd/storage.adb +# gcc -c -x ada ${ADAFLAGS} -I../../lib ../../cmd/stream.adb +# gcc -c -x ada ${ADAFLAGS} -I../../lib ../../cmd/scheme.adb +# gnatbind ${BINDFLAGS} -o b~scheme.adb scheme.ali storage.ali #-I- -I. -O +# gcc -c -x ada ${ADAFLAGS} b~scheme.adb +# gcc -oh2scm b~scheme.o storage.o stream.o scheme.o -L. -lh2 -Wl,-rpath=. #-lgnat-4.1 +# #gnatlink -v -v -o h2scm scheme +# #/usr/bin/gnatbind -x -shared -o b__scheme.adb ./scheme.ali ./storage.ali -I- -I. -I../lib/objdir -O +# #gcc -c -x ada -gnatA -gnata -gnato -gnatN -gnatwl -c -gnatA -gnatWb -gnatiw -gnatws b__scheme.adb -o b__scheme.o +# #gcc -oh2scm scheme.o b__scheme.o storage.o -shared-libgcc -L../lib -lh2 -Wl,-rpath=../lib -L -lgna + + +#.SUFFIXES: .ads .adb .ali +#.ads.ali: +# gcc -c -x ada ${ADAFLAGS} @abs_srcdir@/$< +# +#.adb.ali: +# gcc -c -x ada ${ADAFLAGS} @abs_srcdir@/$< + +$(BINDALI): + +%.ali: @abs_srcdir@/%.adb + $(ADAC) ${ADAFLAGS} -c $< + +%.ali: @abs_srcdir@/%.ads + $(ADAC) ${ADAFLAGS} -c $< + diff --git a/h2/lib/Makefile.in b/h2/lib/Makefile.in index cc7688f..52d14ec 100644 --- a/h2/lib/Makefile.in +++ b/h2/lib/Makefile.in @@ -24,8 +24,9 @@ clean: distclean: clean -ADAFLAGS := -gnatA -fPIC -gnata -gnato -gnatN -gnatwl -lgnat95 -gnatW8 -g -BINDFLAGS := -x -shared +ADAC := $(CC) +ADAFLAGS := -x ada -gnatA -fPIC -gnata -gnato -gnatN -gnatwl -lgnat95 -gnatW8 -g +BINDFLAGS := -x -shared -n -Lh2 SRCS := h2.ads h2-ascii.ads h2-pool.adb h2-scheme.adb h2-utf8.adb h2-wide.ads @@ -35,9 +36,9 @@ OBJS := $(ALIS:.ali=.o) BINDALI := b~h2.adb libh2: $(ALIS) $(BINDALI) - gnatbind ${BINDFLAGS} -o b~h2.adb -n -Lh2 $(ALIS) - gcc -c -x ada ${ADAFLAGS} b~h2.adb - gcc -shared -o libh2.so $(OBJS) b~h2.o -L. -lgnat + gnatbind ${BINDFLAGS} -o b~h2.adb $(ALIS) + $(ADAC) ${ADAFLAGS} -c b~h2.adb + $(LD) -shared -o libh2.so $(OBJS) b~h2.o -L. -lgnat # gcc -c -x ada ${ADAFLAGS} ../../lib/h2.ads # gcc -c -x ada ${ADAFLAGS} ../../lib/h2-ascii.ads @@ -75,8 +76,8 @@ libh2: $(ALIS) $(BINDALI) $(BINDALI): %.ali: @abs_srcdir@/%.adb - gcc -c -x ada ${ADAFLAGS} $< + $(ADAC) ${ADAFLAGS} -c $< %.ali: @abs_srcdir@/%.ads - gcc -c -x ada ${ADAFLAGS} $< + $(ADAC) ${ADAFLAGS} -c $< diff --git a/h2/lib/h2-scheme-execute-apply.adb b/h2/lib/h2-scheme-execute-apply.adb new file mode 100644 index 0000000..45f5b1a --- /dev/null +++ b/h2/lib/h2-scheme-execute-apply.adb @@ -0,0 +1,315 @@ + +separate (H2.Scheme.Execute) + +procedure Apply is + pragma Inline (Apply); + + Operand: aliased Object_Pointer; + Func: aliased Object_Pointer; + Args: aliased Object_Pointer; + + -- ------------------------------------------------------------- + -- List manipulation procedures + -- ------------------------------------------------------------- + procedure Apply_Car_Procedure is + Ptr: Object_Pointer := Args; + A: Object_Pointer; + begin + if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then +Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CAR"); + raise Syntax_Error; + end if; + + A := Get_Car(Ptr); -- the first argument + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Get_Car(A)); + end Apply_Car_Procedure; + + procedure Apply_Cdr_Procedure is + Ptr: Object_Pointer := Args; + A: Object_Pointer; + begin + if Ptr = Nil_Pointer or else Get_Cdr(Ptr) /= Nil_Pointer then +Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CDR"); + raise Syntax_Error; + end if; + + A := Get_Car(Ptr); -- the first argument + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(A)); + end Apply_Cdr_Procedure; + + procedure Apply_Cons_Procedure is + Ptr: Object_Pointer := Args; + 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 +Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR CONS"); + raise Syntax_Error; + end if; + + A := Get_Car(Ptr); -- the first argument + B := Get_Car(Get_Cdr(Ptr)); -- the second argument + Ptr := Make_Cons (Interp.Self, A, B); -- change car + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Ptr); + end Apply_Cons_Procedure; + + procedure Apply_Setcar_Procedure is + Ptr: Object_Pointer := Args; + 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 +Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!"); + raise Syntax_Error; + end if; + + A := Get_Car(Ptr); -- the first argument + B := Get_Car(Get_Cdr(Ptr)); -- the second argument + Set_Car (A, B); -- change car + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, A); + end Apply_Setcar_Procedure; + + procedure Apply_Setcdr_Procedure is + Ptr: Object_Pointer := Args; + 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 +Ada.Text_IO.Put ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!"); + raise Syntax_Error; + end if; + + A := Get_Car(Ptr); -- the first argument + B := Get_Car(Get_Cdr(Ptr)); -- the second argument + Set_Cdr (A, B); -- change cdr + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, A); + end Apply_Setcdr_Procedure; + + -- ------------------------------------------------------------- + -- Arithmetic procedures + -- ------------------------------------------------------------- + procedure Apply_Add_Procedure is + Ptr: Object_Pointer := Args; + Num: Object_Integer := 0; -- TODO: support BIGNUM + Car: Object_Pointer; + begin + while Ptr /= Nil_Pointer loop + -- TODO: check if car is an integer or bignum or something else. + -- if something else, error + Car := Get_Car(Ptr); + if not Is_Integer(Car) then +Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); + raise Evaluation_Error; + end if; + Num := Num + Pointer_To_Integer(Car); + Ptr := Get_Cdr(Ptr); + end loop; + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); + end Apply_Add_Procedure; + + procedure Apply_Subtract_Procedure is + Ptr: Object_Pointer := Args; + Num: Object_Integer := 0; -- TODO: support BIGNUM + Car: Object_Pointer; + begin + if Ptr /= Nil_Pointer then + Car := Get_Car(Ptr); + if not Is_Integer(Car) then + raise Evaluation_Error; + end if; + Num := Pointer_To_Integer(Car); + + while Ptr /= Nil_Pointer loop + -- TODO: check if car is an integer or bignum or something else. + -- if something else, error + Car := Get_Car(Ptr); + if not Is_Integer(Car) then + raise Evaluation_Error; + end if; + Num := Num - Pointer_To_Integer(Car); + Ptr := Get_Cdr(Ptr); + end loop; + end if; + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); + end Apply_Subtract_Procedure; + + procedure Apply_Multiply_Procedure is + Ptr: Object_Pointer := Args; + Num: Object_Integer := 1; -- TODO: support BIGNUM + Car: Object_Pointer; + begin + while Ptr /= Nil_Pointer loop + -- TODO: check if car is an integer or bignum or something else. + -- if something else, error + Car := Get_Car(Ptr); + if not Is_Integer(Car) then +Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); + raise Evaluation_Error; + end if; + Num := Num * Pointer_To_Integer(Car); + Ptr := Get_Cdr(Ptr); + end loop; + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); + end Apply_Multiply_Procedure; + + procedure Apply_Quotient_Procedure is + Ptr: Object_Pointer := Args; + Num: Object_Integer := 1; -- TODO: support BIGNUM + Car: Object_Pointer; + begin + while Ptr /= Nil_Pointer loop + -- TODO: check if car is an integer or bignum or something else. + -- if something else, error + Car := Get_Car(Ptr); + if not Is_Integer(Car) then +Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); + raise Evaluation_Error; + end if; + Num := Num * Pointer_To_Integer(Car); + Ptr := Get_Cdr(Ptr); + end loop; + + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); + end Apply_Quotient_Procedure; + + procedure Apply_Closure is + Fbody: aliased Object_Pointer; + Param: aliased Object_Pointer; + Arg: aliased Object_Pointer; + begin + Push_Top (Interp, Fbody'Unchecked_Access); + Push_Top (Interp, Param'Unchecked_Access); + Push_Top (Interp, Arg'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))" + + -- Push a new environmen for the closure + 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. + + Param := Get_Car(Fbody); -- Parameter list + --Arg := Get_Car(Args); -- Actual argument list + Arg := Args; -- Actual argument list + + Fbody := Get_Cdr (Fbody); -- Real function body + pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel.. + + while Is_Cons(Param) loop + + if not Is_Cons(Arg) then + Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); + raise Evaluation_Error; + end if; + + -- Insert the key/value pair into the environment + Set_Environment (Interp, Get_Car(Param), Get_Car(Arg)); + + Param := Get_Cdr(Param); + Arg := Get_Cdr(Arg); + 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; + + -- Perform cosmetic checks for the argument list + if Is_Cons(Arg) then + Ada.Text_IO.Put_Line (">>>> Two many arguments <<<<"); + raise Evaluation_Error; + elsif Arg /= Nil_Pointer then + Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); + raise Syntax_Error; + end if; + +-- TODO: is it correct to keep the environement in the frame? + Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); + Set_Frame_Operand (Interp.Stack, Fbody); + Clear_Frame_Result (Interp.Stack); + + Pop_Tops (Interp, 3); + end Apply_Closure; + +begin + Push_Top (Interp, Operand'Unchecked_Access); + Push_Top (Interp, Func'Unchecked_Access); + Push_Top (Interp, Args'Unchecked_Access); + + Operand := Get_Frame_Operand(Interp.Stack); + pragma Assert (Is_Cons(Operand)); + +Print (Interp, Operand); + Func := Get_Car(Operand); + if not Is_Normal_Pointer(Func) then + Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); + raise Evaluation_Error; + end if; + + Args := Get_Cdr(Operand); + + case Func.Tag is + when Procedure_Object => + case Get_Procedure_Opcode(Func) is + + when Car_Procedure => + Apply_Car_Procedure; + when Cdr_Procedure => + Apply_Cdr_Procedure; + when Cons_Procedure => + Apply_Cons_Procedure; + when Setcar_Procedure => + Apply_Setcar_Procedure; + when Setcdr_Procedure => + Apply_Setcdr_Procedure; + + + when Add_Procedure => + Apply_Add_Procedure; + when Subtract_Procedure => + Apply_Subtract_Procedure; + when Multiply_Procedure => + Apply_Multiply_Procedure; + when Quotient_Procedure => + Apply_Quotient_Procedure; + --when Remainder_Procedure => + -- Apply_Remainder_Procedure; + + when others => + raise Internal_Error; + end case; + + when Closure_Object => + Apply_Closure; + + when Continuation_Object => + null; + + when others => + Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); + raise Internal_Error; + + end case; + + Pop_Tops (Interp, 3); +end Apply; diff --git a/h2/lib/h2-scheme-execute.adb b/h2/lib/h2-scheme-execute.adb index 72c05bd..baf7533 100644 --- a/h2/lib/h2-scheme-execute.adb +++ b/h2/lib/h2-scheme-execute.adb @@ -305,184 +305,7 @@ Print (Interp, Operand); null; end Evaluate_Procedure; - procedure Apply is - pragma Inline (Apply); - - Operand: aliased Object_Pointer; - Func: aliased Object_Pointer; - Args: aliased Object_Pointer; - - procedure Apply_Car_Procedure is - begin - Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Args)); - end Apply_Car_Procedure; - - procedure Apply_Cdr_Procedure is - begin - Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(Args)); - end Apply_Cdr_Procedure; - - procedure Apply_Add_Procedure is - Ptr: Object_Pointer := Args; - Num: Object_Integer := 0; -- TODO: support BIGNUM - Car: Object_Pointer; - begin - while Ptr /= Nil_Pointer loop - -- TODO: check if car is an integer or bignum or something else. - -- if something else, error - Car := Get_Car(Ptr); - if not Is_Integer(Car) then -Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); - raise Evaluation_Error; - end if; - Num := Num + Pointer_To_Integer(Car); - Ptr := Get_Cdr(Ptr); - end loop; - - Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); - end Apply_Add_Procedure; - - procedure Apply_Subtract_Procedure is - Ptr: Object_Pointer := Args; - Num: Object_Integer := 0; -- TODO: support BIGNUM - Car: Object_Pointer; - begin - if Ptr /= Nil_Pointer then - Car := Get_Car(Ptr); - if not Is_Integer(Car) then - raise Evaluation_Error; - end if; - Num := Pointer_To_Integer(Car); - - while Ptr /= Nil_Pointer loop - -- TODO: check if car is an integer or bignum or something else. - -- if something else, error - Car := Get_Car(Ptr); - if not Is_Integer(Car) then - raise Evaluation_Error; - end if; - Num := Num - Pointer_To_Integer(Car); - Ptr := Get_Cdr(Ptr); - end loop; - end if; - - Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num)); - end Apply_Subtract_Procedure; - - procedure Apply_Closure is - Fbody: aliased Object_Pointer; - Param: aliased Object_Pointer; - Arg: aliased Object_Pointer; - begin - Push_Top (Interp, Fbody'Unchecked_Access); - Push_Top (Interp, Param'Unchecked_Access); - Push_Top (Interp, Arg'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))" - - -- Push a new environmen for the closure - 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. - - Param := Get_Car(Fbody); -- Parameter list - --Arg := Get_Car(Args); -- Actual argument list - Arg := Args; -- Actual argument list - - Fbody := Get_Cdr (Fbody); -- Real function body - pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel.. - - while Is_Cons(Param) loop - - if not Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); - raise Evaluation_Error; - end if; - - -- Insert the key/value pair into the environment - Set_Environment (Interp, Get_Car(Param), Get_Car(Arg)); - - Param := Get_Cdr(Param); - Arg := Get_Cdr(Arg); - 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; - - -- Perform cosmetic checks for the argument list - if Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> Two many arguments <<<<"); - raise Evaluation_Error; - elsif Arg /= Nil_Pointer then - Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); - raise Syntax_Error; - end if; - --- TODO: is it correct to keep the environement in the frame? - Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); - Set_Frame_Operand (Interp.Stack, Fbody); - Clear_Frame_Result (Interp.Stack); - - Pop_Tops (Interp, 3); - end Apply_Closure; - - begin - Push_Top (Interp, Operand'Unchecked_Access); - Push_Top (Interp, Func'Unchecked_Access); - Push_Top (Interp, Args'Unchecked_Access); - - Operand := Get_Frame_Operand(Interp.Stack); - pragma Assert (Is_Cons(Operand)); - -Print (Interp, Operand); - Func := Get_Car(Operand); - if not Is_Normal_Pointer(Func) then - Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); - raise Evaluation_Error; - end if; - - Args := Get_Cdr(Operand); - - case Func.Tag is - when Procedure_Object => - case Get_Procedure_Opcode(Func) is - when Car_Procedure => - Apply_Car_Procedure; - when Cdr_Procedure => - Apply_Cdr_Procedure; - - when Add_Procedure => - Apply_Add_Procedure; - when Subtract_Procedure => - Apply_Subtract_Procedure; - - when others => - raise Internal_Error; - end case; - - when Closure_Object => - Apply_Closure; - - when Continuation_Object => - null; - - when others => - Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); - raise Internal_Error; - - end case; - - Pop_Tops (Interp, 3); - end Apply; + procedure Apply is separate; procedure Fetch_Character is begin @@ -1013,6 +836,7 @@ begin exception when Stream_End_Error => +Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ............."); raise; when others => diff --git a/h2/lib/h2-scheme.adb b/h2/lib/h2-scheme.adb index 78a676a..acbb5f3 100644 --- a/h2/lib/h2-scheme.adb +++ b/h2/lib/h2-scheme.adb @@ -40,14 +40,16 @@ package body H2.Scheme is Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" - 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_Setcar: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "setcar" - Label_Setcdr: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "setcar" - 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_Divide: constant Object_Character_Array := (1 => Ch.Slash); -- "/" + 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_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); -- "*" ----------------------------------------------------------------------------- -- EXCEPTIONS @@ -1582,14 +1584,16 @@ Ada.Text_IO.Put_Line ("Make_String..."); procedure Make_Procedure_Objects is Dummy: Object_Pointer; begin - 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, Setcar_Procedure, Label_Setcar); -- "setcar" - Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "setcdr" - Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" - Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-" - Dummy := Make_Procedure (Interp.Self, Multiply_Procedure, Label_Multiply); -- "*" - Dummy := Make_Procedure (Interp.Self, Divide_Procedure, Label_Divide); -- "/" + 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); -- "-" end Make_Procedure_Objects; begin declare diff --git a/h2/lib/h2-scheme.ads b/h2/lib/h2-scheme.ads index eac1786..68856fd 100644 --- a/h2/lib/h2-scheme.ads +++ b/h2/lib/h2-scheme.ads @@ -180,14 +180,16 @@ package H2.Scheme is Set_Syntax: constant Syntax_Code := Syntax_Code'(12); subtype Procedure_Code is Object_Integer; - Car_Procedure: constant Procedure_Code := Procedure_Code'(0); - Cdr_Procedure: constant Procedure_Code := Procedure_Code'(1); - Setcar_Procedure: constant Procedure_Code := Procedure_Code'(2); - Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(3); - Add_Procedure: constant Procedure_Code := Procedure_Code'(4); - Subtract_Procedure: constant Procedure_Code := Procedure_Code'(5); - Multiply_Procedure: constant Procedure_Code := Procedure_Code'(6); - Divide_Procedure: constant Procedure_Code := Procedure_Code'(7); + 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); type Object_Tag is ( Unknown_Object, diff --git a/h2/lib/lib.gpr.in b/h2/lib/lib.gpr.in index c5a13b7..043ab97 100644 --- a/h2/lib/lib.gpr.in +++ b/h2/lib/lib.gpr.in @@ -15,6 +15,7 @@ project Lib is "h2-scheme.adb", "h2-scheme.ads", "h2-scheme-execute.adb", + "h2-scheme-execute-apply.adb", "h2-scheme-token.adb", "h2-utf8.adb", "h2-utf8.ads",