interpreter.pl (11109B)
1 %% #!/usr/bin/env swipl 2 :- module(interpreter, 3 [ parse_input_expression/2 4 , sexp//1 5 , sexp/4 6 , interp_apply/5 7 , interp_eval/4 8 , lookup_variable_value/4 9 , initial_state/1 10 , primitive_arity/2 11 ]). 12 :- use_module(library(debug), [assertion/1]). 13 :- use_module(library(dcg/basics), [blanks//0, number//1]). 14 :- use_module(library(quasi_quotations), [phrase_from_quasi_quotation/2, quasi_quotation_syntax/1]). 15 :- use_module(library(assoc), [get_assoc/3, put_assoc/4]). 16 :- use_module(library(pairs), [pairs_keys_values/3]). 17 18 :- use_module(interp_errors). 19 :- use_module(interp_state). 20 21 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 22 %% conditionally throw errors 23 interp_check(Condition, Kind, ErrorData) :- 24 parent_name(Caller), 25 validate_and_conditional_throw(Condition, interp_error(Kind, ErrorData), Caller, _). 26 27 interp_check(Condition, Kind, ErrorData, Message) :- 28 parent_name(Caller), 29 validate_and_conditional_throw(Condition, interp_error(Kind, ErrorData), Caller, Message). 30 31 interp_check(Condition, Kind, ErrorData, StateIn, StateOut) :- 32 parent_name(Caller), 33 validate_and_conditional_throw(call(Condition, StateIn, StateOut), interp_error(Kind, ErrorData), Caller, _). 34 35 interp_check(Condition, Kind, ErrorData, Message, StateIn, StateOut) :- 36 parent_name(Caller), 37 validate_and_conditional_throw(call(Condition, StateIn, StateOut), interp_error(Kind, ErrorData), Caller, Message). 38 39 validate_and_conditional_throw(Condition, Error, Caller, Message) :- 40 validate_error(Error, Caller), 41 ( call(Condition) -> true ; throw(error(Error, context(Caller, Message)))). 42 43 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 44 %% Interpreter state 45 initial_state(State) :- 46 global_frame(Frame), 47 empty_state(Empty), 48 State = Empty.new_frame(Frame). 49 50 % :=(DictKey, Value, StateIn, StateOut) :- 51 % assertion(is_dict(StateIn, interp_state)), 52 % put_dict(DictKey, StateIn, Value, StateOut). 53 54 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 55 %% Self-evaluating expressions 56 57 % (self-evaluating? 1) => true 58 % (self-evaluating? "test") => true 59 % (self-evaluating? '(a b c)) => false 60 self_evaluating(Exp) :- number(Exp). 61 self_evaluating(Exp) :- string(Exp). 62 63 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 64 %% Quoted expressions 65 66 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 67 %% Variables and environment 68 69 variable(Exp) :- atom(Exp). 70 71 % (extend-environment '(a) '(1) '()) 72 % => '(((a) . (1)) . ()) 73 extend_environment(VarNames, Values, StateIn, StateOut) :- 74 length(VarNames, VarLength), 75 length(Values, ValLength), 76 assertion(VarLength =@= ValLength), 77 pairs_keys_values(NewFrame, VarNames, Values), 78 StateOut = StateIn.new_frame(NewFrame). 79 80 lookup_variable_value(VarName, Value, State, State) :- 81 ( lookup_variable_value_aux(State.env, State.frames, VarName, Value) -> true 82 ; interp_error(unbound_var, VarName) ). 83 84 lookup_variable_value_aux([FrameNo|Env], Frames, VarName, Value) :- 85 get_assoc(FrameNo, Frames, Frame), 86 lookup_variable_from_frame(Frame, VarName, Value) -> true ; lookup_variable_value_aux(Env, Frames, VarName, Value). 87 lookup_variable_from_frame([K-V|Rest], VarName, Value) :- 88 VarName = K -> V = Value ; lookup_variable_from_frame(Rest, VarName, Value). 89 90 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 91 %% Definitions 92 93 define_variable(VarName, Value, StateIn, StateOut) :- 94 StateOut = StateIn.update_current_frame([VarName-Value|StateIn.current_frame()]). 95 96 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 97 %% Assignments 98 99 set_variable_value(VarName, Value, StateIn, StateIn.put(frames, FramesOut)) --> 100 interp_check(set_variable_value_aux(VarName, Value, StateIn.env, StateIn.frames, FramesOut), unbound_var, VarName). 101 102 set_variable_value_aux(VarName, Value, [EHead|ETail], FramesIn, FramesOut) :- 103 get_assoc(EHead, FramesIn, OldFrame), 104 ( set_variable_in_frame(VarName, Value, OldFrame, NewFrame) 105 -> put_assoc(EHead, FramesIn, NewFrame, FramesOut) 106 ; set_variable_value_aux(VarName, Value, ETail, FramesIn, FramesOut)). 107 108 set_variable_in_frame(VarName, Value, [K-_OldV|OldT], [K-NewV|NewT]) :- 109 ( VarName = K 110 -> NewV = Value, 111 NewT = OldT 112 ; set_variable_in_frame(VarName, Value, OldT, NewT)). 113 114 115 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 116 %% Procedure Construction 117 118 make_procedure(Parameters, Body, proc(Parameters, Body, State.env), State, State). 119 120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 121 %% Application Expressions 122 123 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 124 %% Primitive Procedures 125 126 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 127 %% Eval/Apply 128 129 % is_eval_special(quote). % evaluated before variable resolution 130 is_eval_special(define). 131 is_eval_special(lambda). 132 is_eval_special(if). 133 is_eval_special(cond). 134 is_eval_special('set!'). 135 136 expression_type(Expression, selfeval) :- self_evaluating(Expression), !. 137 expression_type([quote|_Text], quote) :- !. 138 expression_type(VarName, variable) :- variable(VarName), !. 139 expression_type([Special|_Tail], special) :- is_eval_special(Special), !. 140 expression_type([_Operator|_Operands], operator) :- !. 141 142 interp_eval_(selfeval, Expression, Expression) --> { true }. 143 interp_eval_(quote, [quote, Text], Text) --> { true }. 144 interp_eval_(variable, VarName, Result) --> 145 lookup_variable_value(VarName, Result). 146 interp_eval_(special, [Special|Tail], Result) --> 147 interp_eval_special(Special, Tail, Result). 148 interp_eval_(operator, [Operator|Operands], Result) --> 149 interp_eval(Operator, Procedure), 150 list_of_values(Operands, Arguments), 151 interp_apply(Procedure, Arguments, Result). 152 153 interp_eval_special('set!', [VarName, Expression], '#void') --> 154 interp_eval(Expression, Result), 155 set_variable_value(VarName, Result). 156 157 interp_eval_special(lambda, [Parameters|Body], Result) --> 158 make_procedure(Parameters, Body, Result). 159 160 interp_eval_special(define, Arguments, '#void') --> 161 { interp_check(([VarName, Definition] = Arguments), arity, define) }, 162 interp_eval(Definition, Value), 163 define_variable(VarName, Value). 164 165 interp_eval_special(cond, Conditions, Result) --> 166 eval_cond(Conditions, Result). 167 168 eval_cond([], '#void') --> { true }. 169 eval_cond([[else|ThenBody]], Result) --> 170 !, 171 eval_sequence(ThenBody, Result). 172 eval_cond([[TestExpr|ThenBody]|Rest], Result) --> 173 interp_eval(TestExpr, TestResult), 174 { interp_check((TestResult =@= '#t' ; TestResult =@= '#f'), type, bool) }, 175 eval_cond_aux(TestResult, ThenBody, Rest, Result). 176 177 eval_cond_aux('#t', ThenBody, _Rest, Result) --> 178 eval_sequence(ThenBody, Result). 179 eval_cond_aux('#f', _ThenBody, Rest, Result) --> 180 eval_cond(Rest, Result). 181 182 interp_eval(Expression, Result) --> 183 check_state, 184 { 185 assertion(ground(Expression)), 186 interp_check(expression_type(Expression, Type), eval, Expression) 187 }, 188 interp_check(interp_eval_(Type, Expression, Result), eval_fail, Expression). 189 190 interp_apply_(primitive(Name, Arity), Arguments, Result) --> 191 { 192 length(Arguments, ALength), 193 interp_check(Arity = ALength, arity, Name) 194 }, 195 interp_check(primitive_apply(Name, Arguments, Result), primitive, Name). 196 interp_apply_(proc(Parameters, Body, Env), Arguments, Result, StateIn, StateOut) :- 197 State1 = StateIn.put(env, Env), 198 extend_environment(Parameters, Arguments, State1, State2), 199 eval_sequence(Body, Result, State2, State3), 200 StateOut = State3.put(env, StateIn.env). 201 202 interp_apply(Proc, Arguments, Result) --> 203 check_state, 204 { assertion(ground(Proc)), assertion(ground(Arguments)) }, 205 interp_check(interp_apply_(Proc, Arguments, Result), apply_fail, [Proc|Arguments]). 206 207 eval_sequence([H|T], Result) --> 208 interp_eval(H, FirstResult), 209 eval_sequence_aux(T, FirstResult, Result). 210 211 eval_sequence_aux([], Result, Result) --> { true }. 212 eval_sequence_aux([H|T], _, Result) --> 213 interp_eval(H, ThisResult), 214 eval_sequence_aux(T, ThisResult, Result). 215 216 list_of_values([], []) --> { true }. 217 list_of_values([Name|NameTail], [Value|ValueTail]) --> 218 interp_eval(Name, Value), 219 list_of_values(NameTail, ValueTail). 220 221 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 222 %% Environment Setup 223 224 result_bool(Condition, Result) :- 225 call(Condition) -> Result = '#t' ; Result = '#f'. 226 227 % in case we want primitive function which changes state we cand do so here 228 % otherwise call stateless primitive_apply/3 229 primitive_apply(Name, Arguments, Result, State, State) :- 230 primitive_apply(Name, Arguments, Result). 231 232 primitive_apply('atom?', [X], Result) :- result_bool(atom(X), Result). 233 primitive_apply('null?', [X], Result) :- result_bool(X =@= [], Result). 234 primitive_apply(car, [[H|_]], H). 235 primitive_apply(cdr, [[_|T]], T). 236 237 primitive_apply('eq?', [A,B], Result) :- result_bool(A =@= B, Result). 238 primitive_apply(cons, [H,T], [H|T]). 239 primitive_apply(+, [A, B], Result) :- Result is A + B. 240 241 primitive_arity('atom?', 1). 242 primitive_arity('null?', 1). 243 primitive_arity(car, 1). 244 primitive_arity(cdr, 1). 245 246 primitive_arity('eq?', 2). 247 primitive_arity(cons, 2). 248 primitive_arity(+, 2). 249 250 global_frame(['#t'-'#t', '#f'-'#f'|PrimitiveProcs]) :- 251 findall(Name-primitive(Name, Arity), primitive_arity(Name, Arity), PrimitiveProcs). 252 253 254 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 255 %% Driver 256 257 user_print(proc(Parameters, Body, _)) :- 258 format('→ proc(~w, ~w, <env>)~n', [Parameters, Body]). 259 260 interp_loop(State0, InputStream) :- 261 write('? '), 262 Here=interp_loop/1, 263 ( read_line_to_codes(InputStream, Codes) -> true 264 ; throw(error(read_error, context(Here, 'Failed to read line.')))), 265 format('got input: "~s"~n', [Codes]), 266 ( parse_input_expression(Codes, Expression) -> true 267 ; throw(error(parse_error(Codes), context(Here, 'Failed to parse line.')))), 268 ( interp_eval(Expression, Result, State0, State1) -> true 269 ; throw(error(evaluation_error(Codes), context(Here, 'Failed to evaluate expression.')))), 270 user_print(Result), 271 nl, 272 interp_loop(State1, InputStream). 273 274 % grammar {{{1 275 276 parse_input_expression(Codes, Expression) :- 277 phrase(sexp(Expression), Codes). 278 279 sexp(Value) --> blanks, sexp_value(Value). 280 281 sexp_value(List) --> `(`, blanks, sexp_list(List). 282 sexp_value(Number) --> number(Number). 283 sexp_value(Atom) --> 284 { ground(Atom) }, !, 285 { atom_codes(Atom, Codes) }, 286 Codes. 287 sexp_value(Atom) --> 288 { var(Atom) }, !, 289 [Initial], 290 { atom_start_code(Initial) }, 291 atom_tail(Codes), 292 { atom_codes(Atom, [Initial|Codes]) }. 293 294 atom_tail([Code|Tail]) --> [Code], { atom_code(Code) }, !, atom_tail(Tail). 295 atom_tail([]) --> { true }. 296 297 atom_code(Code) :- 298 code_type(Code, graph), % non-whitespace / non-control 299 Code \= 40, % open paren 300 Code \= 41. % close paren 301 302 atom_start_code(Code) :- 303 atom_code(Code), \+ code_type(Code, digit). 304 305 sexp_list([]) --> `)`. 306 sexp_list([Value|Rest]) --> sexp_value(Value), blanks, sexp_list(Rest). 307 308 sexp(Content, _, _, Result) :- 309 phrase_from_quasi_quotation(sexp(Result), Content). 310 :- quasi_quotation_syntax(sexp). 311 312 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 313 %% Interpreter wrapper 314 315 % main {{{1 316 %main :- current_prolog_flag(argv, Argv), main(Argv). 317 318 %:- initialization(main, main). 319 main(_Args) :- 320 current_stream(0, read, StdInStream), 321 initial_state(State), 322 interp_loop(State, StdInStream).