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

implemented a few list manipulation procedures

Browse Source
This commit is contained in:
hyung-hwan 2014-01-19 06:40:23 +00:00
parent 55441b4451
commit f970a410fd
9 changed files with 439 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
configure vendored
View File

@ -2519,7 +2519,7 @@ else
fi 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 cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure # This file is a shell script that caches the results of configure
@ -3240,6 +3240,7 @@ do
case $ac_config_target in case $ac_config_target in
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"lib/Makefile") CONFIG_FILES="$CONFIG_FILES lib/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/lib.gpr") CONFIG_FILES="$CONFIG_FILES lib/lib.gpr" ;;
"lib/libh2.gpr") CONFIG_FILES="$CONFIG_FILES lib/libh2.gpr" ;; "lib/libh2.gpr") CONFIG_FILES="$CONFIG_FILES lib/libh2.gpr" ;;
"cmd/Makefile") CONFIG_FILES="$CONFIG_FILES cmd/Makefile" ;; "cmd/Makefile") CONFIG_FILES="$CONFIG_FILES cmd/Makefile" ;;

1
configure.ac
View File

@ -16,6 +16,7 @@ fi
AC_CONFIG_FILES([ AC_CONFIG_FILES([
Makefile Makefile
lib/Makefile lib/Makefile
lib/GNUmakefile
lib/lib.gpr lib/lib.gpr
lib/libh2.gpr lib/libh2.gpr
cmd/Makefile cmd/Makefile

80
lib/GNUmakefile.in Normal file
View File

@ -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 $<

15
lib/Makefile.in
View File

@ -24,8 +24,9 @@ clean:
distclean: clean distclean: clean
ADAFLAGS := -gnatA -fPIC -gnata -gnato -gnatN -gnatwl -lgnat95 -gnatW8 -g ADAC := $(CC)
BINDFLAGS := -x -shared 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 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 BINDALI := b~h2.adb
libh2: $(ALIS) $(BINDALI) libh2: $(ALIS) $(BINDALI)
gnatbind ${BINDFLAGS} -o b~h2.adb -n -Lh2 $(ALIS) gnatbind ${BINDFLAGS} -o b~h2.adb $(ALIS)
gcc -c -x ada ${ADAFLAGS} b~h2.adb $(ADAC) ${ADAFLAGS} -c b~h2.adb
gcc -shared -o libh2.so $(OBJS) b~h2.o -L. -lgnat $(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.ads
# gcc -c -x ada ${ADAFLAGS} ../../lib/h2-ascii.ads # gcc -c -x ada ${ADAFLAGS} ../../lib/h2-ascii.ads
@ -75,8 +76,8 @@ libh2: $(ALIS) $(BINDALI)
$(BINDALI): $(BINDALI):
%.ali: @abs_srcdir@/%.adb %.ali: @abs_srcdir@/%.adb
gcc -c -x ada ${ADAFLAGS} $< $(ADAC) ${ADAFLAGS} -c $<
%.ali: @abs_srcdir@/%.ads %.ali: @abs_srcdir@/%.ads
gcc -c -x ada ${ADAFLAGS} $< $(ADAC) ${ADAFLAGS} -c $<

315
lib/h2-scheme-execute-apply.adb Normal file
View File

@ -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;

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

@ -305,184 +305,7 @@ Print (Interp, Operand);
null; null;
end Evaluate_Procedure; end Evaluate_Procedure;
procedure Apply is procedure Apply is separate;
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 Fetch_Character is procedure Fetch_Character is
begin begin
@ -1013,6 +836,7 @@ begin
exception exception
when Stream_End_Error => when Stream_End_Error =>
Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN .............");
raise; raise;
when others => when others =>

36
lib/h2-scheme.adb
View File

@ -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_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_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_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_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_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons"
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_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_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" 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_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" 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_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" 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_Divide: constant Object_Character_Array := (1 => Ch.Slash); -- "/" 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 -- EXCEPTIONS
@ -1582,14 +1584,16 @@ Ada.Text_IO.Put_Line ("Make_String...");
procedure Make_Procedure_Objects is procedure Make_Procedure_Objects is
Dummy: Object_Pointer; Dummy: Object_Pointer;
begin begin
Dummy := Make_Procedure (Interp.Self, Car_Procedure, Label_Car); -- "car" Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+"
Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr" Dummy := Make_Procedure (Interp.Self, Car_Procedure, Label_Car); -- "car"
Dummy := Make_Procedure (Interp.Self, Setcar_Procedure, Label_Setcar); -- "setcar" Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr"
Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "setcdr" Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons"
Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" Dummy := Make_Procedure (Interp.Self, Multiply_Procedure, Label_Multiply); -- "*"
Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-" Dummy := Make_Procedure (Interp.Self, Quotient_Procedure, Label_Quotient); -- "quotient"
Dummy := Make_Procedure (Interp.Self, Multiply_Procedure, Label_Multiply); -- "*" Dummy := Make_Procedure (Interp.Self, Remainder_Procedure, Label_Remainder); -- "remainder"
Dummy := Make_Procedure (Interp.Self, Divide_Procedure, Label_Divide); -- "/" 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; end Make_Procedure_Objects;
begin begin
declare declare

18
lib/h2-scheme.ads
View File

@ -180,14 +180,16 @@ package H2.Scheme is
Set_Syntax: constant Syntax_Code := Syntax_Code'(12); Set_Syntax: constant Syntax_Code := Syntax_Code'(12);
subtype Procedure_Code is Object_Integer; subtype Procedure_Code is Object_Integer;
Car_Procedure: constant Procedure_Code := Procedure_Code'(0); Add_Procedure: constant Procedure_Code := Procedure_Code'(0);
Cdr_Procedure: constant Procedure_Code := Procedure_Code'(1); Car_Procedure: constant Procedure_Code := Procedure_Code'(1);
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(2); Cdr_Procedure: constant Procedure_Code := Procedure_Code'(2);
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(3); Cons_Procedure: constant Procedure_Code := Procedure_Code'(3);
Add_Procedure: constant Procedure_Code := Procedure_Code'(4); Multiply_Procedure: constant Procedure_Code := Procedure_Code'(4);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(5); Quotient_Procedure: constant Procedure_Code := Procedure_Code'(5);
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(6); Remainder_Procedure: constant Procedure_Code := Procedure_Code'(6);
Divide_Procedure: constant Procedure_Code := Procedure_Code'(7); 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 ( type Object_Tag is (
Unknown_Object, Unknown_Object,

1
lib/lib.gpr.in
View File

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