commit 988f292571cc3109ec5225a8a1176b176db8f6a1
parent fea60c9f6d0178599bcbedfac82c91103a92eeec
Author: Jan Pobrislo <ccx@te2000.cz>
Date: Sat, 31 May 2025 00:47:41 +0000
Refactor, conditional error throw, test case with recursion.
Diffstat:
| M | interp_errors.pl | | | 39 | ++++++++++++++++++++++++++------------- |
| M | interpreter.pl | | | 120 | +++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------- |
| M | tests.pl | | | 22 | +++++++++++++++++++++- |
3 files changed, 128 insertions(+), 53 deletions(-)
diff --git a/interp_errors.pl b/interp_errors.pl
@@ -1,6 +1,8 @@
:- module(interp_errors,
[ interp_error/2
, interp_error/3
+ , parent_name/1
+ , validate_error/2
]).
%%% messages
@@ -25,29 +27,40 @@ prolog:error_message(interp_error(arity, Func)) -->
prolog:error_message(interp_error(unbound_var, VarName)) -->
[ 'No such variable: "~w".' - [VarName] ].
+prolog:error_message(interp_error(primitive, Func)) -->
+ [ 'Error evaluating primitive function: "~w".' - [Func] ].
+
+prolog:error_message(interp_error(type, Expected)) -->
+ [ 'Got invalid value for type ~w.' - [Expected] ].
+
%%% exception throwing helpers
validate_error(interp_error(eval, _), _) :- !.
validate_error(interp_error(arity, _), _) :- !.
validate_error(interp_error(unbound_var, _), _) :- !.
-validate_error(ErrorVal, Location) :-
+validate_error(interp_error(primitive, _), _) :- !.
+validate_error(interp_error(type, _), _) :- !.
+validate_error(ErrorVal, Caller) :-
throw(error(
domain_error(interp_error/2, ErrorVal),
- context(Location, 'Tried to throw invalid interp_error')
+ context(Caller, 'Tried to throw invalid interp_error')
)).
-validate_and_throw(Error, Location, Message) :-
- validate_error(Error, Location),
- throw(error(Error, context(Location, Message))).
+validate_and_throw(Error, Caller, Message) :-
+ validate_error(Error, Caller),
+ throw(error(Error, context(Caller, Message))).
-interp_error(Kind, ErrorData) :-
+parent_name(Name) :-
prolog_current_frame(ThisFrame),
- prolog_frame_attribute(ThisFrame, parent, ParentFrame),
- prolog_frame_attribute(ParentFrame, predicate_indicator, Location),
- validate_and_throw(interp_error(Kind, ErrorData), Location, _).
+ prolog_frame_attribute(ThisFrame, parent, CallerFrame),
+ prolog_frame_attribute(CallerFrame, parent, CallerParentFrame),
+ prolog_frame_attribute(CallerParentFrame, predicate_indicator, Name).
+
+interp_error(Kind, ErrorData) :-
+ parent_name(Caller),
+ validate_and_throw(interp_error(Kind, ErrorData), Caller, _).
interp_error(Kind, ErrorData, Message) :-
- prolog_current_frame(ThisFrame),
- prolog_frame_attribute(ThisFrame, parent, ParentFrame),
- prolog_frame_attribute(ParentFrame, predicate_indicator, Location),
- validate_and_throw(interp_error(Kind, ErrorData), Location, Message).
+ parent_name(Caller),
+ validate_and_throw(interp_error(Kind, ErrorData), Caller, Message).
+
diff --git a/interpreter.pl b/interpreter.pl
@@ -15,6 +15,19 @@
:- use_module(interp_errors).
+%%%% conditionally throw errors
+interp_check(Condition, Kind, ErrorData) :-
+ parent_name(Caller),
+ validate_and_conditional_throw(Condition, interp_error(Kind, ErrorData), Caller, _).
+
+interp_check(Condition, Kind, ErrorData, Message) :-
+ parent_name(Caller),
+ validate_and_conditional_throw(Condition, interp_error(Kind, ErrorData), Caller, Message).
+
+validate_and_conditional_throw(Condition, Error, Caller, Message) :-
+ validate_error(Error, Caller),
+ ( call(Condition) -> true ; throw(error(Error, context(Caller, Message)))).
+
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Self-evaluating expressions
@@ -55,8 +68,7 @@ extend_environment(OldEnv, VarNames, Values, [NewFrame|OldEnv]) :-
pairs_keys_values(NewFrame, VarNames, Values).
lookup_variable_value(Env, VarName, Value) :-
- ( lookup_variable_value_aux(Env, VarName, Value) -> true
- ; interp_error(unbound_var, VarName)).
+ interp_check(lookup_variable_value_aux(Env, VarName, Value), unbound_var, VarName).
lookup_variable_value_aux([Frame|Env], VarName, Value) :-
lookup_variable_from_frame(Frame, VarName, Value) -> true ; lookup_variable_value_aux(Env, VarName, Value).
@@ -75,18 +87,13 @@ is_definition([define,_,_]).
define_variable(VarName, Value, [OldFrame|EnvTail], [[VarName-Value|OldFrame]|EnvTail]).
-eval_definition([define, VarName, Definition], Value, OldEnv, NewEnv) :-
- interp_eval(Definition, Value, OldEnv, Env1),
- define_variable(VarName, Value, Env1, NewEnv).
-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Assignments
-is_assignment(['set!'|_]).
+%is_assignment(['set!'|_]).
set_variable_value(VarName, Value, OldEnv, NewEnv) :-
- ( set_variable_value_aux(VarName, Value, OldEnv, NewEnv) -> true
- ; interp_error(unbound_var, VarName)).
+ interp_check(set_variable_value_aux(VarName, Value, OldEnv, NewEnv), unbound_var, VarName).
set_variable_value_aux(VarName, Value, [OldFrame|OldE], [NewFrame|NewE]) :-
( set_variable_in_frame(VarName, Value, OldFrame, NewFrame)
@@ -100,10 +107,6 @@ set_variable_in_frame(VarName, Value, [K-_OldV|OldT], [K-NewV|NewT]) :-
NewT = OldT
; set_variable_in_frame(VarName, Value, OldT, NewT)).
-eval_assignment(['set!', VarName, Expression], Env, NewEnv) :-
- interp_eval(Expression, Result, Env, Env1),
- set_variable_value(VarName, Result, Env1, NewEnv).
-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Procedure Construction
@@ -147,6 +150,14 @@ rest_operands([_,_|X], X).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Eval/Apply
+% is_eval_special(quote).
+is_eval_special(define).
+is_eval_special(lambda).
+is_eval_special(if).
+is_eval_special(cond).
+is_eval_special('set!').
+
+
interp_eval_(Expression, Expression, Env, Env) :-
self_evaluating(Expression), !.
interp_eval_([quote, Text], Text, Env, Env) :- !.
@@ -154,16 +165,10 @@ interp_eval_(VarName, Result, Env, Env) :-
variable(VarName),
!,
lookup_variable_value(Env, VarName, Result).
-interp_eval_([define|Tail], Result, Env, NewEnv) :-
- !,
- eval_definition([define|Tail], Result, Env, NewEnv).
-interp_eval_(Expression, void, Env, NewEnv) :-
- is_assignment(Expression),
+interp_eval_([Special|Tail], Result, Env, NewEnv) :-
+ is_eval_special(Special),
!,
- eval_assignment(Expression, Env, NewEnv).
-interp_eval_([lambda, Parameters|Body], Result, Env, Env) :-
- !,
- make_procedure(Parameters, Body, Env, Result).
+ interp_check(interp_eval_special(Special, Tail, Result, Env, NewEnv), eval, [Special|Tail]).
interp_eval_([Operator|Operands], Result, Env, NewEnv) :-
!,
interp_eval(Operator, Procedure, Env, NewEnv),
@@ -172,6 +177,32 @@ interp_eval_([Operator|Operands], Result, Env, NewEnv) :-
interp_eval_(Expression, _, _, _) :-
interp_error(eval, Expression).
+interp_eval_special('set!', [VarName, Expression], '#void', Env, NewEnv) :-
+ interp_eval(Expression, Result, Env, Env1),
+ set_variable_value(VarName, Result, Env1, NewEnv).
+
+interp_eval_special(lambda, [Parameters|Body], Result, Env, Env) :-
+ make_procedure(Parameters, Body, Env, Result).
+
+interp_eval_special(define, [VarName, Definition], '#void', Env, NewEnv) :-
+ interp_eval(Definition, Value, Env, Env1),
+ define_variable(VarName, Value, Env1, NewEnv).
+
+interp_eval_special(cond, Conditions, Result, Env, NewEnv) :-
+ eval_cond(Conditions, Result, Env, NewEnv).
+
+eval_cond([], '#void', Env, Env).
+eval_cond([[else|ThenBody]], Result, Env, NewEnv) :-
+ !,
+ eval_sequence(ThenBody, Result, Env, NewEnv).
+eval_cond([[TestExpr|ThenBody]|Rest], Result, Env, NewEnv) :-
+ interp_eval(TestExpr, TestResult, Env, Env1),
+ ( TestResult =@= '#t'
+ -> eval_sequence(ThenBody, Result, Env1, NewEnv)
+ ; ( TestResult =@= '#f'
+ -> eval_cond(Rest, Result, Env1, NewEnv)
+ ; interp_error(type, bool))).
+
interp_eval(Expression, Result, Env, NewEnv) :-
assertion(ground(Expression)),
assertion(ground(Env)),
@@ -179,26 +210,25 @@ interp_eval(Expression, Result, Env, NewEnv) :-
interp_apply_(primitive(Name, Arity), Arguments, Result) :-
length(Arguments, ALength),
- ( Arity = ALength -> true
- ; interp_error(arity, Name)),
- primitive_apply(Name, Arguments, Result).
+ interp_check(Arity = ALength, arity, Name),
+ interp_check(primitive_apply(Name, Arguments, Result), primitive, Name).
interp_apply_(proc(Parameters, Body, Env), Arguments, Result) :-
- extend_environment(Env, Parameters, Arguments, NewEnv),
- eval_sequence(Body, NewEnv, Result).
+ extend_environment(Env, Parameters, Arguments, Env1),
+ eval_sequence(Body, Result, Env1, _Env2).
interp_apply(Proc, Arguments, Result) :-
assertion(ground(Proc)),
assertion(ground(Arguments)),
interp_apply_(Proc, Arguments, Result).
-eval_sequence([H|T], Env, Result) :-
+eval_sequence([H|T], Result, Env, NextEnv) :-
interp_eval(H, FirstResult, Env, Env1),
- eval_sequence_aux(T, Env1, FirstResult, Result).
+ eval_sequence_aux(T, FirstResult, Result, Env1, NextEnv).
-eval_sequence_aux([], _, Result, Result).
-eval_sequence_aux([H|T], Env, _, Result) :-
+eval_sequence_aux([], Result, Result, Env, Env).
+eval_sequence_aux([H|T], _, Result, Env, NextEnv) :-
interp_eval(H, ThisResult, Env, Env1),
- eval_sequence_aux(T, Env1, ThisResult, Result).
+ eval_sequence_aux(T, ThisResult, Result, Env1, NextEnv).
list_of_values([], _, []).
list_of_values([Name|NameTail], Env, [Value|ValueTail]) :-
@@ -208,18 +238,28 @@ list_of_values([Name|NameTail], Env, [Value|ValueTail]) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Environment Setup
+result_bool(Condition, Result) :-
+ call(Condition) -> Result = '#t' ; Result = '#f'.
+
+primitive_apply('atom?', [X], Result) :- result_bool(atom(X), Result).
+primitive_apply('null?', [X], Result) :- result_bool(X =@= [], Result).
primitive_apply(car, [[H|_]], H).
primitive_apply(cdr, [[_|T]], T).
+
+primitive_apply('eq?', [A,B], Result) :- result_bool(A =@= B, Result).
primitive_apply(cons, [H,T], [H|T]).
primitive_apply(+, [A, B], Result) :- Result is A + B.
-% primitive_apply('[]', [], []).
+primitive_arity('atom?', 1).
+primitive_arity('null?', 1).
primitive_arity(car, 1).
primitive_arity(cdr, 1).
+
+primitive_arity('eq?', 2).
primitive_arity(cons, 2).
primitive_arity(+, 2).
-setup_environment([[true-true, false-false|PrimitiveProcs]]) :-
+setup_environment([['#t'-'#t', '#f'-'#f'|PrimitiveProcs]]) :-
findall(Name-primitive(Name, Arity), primitive_arity(Name, Arity), PrimitiveProcs).
the_global_environment(Env) :- setup_environment(Env).
@@ -250,13 +290,15 @@ interp_loop(Env, InputStream) :-
parse_input_expression(Codes, Expression) :-
phrase(sexp(Expression), Codes).
-sexp(List) --> `(`, blanks, sexp_list(List).
-sexp(Number) --> number(Number).
-sexp(Atom) -->
+sexp(Value) --> blanks, sexp_value(Value).
+
+sexp_value(List) --> `(`, blanks, sexp_list(List).
+sexp_value(Number) --> number(Number).
+sexp_value(Atom) -->
{ ground(Atom) }, !,
{ atom_codes(Atom, Codes) },
Codes.
-sexp(Atom) -->
+sexp_value(Atom) -->
{ var(Atom) }, !,
[Initial],
{ atom_start_code(Initial) },
@@ -275,7 +317,7 @@ atom_start_code(Code) :-
atom_code(Code), \+ code_type(Code, digit).
sexp_list([]) --> `)`.
-sexp_list([Value|Rest]) --> sexp(Value), blanks, sexp_list(Rest).
+sexp_list([Value|Rest]) --> sexp_value(Value), blanks, sexp_list(Rest).
sexp(Content, _, _, Result) :-
phrase_from_quasi_quotation(sexp(Result), Content).
diff --git a/tests.pl b/tests.pl
@@ -101,8 +101,10 @@ quoted_args([], []).
quoted_args([H|T], [[quote, H]|QT]) :- quoted_args(T, QT).
test_eval(Call, ExpectedResult) :-
- format('testing call: ~w → expecting ~w~n', [Call, ExpectedResult]),
the_global_environment(Env),
+ test_eval(Call, ExpectedResult, Env).
+test_eval(Call, ExpectedResult, Env) :-
+ format('testing call: ~w → expecting ~w~n', [Call, ExpectedResult]),
interp_eval(Call, Result, Env, _),
assertion(Result =@= ExpectedResult).
@@ -128,4 +130,22 @@ test(eval_apply_example, [forall(apply_example(Func, Args, ExpectedResult))]) :-
test(eval_example, [forall(eval_example_decoded(Call, ExpectedResult))]) :-
test_eval(Call, ExpectedResult).
+eval_define_lat :-
+ DefLat = {|sexp||
+(define lat?
+ (lambda (l)
+ (cond
+ ((null? l) #t)
+ ((atom? (car l)) (lat? (cdr l)))
+ (else #f))))|},
+ the_global_environment(Env0),
+ interp_eval(DefLat, _, Env0, Env1),
+ Call0 = {|sexp||(lat? (quote ()))|},
+ test_eval(Call0, '#t', Env1),
+ Call1 = {|sexp||(lat? (quote (Jack Sprat could eat no chicken fat)))|},
+ test_eval(Call1, '#t', Env1),
+ Call2 = {|sexp||(lat? (quote ((Jack) Sprat could eat no chicken fat)))|},
+ test_eval(Call2, '#f', Env1).
+test(eval_define_lat) :- eval_define_lat.
+
:- end_tests(eval).
