interpl

commit ef83e0383499ee1b1e52d2610fa39f5ba2191d79
Author: Jan Pobrislo <ccx@te2000.cz>
Date:   Fri, 30 May 2025 13:16:45 +0000

initial commit

Diffstat:
A
Makefile
 | 
2
++
A
interpreter.pl
 | 
250
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
tests.pl
 | 
40
++++++++++++++++++++++++++++++++++++++++

3 files changed, 292 insertions(+), 0 deletions(-)
diff --git a/Makefile b/Makefile
@@ -0,0 +1,2 @@
+tests:
+	swipl -g run_tests -t halt tests.pl
diff --git a/interpreter.pl b/interpreter.pl
@@ -0,0 +1,250 @@
+%% #!/usr/bin/env swipl
+:- module(interpreter,
+	[ parse_input_expression/2
+	]).
+:- use_module(library(debug), [assertion/1]).
+:- use_module(library(pairs)).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Self-evaluating expressions
+
+% (self-evaluating? 1) => true
+% (self-evaluating? "test") => true
+% (self-evaluating? '(a b c)) => false
+self_evaluating(Exp) :- number(Exp).
+self_evaluating(Exp) :- string(Exp).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Quoted expressions
+quoted([quote|Rest], Rest).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Variables and environment
+
+variable(Exp) :- atom(Exp).
+
+frame_variables(Frame, Variables) :- pairs_keys(Frame, Variables).
+frame_values(Frame, Variables) :- pairs_values(Frame, Variables).
+add_binding_to_frame(VarName, Value, OldFrame, [VarName-Value|OldFrame]).
+
+% (enclosing-environment '(((a) . (1)) . ())) => '()
+enclosing_environment([_|Env], Env).
+
+% (first-frame '(((a) . (1)) . ())) => '((a) . (1))
+first_frame([Frame|_], Frame).
+
+% No bindings, no enclosing environment
+empty_environment([]).
+
+% (extend-environment '(a) '(1) '())
+% => '(((a) . (1)) . ())
+extend_environment(OldEnv, VarNames, Values, [NewFrame|OldEnv]) :-
+	length(VarNames, VarLength),
+	length(Values, ValLength),
+	assertion(VarLength =@= ValLength),
+	pairs_keys_values(NewFrame, VarNames, Values).
+
+lookup_variable_value(Env, VarName, Value) :-
+	lookup_variable_value_aux(Env, VarName, Value) -> true ; assertion(false).  % unbound variable
+lookup_variable_value_aux([Frame|Env], VarName, Value) :-
+	lookup_variable_from_frame(Frame, VarName, Value) -> true ; lookup_variable_value_aux(Env, VarName, Value).
+lookup_variable_from_frame([K-V|Rest], VarName, Value) :-
+	VarName = K -> V = Value ; lookup_variable_from_frame(Rest, VarName, Value).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Definitions
+
+% (definition? '(define x 1)) => true
+% (definition? '(quote x)) => false
+is_definition([define,_,_]).
+
+%definition_variable([define, VarName, _], VarName).
+%definition_value([define, _, Value], Value).
+
+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!'|_]).
+
+set_variable_value(VarName, Value, OldEnv, NewEnv) :-
+	set_variable_value_aux(VarName, Value, OldEnv, NewEnv) -> true ; assertion(false).
+
+set_variable_value_aux(VarName, Value, [OldFrame|OldE], [NewFrame|NewE]) :-
+	(  set_variable_in_frame(VarName, Value, OldFrame, NewFrame)
+	-> OldE = NewE
+	;  OldFrame = NewFrame,
+	   set_variable_value_aux(VarName, Value, OldE, NewE)).
+
+set_variable_in_frame(VarName, Value, [K-_OldV|OldT], [K-NewV|NewT]) :-
+	(  VarName = K
+	-> NewV = Value,
+	   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
+
+% (lambda? '(lambda () 1)) => 1
+is_lambda([lambda, Vars|_]) :- is_list(Vars).
+
+% (lambda-parameters '(lambda () 1)) => '()
+%% (define (lambda-parameters exp) (cadr exp))
+% (lambda-body '(lambda () 1)) => '(1)
+%% (define (lambda-body exp) (cddr exp))
+
+make_procedure(Parameters, Body, Env, proc(Parameters, Body, Env)).
+
+%compound_procedure(proc(_,_,_)).
+%(define (compound-procedure? p)
+%  (tagged-list? p 'procedure))
+%(define (procedure-parameters p) (cadr p))
+%(define (procedure-body p) (caddr p))
+%(define (procedure-environment p) (cadddr p))
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Application Expressions
+
+%(define (application? exp) (pair? exp))
+is_application([_|_]).
+%(define (operator exp) (car exp))
+operator([Operator|_], Operator).
+%(define (operands exp) (cdr exp))
+operands([_|Operands], Operands).
+%(define (no-operands? ops) (null? ops))
+operands([_|Operands], Operands).
+%(define (first-operand ops) (car ops))
+first_operand([_,X|_], X).
+%(define (rest-operands ops) (cdr ops))
+rest_operands([_,_|X], X).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Primitive Procedures
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Eval/Apply
+
+interp_eval(Expression, Expression, Env, Env) :-
+	self_evaluating(Expression), !.
+interp_eval([quoted|Rest], Rest, Env, Env) :- !.
+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),
+	!,
+	eval_assignment(Expression, Env, NewEnv).
+interp_eval([lambda, Parameters|Body], Result, Env, Env) :-
+	make_procedure(Parameters, Body, Env, Result).
+interp_eval([Operator|Operands], Result, Env, NewEnv) :-
+	!,
+	interp_eval(Operator, Procedure, Env, NewEnv),
+	list_of_values(Operands, Env, Arguments),
+	interp_apply(Procedure, Arguments, Result).
+interp_eval(_, _, _, _) :- assertion(false).
+
+interp_apply(primitive(Name), Arguments, Result) :-
+	primitive_apply(Name, Arguments, Result).
+interp_apply(proc(Parameters, Body, Env), Arguments, Result) :-
+	extend_environment(Env, Parameters, Arguments, NewEnv),
+	eval_sequence(Body, NewEnv, Result).
+
+eval_sequence([H|T], Env, Result) :-
+	interp_eval(H, FirstResult, Env, Env1),
+	eval_sequence_aux(T, Env1, FirstResult, Result).
+
+eval_sequence_aux([], _, Result, Result).
+eval_sequence_aux([H|T], Env, _, Result) :-
+	interp_eval(H, ThisResult, Env, Env1),
+	eval_sequence_aux(T, Env1, ThisResult, Result).
+
+list_of_values([], _, []).
+list_of_values([Name|NameTail], Env, [Value|ValueTail]) :-
+	interp_eval(Name, Value, Env, Env),  % enforces environment does not change
+	list_of_values(NameTail, ValueTail).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Environment Setup
+
+primitive_apply(car, [[H|_]], H).
+primitive_apply(cdr, [[_|T]], T).
+primitive_apply(cons, [H,T], [H|T]).
+primitive_apply(+, [A, B], Result) :- Result is A + B.
+% primitive_apply('[]', [], []).
+
+setup_environment([[
+	car-primitive(car),
+	cdr-primitive(cdr),
+	cons-primitive(cons),
+	(+)-primitive(+),
+	true-true,
+	false-false
+]]).
+
+the_global_environment(Env) :- setup_environment(Env).
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Driver
+
+user_print(proc(Parameters, Body, _)) :-
+	format('→ proc(~w, ~w, <env>)~n', [Parameters, Body]).
+
+interp_loop(Env, InputStream) :-
+	write('? '),
+	Here=interp_loop/1,
+	( read_line_to_codes(InputStream, Codes) -> true
+	; throw(error(read_error, context(Here, 'Failed to read line.')))),
+	format('got input: "~s"~n', [Codes]),
+	( parse_input_expression(Codes, Expression) -> true
+	; throw(error(parse_error(Codes), context(Here, 'Failed to parse line.')))),
+	( interp_eval(Expression, Result, Env, NewEnv) -> true
+	; throw(error(evaluation_error(Codes), context(Here, 'Failed to evaluate expression.')))),
+	user_print(Result),
+	nl,
+	interp_loop(NewEnv, InputStream).
+
+% errors {{{1
+
+:- multifile prolog:error_message//1.
+prolog:error_message(read_error) -->
+    [ 'Failed to read line.' ].
+
+prolog:error_message(parse_error(Codes)) -->
+    [ 'Failed to parse line: "~s".' - [Codes] ].
+
+prolog:error_message(evaluation_error(Codes)) -->
+    [ 'Failed to evaluate expression: "~s".' - [Codes] ].
+
+% grammar {{{1
+
+parse_input_expression(Codes, Expression) :-
+	phrase(sexp(Expression), Codes).
+
+sexp(_Expression) --> { false }.  % TODO
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% Interpreter wrapper
+
+% main {{{1
+%main :- current_prolog_flag(argv, Argv), main(Argv).
+
+%:- initialization(main, main).
+main(_Args) :-
+	current_stream(0, read, StdInStream),
+	the_global_environment(Env),
+	interp_loop(Env, StdInStream).
diff --git a/tests.pl b/tests.pl
@@ -0,0 +1,40 @@
+:- use_module(library(debug), [assertion/1]).
+
+:- use_module(interpreter).
+
+test_one_result(Template, Goal, Output) :-
+	findall(Template, Goal, Results),
+	assertion(length(Results, 1)),
+	Results = [Output].
+
+:- begin_tests(sexp).
+
+test(sexp_atom) :-
+	parse_input_expression(`a`, Expression),
+	assertion(Expression =@= a).
+
+test(sexp_atom2) :-
+	parse_input_expression(`hello-world!`, Expression),
+	assertion(Expression =@= 'hello-world!').
+
+test(sexp_number) :-
+	parse_input_expression(`0`, Expression),
+	assertion(Expression =@= 0).
+
+test(sexp_number2) :-
+	parse_input_expression(`31337`, Expression),
+	assertion(Expression =@= 31337).
+
+test(sexp_list_empty) :-
+	parse_input_expression(`()`, Expression),
+	assertion(Expression =@= []).
+
+test(sexp_list_one_atom) :-
+	parse_input_expression(`(a)`, Expression),
+	assertion(Expression =@= [a]).
+
+test(sexp_list_one_two_atoms) :-
+	parse_input_expression(`(a)`, Expression),
+	assertion(Expression =@= [a, b]).
+
+:- end_tests(sexp).