sforman
/
Thun
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make a version for GNU Prolog compiler.

This commit is contained in:
Simon Forman 2019-08-10 12:19:09 -07:00
parent 10a23c5c68
commit 1ce9544bcc
10 changed files with 1470 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
thun/gnu-prolog/Makefile Normal file
View File

@ -0,0 +1,8 @@
thun: thun.pl
gplc -o thun thun.pl
foo: foo.pl
gplc -o foo foo.pl

1
thun/gnu-prolog/build.sh Executable file
View File

@ -0,0 +1 @@
gplc --min-size -o thun thun.pl util.pl

681
thun/gnu-prolog/compiler.pl Normal file
View File

@ -0,0 +1,681 @@
/*
Copyright © 2018-2019 Simon Forman
This file is part of Thun
Thun is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Thun is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Thun. If not see <http://www.gnu.org/licenses/>.
The Joy interpreter that this implements is pretty crude. the only types
are 16-bit integers and linked lists. The lists are 32-bit words divided
into two 16-bit fields. The high half is the node value and the low half
points directly (not offset) to the next cell, zero terminates the list.
The expression is expected to be already written in RAM as a linked list at
the time the mainloop starts. As yet there is no support for actually doing
this. Both the new stack and expression cells are written to the same heap
intermixed. The stack and expression pointers never decrease, the whole
history of the computation is recorded in RAM. If the computation of the
expression overruns the end of RAM (or 16-bits whichever comes first) the
machine crashes.
At the moment, functions are recognized by setting high bit, but I don't
think I remembered to set the bits during compilation, so it won't work
at all right now. Er... Boo. Anyhow, the whole thing is very crude and
not at all what I am hoping eventually to build.
But it's a start, and I feel good about emitting machine code (even if the
program doesn't do anything useful yet.)
*/
:- use_module(library(assoc)).
:- use_module(library(clpfd)).
do :- Program = [
ヲ,∅,⟴,ヵ,メ,ョ,
[グ,ケ,ゲ,ド,ゴ,サ],ヮ(cons),
[ザ,シ],ヮ(dup),
[グ,ス,[],[ジ,ス,[ズ,セ,ス,[ゼ,ソ],[タ,ゾ],ヰ,ヂ],ヱ],ヰ,チ],ヮ(i),
[ヶ,ペ],ワ(new),
[ナ,ズ,セ,ネ,ヒ,ド,ャ,ペ],ワ(swap),
[new,cons],≡(unit),
[dup,i],≡(x),
[swap,cons],≡(swons)
],
compile_program(Program, Binary),
write_binary('joy_asm.bin', Binary).
compile_program(Program, Binary) :-
phrase((init, ⦾(Program, IR)), [], [Context]),
phrase(⟐(IR), ASM),
phrase(linker(ASM), EnumeratedASM),
foo(Context),
phrase(asm(EnumeratedASM), Binary).
foo(Context) :-
get_assoc(dictionary, Context, D),
assoc_to_list(D, Dictionary),
portray_clause(Dictionary).
/*
This first stage ⦾//2 converts the Joy description into a kind of intermediate
representation that models the Joy interpreter on top of the machine but doesn't
actually use assembly instructions. It also manages the named registers and
memory locations so thet don't appear in the program.
The idea here is to extract the low-level "primitives" needed to define the Joy
interpreter to make it easier to think about (and maybe eventually retarget other
CPUs.)
*/
⦾([], []) --> [].
⦾([ヲ|Terms], Ts) --> % Preamble.
% Initialize context/state/symbol table.
set(dict_ptr, 11), % Reg 11 is a pointer used during func lookup.
set(dict_top, 12), % Reg 12 points to top of dictionary.
set(dict, 0), % Address of top of dict during compilation.
set(done, _DONE), % DONE label (logic variable.)
set(expr, 4), % Reg 4 points to expression.
set(halt, _HALT), % HALT label (logic variable.)
set(main, _MAIN), % MAIN label (logic variable.)
set(reset, _Reset), % Reset label (logic variable.)
set(sp, 2), % Reg 2 points to just under top of stack.
set(temp0, 6), % Reg 6 is a temp var.
set(temp1, 7), % Reg 7 is a temp var.
set(temp2, 8), % Reg 8 is a temp var.
set(temp3, 9), % Reg 9 is a temp var.
set(term, 5), % Reg 4 holds current term.
set(tos, 3), % Reg 3 holds Top of Stack.
⦾(Terms, Ts).
⦾([ヵ|Terms], [ % Initialization.
jump(Over), % Oberon bootloader writes MemLim to RAM[12] and
asm(allocate(_, 16)), % stackOrg to RAM[24], we don't need these
label(Over), % but they must not be allowed to corrupt our code.
set_reg_const(0, 0), % zero out the root cell.
write_ram(0, 0),
set_reg_const(SP, 0x1000),
set_reg_const(EXPR, 0x500),
set_reg_label(DICT_TOP, LastWord),
set_reg_const(TOS, 0),
set_reg_const(TERM, 0),
asm(store_word(TOS, SP, 0)) % RAM[SP] := 0
|Ts]) -->
get([dict_top, DICT_TOP, expr, EXPR, sp, SP, term, TERM, tos, TOS]),
⦾(Terms, Ts), get(dict, LastWord).
⦾([メ|Terms], [ % Mainloop.
label(MAIN),
if_zero(EXPR, HALT),
deref(EXPR),
split_word(TERM, EXPR),
if_literal(TERM, PUSH),
lookup(DICT_PTR, DICT_TOP, TERM, HALT), % Jump to command or if not found halt.
label(PUSH), push(TOS, TERM, SP), % stack = TERM, stack
label(DONE), write_ram(SP, TOS), % RAM[SP] := TOS
jump(MAIN)
|Ts]) -->
get([dict_ptr, DICT_PTR, dict_top, DICT_TOP, done, DONE, expr, EXPR,
halt, HALT, main, MAIN, sp, SP, term, TERM, tos, TOS]),
⦾(Terms, Ts).
⦾([Body, ≡(NameAtom)|Terms], [defi(Name, B, Prev, I, SP, TOS)|Ts]) -->
get(dict, Prev), set(dict, Name), get([sp, SP, tos, TOS]),
inscribe(NameAtom, Name), ⦾(Terms, Ts), lookup(i, I), lookup(Body, B).
⦾([Body, ヮ(NameAtom)|Terms], [definition(Name, DONE, B, Prev)|Ts]) -->
get(dict, Prev), set(dict, Name), inscribe(NameAtom, Name),
get(done, DONE), ⦾([Body, Terms], [B, Ts]).
⦾([Body, ワ(NameAtom)|Terms], [definition(Name, MAIN, B, Prev)|Ts]) -->
get(dict, Prev), set(dict, Name), inscribe(NameAtom, Name),
get(main, MAIN), ⦾([Body, Terms], [B, Ts]).
⦾([P, T, E, ヰ|Terms], [br(Predicate, Then, Else)|Ts]) -->
⦾([P, T, E, Terms], [Predicate, Then, Else, Ts]).
⦾([P, B, ヱ|Terms], [repeat_until(Predicate, Body)|Ts]) -->
⦾([P, B, Terms], [Predicate, Body, Ts]).
⦾([Term|Terms], [T|Ts]) --> ⦾(Term, T), ⦾(Terms, Ts).
⦾(∅, dw(0)) --> [].
⦾(⟴, label(Reset)) --> get(reset, Reset).
⦾(ョ, halt(HALT)) --> get(halt, HALT).
⦾(グ, pop(TEMP0, TOS)) --> get(temp0, TEMP0), get(tos, TOS).
⦾(シ, push(TOS, TOS, SP)) --> get(tos, TOS), get(sp, SP).
⦾(ケ, high_half(TEMP1, TOS)) --> get(temp1, TEMP1), get(tos, TOS).
⦾(サ, merge(SP, TOS)) --> get(tos, TOS), get(sp, SP).
⦾(ザ, swap_halves(TOS)) --> get(tos, TOS).
⦾(ズ, deref(TEMP0)) --> get(temp0, TEMP0).
⦾(ス, if_zero(TEMP0)) --> get(temp0, TEMP0).
⦾(ソ, asm(mov(EXPR, TEMP3))) --> get(expr, EXPR), get(temp3, TEMP3).
⦾(ャ, asm(ior(TOS, TEMP1, SP))) --> get(tos, TOS), get(temp1, TEMP1), get(sp, SP).
⦾(タ, add_const(TEMP2, SP, 8)) --> get(temp2, TEMP2), get(sp, SP).
⦾(ジ, add_const(TEMP3, SP, 4)) --> get(temp3, TEMP3), get(sp, SP).
⦾(チ, add_const(SP, SP, 4)) --> get(sp, SP).
⦾(セ, chop_word(TEMP1, TEMP0)) --> get(temp0, TEMP0), get(temp1, TEMP1).
⦾(ト, chop_word(TEMP0, TOS)) --> get(temp0, TEMP0), get(tos, TOS).
⦾(ネ, chop_word(TEMP2, TOS)) --> get(temp2, TEMP2), get(tos, TOS).
⦾(ゼ, or_inplace(TEMP1, EXPR)) --> get(expr, EXPR), get(temp1, TEMP1).
⦾(ゲ, or_inplace(TEMP0, TEMP1)) --> get(temp0, TEMP0), get(temp1, TEMP1).
⦾(ヒ, or_inplace(TEMP0, TEMP2)) --> get(temp0, TEMP0), get(temp2, TEMP2).
⦾(ゾ, or_inplace(TEMP1, TEMP2)) --> get(temp1, TEMP1), get(temp2, TEMP2).
⦾(ド, write_cell(TEMP0, SP)) --> get(temp0, TEMP0), get(sp, SP).
⦾(ヂ, write_cell(TEMP1, SP)) --> get(temp1, TEMP1), get(sp, SP).
⦾(ペ, write_cell(TOS, SP)) --> get(tos, TOS), get(sp, SP).
⦾(ゴ, low_half(TOS)) --> get(tos, TOS).
⦾(ナ, low_half(TEMP0, TOS)) --> get(temp0, TEMP0), get(tos, TOS).
⦾(ヶ, low_half(TOS, SP)) --> get(sp, SP), get(tos, TOS).
/*
Context (state) manipulation for the ⦾//2 relation.
Association lists are used to keep a kind of symbol table as well as a dictionary
of name atoms to address logic variables for defined Joy functions.
*/
init, [Context] -->
{empty_assoc(C), empty_assoc(Dictionary),
put_assoc(dictionary, C, Dictionary, Context)}.
get([]) --> !.
get([Key, Value|Ts]) --> !, get(Key, Value), get(Ts).
get(Key, Value) --> state(Context), {get_assoc(Key, Context, Value)}.
set(Key, Value) --> state(ContextIn, ContextOut),
{put_assoc(Key, ContextIn, Value, ContextOut)}.
inscribe(NameAtom, Label) --> state(ContextIn, ContextOut),
{get_assoc(dictionary, ContextIn, Din),
put_assoc(NameAtom, Din, Label, Dout),
put_assoc(dictionary, ContextIn, Dout, ContextOut)}.
lookup([], []) --> !.
lookup([T|Ts], [V|Vs]) --> !, lookup(T, V), lookup(Ts, Vs).
lookup(NameAtom, Label) --> state(Context),
{get_assoc(dictionary, Context, D), get_assoc(NameAtom, D, Label)}.
state(S), [S] --> [S].
state(S0, S), [S] --> [S0].
/*
This second stage ⟐//1 converts the intermediate representation to assembly
language.
*/
⟐([]) --> [].
⟐([Term|Terms]) --> ⟐(Term), ⟐(Terms).
⟐(if_literal(Reg, Label)) --> % commands marked by setting high bit.
[and_imm(0, Reg, 0x8000), % 1 << 15
eq_offset(Label)].
% if reg = 0 jump to label.
⟐(if_zero(Reg, Label)) --> [sub_imm(Reg, Reg, 0), eq_offset(Label)].
⟐(set_reg_const(Reg, Immediate)) --> {Immediate >= -(2^15), Immediate < 2^16}, !,
[mov_imm(Reg, Immediate)].
⟐(set_reg_const(Reg, Immediate)) --> {Immediate >= 0, Immediate < 2^33}, !, % FIXME: handle negative numbers.
{high_half_word(Immediate, HighHalf), low_half_word(Immediate, LowHalf)},
[ mov_imm_with_shift(Reg, HighHalf), ior_imm(Reg, Reg, LowHalf)].
⟐(set_reg_label(Reg, Label)) --> [mov_imm(Reg, Label)].
⟐( noop) --> [mov(0, 0)].
⟐( halt(Halt)) --> [label(Halt), do_offset(Halt)].
⟐( asm(ASM)) --> [ASM].
⟐(label(Label)) --> [label(Label)].
⟐( jump(Label)) --> [do_offset(Label)].
⟐( dw(Int)) --> [word(Int)].
⟐( low_half(Reg)) --> [and_imm(Reg, Reg, 0xffff)].
⟐( low_half(To, From)) --> [and_imm(To, From, 0xffff)].
⟐( high_half(Reg)) --> [mov_imm_with_shift(0, 0xffff), and(Reg, Reg, 0)].
⟐(high_half(To, From)) --> [mov_imm_with_shift(0, 0xffff), and(To, From, 0)].
⟐(swap_halves(Register)) --> [ror_imm(Register, Register, 16)].
⟐(swap_halves(To, From)) --> [ror_imm( To, From, 16)].
⟐(high_half_to(To, From)) --> ⟐([swap_halves(To, From), low_half(To)]).
⟐(split_word(To, From)) --> ⟐([high_half_to(To, From), low_half(From)]).
⟐(chop_word(To, From)) --> ⟐([high_half(To, From), low_half(From)]).
⟐(merge(SP, TOS)) -->
[lsl_imm(0, SP, 16),
ior(TOS, TOS, 0),
add_imm(SP, SP, 4)].
⟐(push(TOS, TERM, SP)) -->
[lsl_imm(TOS, TERM, 16), % TOS := TERM << 16
ior(TOS, TOS, SP), % TOS := TOS | SP
add_imm(SP, SP, 4)]. % SP += 1 (word, not byte)
⟐( write_ram(To, From)) --> [store_word(From, To, 0)].
⟐(write_cell(From, SP)) --> [add_imm(SP, SP, 4), store_word(From, SP, 0)].
⟐(deref(Reg)) --> [load_word(Reg, Reg, 0)].
⟐(or_inplace(To, From)) --> [ior(To, To, From)].
⟐(definition(Label, Exit, Body, Prev)) -->
⟐([
dw(Prev),
label(Label),
Body,
jump(Exit)
]).
⟐(defi(Label, Body, Prev, I, SP, TOS)) -->
⟐([dw(Prev),
label(Label),
defi_def(BodyLabel, SP, TOS),
jump(I)]),
dexpr(Body, BodyLabel).
⟐(defi_def(Label, SP, TOS)) -->
[mov_imm_with_shift(TOS, Label),
ior(TOS, TOS, SP)],
⟐(write_cell(TOS, SP)).
⟐(lookup(PTR, TOP, TERM, Exit)) -->
[mov(PTR, TOP), % point to the top of the dictionary.
label(Lookup),
sub(0, TERM, PTR), eq(PTR), % if the term is found jump to it,
sub_imm(PTR, PTR, 4), % else load the next pointer.
load_word(PTR, PTR, 0),
sub_imm(PTR, PTR, 0), eq_offset(Exit), % exit if it's zero.
do_offset(Lookup)]. % loop to the top.
⟐(repeat_until(Condition, Body)) -->
{add_label(Condition, End, ConditionL)},
⟐([
label(Loop),
Body,
ConditionL,
jump(Loop),
label(End)
]).
⟐(br(Condition, [], Else)) --> !,
{add_label(Condition, END, ConditionL)},
⟐([ConditionL, Else, label(END)]).
⟐(br(Condition, Then, Else)) -->
{add_label(Condition, THEN, ConditionL)},
⟐([
ConditionL, Else, jump(END),
label(THEN), Then, label(END)
]).
⟐(add_const(To, From, Immediate)) --> [add_imm(To, From, Immediate)].
⟐(pop(Reg, TOS)) --> ⟐([split_word(Reg, TOS), deref(TOS)]).
/*
Support for ⟐//1 second stage.
The dexpr//2 DCG establishes a sequence of labeled expr_cell/2 pseudo-assembly
memory locations as a linked list that encodes a Prolog list of Joy function
labels comprising e.g. the body of some Joy definition.
*/
dexpr([], 0) --> [].
dexpr([Func|Rest], ThisCell) -->
[label(ThisCell), expr_cell(Func, NextCell)],
dexpr(Rest, NextCell).
/*
The add_label/3 relation is a meta-logical construct that accepts a comparision
predicate (e.g. if_zero/2) and "patches" it by adding the Label logic variable
to the end.
*/
add_label(CmpIn, Label, CmpOut) :-
CmpIn =.. F,
append(F, [Label], G),
CmpOut =.. G.
/*
Two simple masking predicates.
*/
high_half_word(I, HighHalf) :- HighHalf is I >> 16 /\ 0xFFFF.
low_half_word( I, LowHalf) :- LowHalf is I /\ 0xFFFF.
/*
Linker
*/
linker(ASM) --> enumerate_asm(ASM, 0, _).
enumerate_asm( [], N, N) --> !, [].
enumerate_asm( [Term|Terms], N, M) --> !, enumerate_asm(Term, N, O), enumerate_asm(Terms, O, M).
enumerate_asm( label(N) , N, N) --> !, [].
enumerate_asm(allocate(N, Bytes), N, M) --> !, {Bits is 8 * Bytes}, [skip(Bits)], {align(N, Bytes, M)}.
enumerate_asm( Instr, N, M) --> [(Z, Instr)], {align(N, 0, Z), align(Z, 4, M)}.
align(_, Bytes, _) :- (Bytes < 0 -> write('Align negative number? No!')), !, fail.
align(N, 1, M) :- !, M is N + 1.
align(N, Bytes, M) :- N mod 4 =:= 0, !, M is N + Bytes.
align(N, Bytes, M) :- Padding is 4 - (N mod 4), M is N + Bytes + Padding.
/*
Assembler
*/
asm([]) --> !, [].
asm([ skip(Bits)|Rest]) --> !, skip(Bits), asm(Rest).
asm([(N, Instruction)|Rest]) --> !, asm(N, Instruction), asm(Rest).
asm(_, expr_cell(Func, NextCell)) --> !,
{Data is (Func << 16) \/ NextCell}, asm(_, word(Data)).
asm(_, word(Word)) --> !, {binary_number(Bits, Word)}, collect(32, Bits).
asm(_, load_word(A, B, Offset)) --> !, instruction_format_F2(0, 0, A, B, Offset).
asm(_, load_byte(A, B, Offset)) --> !, instruction_format_F2(0, 1, A, B, Offset).
asm(_, store_word(A, B, Offset)) --> !, instruction_format_F2(1, 0, A, B, Offset).
asm(_, store_byte(A, B, Offset)) --> !, instruction_format_F2(1, 1, A, B, Offset).
asm(_, mov(A, C)) --> instruction_format_F0(0, A, 0, mov, C).
asm(_, mov_with_shift(A, C)) --> instruction_format_F0(1, A, 0, mov, C).
asm(_, mov_imm_with_shift(A, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(1, 0, A, 0, mov, Imm).
asm(_, mov_imm_with_shift(A, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(1, 0, A, 0, mov, Imm).
asm(_, mov_imm_with_shift(_, _)) --> {write('Immediate value out of bounds'), fail}.
asm(_, mov_imm(A, Imm) ) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, 0, mov, Imm).
asm(_, mov_imm(A, Imm) ) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, 0, mov, Imm).
asm(_, mov_imm(_, _) ) --> {write('Immediate value out of bounds'), fail}.
asm(_, add(A, B, C)) --> instruction_format_F0(0, A, B, add, C).
asm(_, add_carry(A, B, C)) --> instruction_format_F0(1, A, B, add, C).
asm(_, sub(A, B, C)) --> instruction_format_F0(0, A, B, sub, C).
asm(_, sub_carry(A, B, C)) --> instruction_format_F0(1, A, B, sub, C).
asm(_, add_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, add, Imm).
asm(_, add_imm(A, B, Imm)) --> {pos_int15(Imm)}, !, instruction_format_F1(0, 0, A, B, add, Imm).
asm(_, add_imm_carry(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(1, 1, A, B, add, Imm).
asm(_, add_imm_carry(A, B, Imm)) --> {pos_int15(Imm)}, !, instruction_format_F1(1, 0, A, B, add, Imm).
asm(_, sub_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, sub, Imm).
asm(_, sub_imm(A, B, Imm)) --> {pos_int15(Imm)}, !, instruction_format_F1(0, 0, A, B, sub, Imm).
asm(_, sub_imm_carry(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(1, 1, A, B, sub, Imm).
asm(_, sub_imm_carry(A, B, Imm)) --> {pos_int15(Imm)}, !, instruction_format_F1(1, 0, A, B, sub, Imm).
asm(_, mul(A, B, C)) --> instruction_format_F0(0, A, B, mul, C).
asm(_, mul_unsigned(A, B, C)) --> instruction_format_F0(1, A, B, mul, C).
asm(_, mul_imm(A, B, Imm, U)) --> {neg_int15(Imm)}, !, instruction_format_F1(U, 1, A, B, mul, Imm).
asm(_, mul_imm(A, B, Imm, U)) --> {pos_int15(Imm)}, !, instruction_format_F1(U, 0, A, B, mul, Imm).
asm(_, and(A, B, C)) --> instruction_format_F0(0, A, B, and, C).
asm(_, ann(A, B, C)) --> instruction_format_F0(0, A, B, ann, C).
asm(_, asr(A, B, C)) --> instruction_format_F0(0, A, B, asr, C).
asm(_, div(A, B, C)) --> instruction_format_F0(0, A, B, div, C).
asm(_, ior(A, B, C)) --> instruction_format_F0(0, A, B, ior, C).
asm(_, lsl(A, B, C)) --> instruction_format_F0(0, A, B, lsl, C).
asm(_, ror(A, B, C)) --> instruction_format_F0(0, A, B, ror, C).
asm(_, xor(A, B, C)) --> instruction_format_F0(0, A, B, xor, C).
asm(_, and_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, and, Imm).
asm(_, and_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, and, Imm).
asm(_, ann_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, ann, Imm).
asm(_, ann_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, ann, Imm).
asm(_, asr_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, asr, Imm).
asm(_, asr_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, asr, Imm).
asm(_, div_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, div, Imm).
asm(_, div_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, div, Imm).
asm(_, ior_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, ior, Imm).
asm(_, ior_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, ior, Imm).
asm(_, lsl_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, lsl, Imm).
asm(_, lsl_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, lsl, Imm).
asm(_, ror_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, ror, Imm).
asm(_, ror_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, ror, Imm).
asm(_, xor_imm(A, B, Imm)) --> {neg_int15(Imm)}, !, instruction_format_F1(0, 1, A, B, xor, Imm).
asm(_, xor_imm(A, B, Imm)) --> {pos_int16(Imm)}, !, instruction_format_F1(0, 0, A, B, xor, Imm).
asm(_, cc(C)) --> instruction_format_F3a(0, cc, C).
asm(N, cc_offset(Label)) --> instruction_format_F3b(0, cc, Label, N).
asm(_, cc_link(C)) --> instruction_format_F3a(1, cc, C).
asm(N, cc_link_offset(Label)) --> instruction_format_F3b(1, cc, Label, N).
asm(_, cs(C)) --> instruction_format_F3a(0, cs, C).
asm(N, cs_offset(Label)) --> instruction_format_F3b(0, cs, Label, N).
asm(_, cs_link(C)) --> instruction_format_F3a(1, cs, C).
asm(N, cs_link_offset(Label)) --> instruction_format_F3b(1, cs, Label, N).
asm(_, do(C)) --> instruction_format_F3a(0, do, C).
asm(N, do_offset(Label)) --> instruction_format_F3b(0, do, Label, N).
asm(_, do_link(C)) --> instruction_format_F3a(1, do, C).
asm(N, do_link_offset(Label)) --> instruction_format_F3b(1, do, Label, N).
asm(_, eq(C)) --> instruction_format_F3a(0, eq, C).
asm(N, eq_offset(Label)) --> instruction_format_F3b(0, eq, Label, N).
asm(_, eq_link(C)) --> instruction_format_F3a(1, eq, C).
asm(N, eq_link_offset(Label)) --> instruction_format_F3b(1, eq, Label, N).
asm(_, ge(C)) --> instruction_format_F3a(0, ge, C).
asm(N, ge_offset(Label)) --> instruction_format_F3b(0, ge, Label, N).
asm(_, ge_link(C)) --> instruction_format_F3a(1, ge, C).
asm(N, ge_link_offset(Label)) --> instruction_format_F3b(1, ge, Label, N).
asm(_, gt(C)) --> instruction_format_F3a(0, gt, C).
asm(N, gt_offset(Label)) --> instruction_format_F3b(0, gt, Label, N).
asm(_, gt_link(C)) --> instruction_format_F3a(1, gt, C).
asm(N, gt_link_offset(Label)) --> instruction_format_F3b(1, gt, Label, N).
asm(_, hi(C)) --> instruction_format_F3a(0, hi, C).
asm(N, hi_offset(Label)) --> instruction_format_F3b(0, hi, Label, N).
asm(_, hi_link(C)) --> instruction_format_F3a(1, hi, C).
asm(N, hi_link_offset(Label)) --> instruction_format_F3b(1, hi, Label, N).
asm(_, le(C)) --> instruction_format_F3a(0, le, C).
asm(N, le_offset(Label)) --> instruction_format_F3b(0, le, Label, N).
asm(_, le_link(C)) --> instruction_format_F3a(1, le, C).
asm(N, le_link_offset(Label)) --> instruction_format_F3b(1, le, Label, N).
asm(_, ls(C)) --> instruction_format_F3a(0, ls, C).
asm(N, ls_offset(Label)) --> instruction_format_F3b(0, ls, Label, N).
asm(_, ls_link(C)) --> instruction_format_F3a(1, ls, C).
asm(N, ls_link_offset(Label)) --> instruction_format_F3b(1, ls, Label, N).
asm(_, lt(C)) --> instruction_format_F3a(0, lt, C).
asm(N, lt_offset(Label)) --> instruction_format_F3b(0, lt, Label, N).
asm(_, lt_link(C)) --> instruction_format_F3a(1, lt, C).
asm(N, lt_link_offset(Label)) --> instruction_format_F3b(1, lt, Label, N).
asm(_, mi(C)) --> instruction_format_F3a(0, mi, C).
asm(N, mi_offset(Label)) --> instruction_format_F3b(0, mi, Label, N).
asm(_, mi_link(C)) --> instruction_format_F3a(1, mi, C).
asm(N, mi_link_offset(Label)) --> instruction_format_F3b(1, mi, Label, N).
asm(_, ne(C)) --> instruction_format_F3a(0, ne, C).
asm(N, ne_offset(Label)) --> instruction_format_F3b(0, ne, Label, N).
asm(_, ne_link(C)) --> instruction_format_F3a(1, ne, C).
asm(N, ne_link_offset(Label)) --> instruction_format_F3b(1, ne, Label, N).
asm(_, nv(C)) --> instruction_format_F3a(0, nv, C). % NeVer.
asm(N, nv_offset(Label)) --> instruction_format_F3b(0, nv, Label, N).
asm(_, nv_link(C)) --> instruction_format_F3a(1, nv, C).
asm(N, nv_link_offset(Label)) --> instruction_format_F3b(1, nv, Label, N).
asm(_, pl(C)) --> instruction_format_F3a(0, pl, C).
asm(N, pl_offset(Label)) --> instruction_format_F3b(0, pl, Label, N).
asm(_, pl_link(C)) --> instruction_format_F3a(1, pl, C).
asm(N, pl_link_offset(Label)) --> instruction_format_F3b(1, pl, Label, N).
asm(_, vc(C)) --> instruction_format_F3a(0, vc, C).
asm(N, vc_offset(Label)) --> instruction_format_F3b(0, vc, Label, N).
asm(_, vc_link(C)) --> instruction_format_F3a(1, vc, C).
asm(N, vc_link_offset(Label)) --> instruction_format_F3b(1, vc, Label, N).
asm(_, vs(C)) --> instruction_format_F3a(0, vs, C).
asm(N, vs_offset(Label)) --> instruction_format_F3b(0, vs, Label, N).
asm(_, vs_link(C)) --> instruction_format_F3a(1, vs, C).
asm(N, vs_link_offset(Label)) --> instruction_format_F3b(1, vs, Label, N).
% This is the core of the assembler where the instruction formats are specified.
instruction_format_F0(U, A, B, Op, C ) --> [0, 0, U, 0], reg(A), reg(B), operation(Op), skip(12), reg(C).
instruction_format_F1(U, V, A, B, Op, Im) --> [0, 1, U, V], reg(A), reg(B), operation(Op), immediate(Im).
instruction_format_F2(U, V, A, B, Offset) --> [1, 0, U, V], reg(A), reg(B), offset(Offset).
instruction_format_F3a(V, Cond, C ) --> [1, 1, 0, V], cond(Cond), skip(20), reg(C).
instruction_format_F3b(V, Cond, To, Here) --> [1, 1, 1, V], cond(Cond), encode_jump_offset(To, Here).
immediate(Imm) --> encode_int(16, Imm), !.
offset(Offset) --> encode_int(20, Offset), !.
skip(N) --> collect(N, Zeros), {Zeros ins 0..0}.
encode_jump_offset(To, Here) --> {Offset is ((To - Here) >> 2) - 1}, encode_int(24, Offset).
encode_int(Width, I) --> {I >= 0}, !, collect(Width, Bits), { binary_number(Bits, I) }, !.
encode_int(Width, I) --> {I < 0}, !, collect(Width, Bits), {twos_compliment(Bits, I, Width)}, !.
collect(N, []) --> {N =< 0}.
collect(N, [X|Rest]) --> {N > 0, N0 is N - 1}, [X], collect(N0, Rest).
reg( 0) --> [0, 0, 0, 0].
reg( 1) --> [0, 0, 0, 1].
reg( 2) --> [0, 0, 1, 0].
reg( 3) --> [0, 0, 1, 1].
reg( 4) --> [0, 1, 0, 0].
reg( 5) --> [0, 1, 0, 1].
reg( 6) --> [0, 1, 1, 0].
reg( 7) --> [0, 1, 1, 1].
reg( 8) --> [1, 0, 0, 0].
reg( 9) --> [1, 0, 0, 1].
reg(10) --> [1, 0, 1, 0].
reg(11) --> [1, 0, 1, 1].
reg(12) --> [1, 1, 0, 0].
reg(13) --> [1, 1, 0, 1].
reg(14) --> [1, 1, 1, 0].
reg(15) --> [1, 1, 1, 1].
operation(mov) --> [0, 0, 0, 0].
operation(lsl) --> [0, 0, 0, 1].
operation(asr) --> [0, 0, 1, 0].
operation(ror) --> [0, 0, 1, 1].
operation(and) --> [0, 1, 0, 0].
operation(ann) --> [0, 1, 0, 1].
operation(ior) --> [0, 1, 1, 0].
operation(xor) --> [0, 1, 1, 1].
operation(add) --> [1, 0, 0, 0].
operation(sub) --> [1, 0, 0, 1].
operation(mul) --> [1, 0, 1, 0].
operation(div) --> [1, 0, 1, 1].
operation(fad) --> [1, 1, 0, 0].
operation(fsb) --> [1, 1, 0, 1].
operation(fml) --> [1, 1, 1, 0].
operation(fdv) --> [1, 1, 1, 1].
cond(mi) --> [0, 0, 0, 0].
cond(eq) --> [0, 0, 0, 1].
cond(cs) --> [0, 0, 1, 0].
cond(vs) --> [0, 0, 1, 1].
cond(ls) --> [0, 1, 0, 0].
cond(lt) --> [0, 1, 0, 1].
cond(le) --> [0, 1, 1, 0].
cond(do) --> [0, 1, 1, 1].
cond(pl) --> [1, 0, 0, 0].
cond(ne) --> [1, 0, 0, 1].
cond(cc) --> [1, 0, 1, 0].
cond(vc) --> [1, 0, 1, 1].
cond(hi) --> [1, 1, 0, 0].
cond(ge) --> [1, 1, 0, 1].
cond(gt) --> [1, 1, 1, 0].
cond(nv) --> [1, 1, 1, 1].
pos_int16(I) :- I >= 0, I < 2^16.
pos_int15(I) :- I >= 0, I < 2^15.
neg_int15(I) :- I < 0, I >= -(2^15).
int15(I) :- pos_int15(I) ; neg_int15(I).
invert([], []).
invert([1|Tail], [0|Lait]) :- invert(Tail, Lait).
invert([0|Tail], [1|Lait]) :- invert(Tail, Lait).
twos_compliment(Bits, Number, Width) :-
X is abs(Number),
binary_number(B, X),
length(B, Width),
invert(B, Antibits),
binary_number(Antibits, Y),
Z is Y+1,
length(Bits, Width),
binary_number(Bits, Z).
% https://stackoverflow.com/a/28015816
canonical_binary_number([0], 0).
canonical_binary_number([1], 1).
canonical_binary_number([1|Bits], Number):-
when(ground(Number),
(Number > 1,
Pow is floor(log(Number) / log(2)),
Number1 is Number - 2 ^ Pow,
( Number1 > 1
-> Pow1 is floor(log(Number1) / log(2)) + 1
; Pow1 = 1
))),
length(Bits, Pow),
between(1, Pow, Pow1),
length(Bits1, Pow1),
append(Zeros, Bits1, Bits),
maplist(=(0), Zeros),
canonical_binary_number(Bits1, Number1),
Number is Number1 + 2 ^ Pow.
binary_number( Bits , Number) :- canonical_binary_number(Bits, Number).
binary_number([0|Bits], Number) :- binary_number(Bits, Number).
% Helper code to write the list of bits as a binary file.
for_serial(Binary, Ser) :-
length(Binary, LengthInBits),
LengthInBytes is LengthInBits >> 3,
skip(32, Caboose, []), % zero word to signal EOF to bootloader.
append(Binary, Caboose, B),
skip(32, G, B), % Address is zero.
binary_number(Bits, LengthInBytes),
collect(32, Bits, Ser, G).
write_binary(Name, Binary) :-
open(Name, write, Stream, [type(binary)]),
phrase(write_binary_(Stream), Binary),
close(Stream).
write_binary_(Stream) -->
% Handle "Endian-ness".
collect(8, Bits3), collect(8, Bits2), collect(8, Bits1), collect(8, Bits0), !,
{wb(Bits0, Stream), wb(Bits1, Stream), wb(Bits2, Stream), wb(Bits3, Stream)},
write_binary_(Stream).
write_binary_(_) --> [].
wb(Bits, Stream) :- binary_number(Bits, Byte), put_byte(Stream, Byte).

72
thun/gnu-prolog/defs.txt Normal file
View File

@ -0,0 +1,72 @@
-- == 1 -
? == dup bool
++ == 1 +
anamorphism == [pop []] swap [dip swons] genrec
app1 == grba infrst
app2 == [grba swap grba swap] dip [infrst] cons ii
app3 == 3 appN
appN == [grabN] cons dip map disenstacken
at == drop first
average == [sum 1.0 *] [size] cleave /
b == [i] dip i
binary == unary popd
ccons == cons cons
cleave == fork popdd
clop == cleave popdd
codireco == cons dip rest cons
dinfrirst == dip infrst
disenstacken == ? [uncons ?] loop pop
down_to_zero == [0 >] [dup --] while
drop == [rest] times
dupd == [dup] dip
dupdd == [dup] dipd
dupdipd == dup dipd
enstacken == stack [clear] dip
flatten == [] swap [concat] step
fork == [i] app2
fourth == rest third
gcd == true [tuck mod dup 0 >] loop pop
grabN == [] swap [cons] times
grba == [stack popd] dip
hypot == [sqr] ii + sqrt
ifte == [nullary] dipd swap branch
ii == [dip] dupdip i
infra == swons swaack [i] dip swaack
infrst == infra first
make_generator == [codireco] ccons
neg == 0 swap -
nullary == [stack] dinfrirst
of == swap at
pam == [i] map
pm == [+] [-] clop
popd == [pop] dip
popdd == [pop] dipd
popop == pop pop
popopd == [popop] dip
popopdd == [popop] dipd
primrec == [i] genrec
product == 1 swap [*] step
quoted == [unit] dip
range == [0 <=] [1 - dup] anamorphism
range_to_zero == unit [down_to_zero] infra
reverse == [] swap shunt
rrest == rest rest
run == [] swap infra
second == rest first
shift == uncons [swons] dip
shunt == [swons] step
size == 0 swap [pop ++] step
split_at == [drop] [take] clop
sqr == dup *
step_zero == 0 roll> step
sum == 0 swap [+] step
swons == swap cons
take == [] rolldown [shift] times pop
ternary == binary popd
third == rest second
unary == nullary popd
unit == [] cons
unquoted == [i] dip
unswons == uncons swap
while == swap [nullary] cons dup dipd concat loop
x == dup i

107
thun/gnu-prolog/foo.pl Normal file
View File

@ -0,0 +1,107 @@
:- dynamic(func/3).
:- discontiguous(func/3).
/*
Copyright 2018, 2019 Simon Forman
This file is part of Thun
Thun is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Thun is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Thun. If not see <http://www.gnu.org/licenses/>.
*/
/*
Interpreter
thun(Expression, InputStack, OutputStack)
*/
thun([], S, S).
thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
thun( [Def|E], Si, So) :- def(Def, Body), !, append(Body, E, Eo), thun(Eo, Si, So).
thun( [Func|E], Si, So) :- func(Func, Si, S), thun(E, S, So).
thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
% Some error handling.
thun([Unknown|E], Si, So) :-
damned_thing(Unknown),
write("wtf? "),
write(Unknown), nl,
So = [[Unknown|E]|Si].
damned_thing(It) :-
\+ literal(It),
\+ def(It, _),
\+ func(It, _, _),
\+ combo(It, _, _, _, _).
/*
Literals
*/
literal(V) :- var(V).
literal(I) :- number(I).
literal([]).
literal([_|_]).
literal(true).
literal(false).
% Symbolic math expressions are literals.
literal(_+_).
literal(_-_).
literal(_*_).
literal(_/_).
literal(_ mod _).
% Symbolic comparisons are literals.
literal(_>_).
literal(_<_).
literal(_>=_).
literal(_=<_).
literal(_=:=_).
literal(_=\=_).
/*
Functions
*/
func(cons, [A, B|S], [[B|A]|S]).
func(swap, [A, B|S], [B, A|S]).
func(dup, [A|S], [A, A|S]).
func(pop, [_|S], S ).
/*
Combinators
*/
combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
combo(dupdip, [P, X|S], [X|S], Ei, Eo) :- append(P, [X|Ei], Eo).
/*
Definitions
*/
def(x, [dup, i]).

120
thun/gnu-prolog/gthun.pl Normal file
View File

@ -0,0 +1,120 @@
:- op(990, xfy, =-).
:- dynamic((=-)/2).
:- initialization(loop).
/*
Parser
*/
joy_parse([T|S]) --> blanks, joy_term(T), blanks, joy_parse(S).
joy_parse([]) --> [].
joy_term(N) --> num(N), !.
joy_term(S) --> [0'[], !, joy_parse(S), [0']].
joy_term(A) --> chars(Chars), !, {atom_codes(A, Chars)}.
/*
Interpreter.
*/
thun([], S, S).
thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
thun( [Func|E], Si, So) :- func(Func, Si, S), !, thun(E, S, So).
thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), !, thun(Eo, S, So).
thun(Err, S, [Err|S]) :- write('Unknown term!'), nl.
/*
Literals
*/
literal(V) :- var(V).
literal(I) :- number(I).
literal([]).
literal([_|_]).
literal(true).
literal(false).
/*
Functions
*/
func(cons, [A, B|S], [[B|A]|S]).
func(swap, [A, B|S], [B, A|S]).
func(dup, [A|S], [A, A|S]).
func(pop, [_|S], S ).
func(uncons, Si, So) :- func(cons, So, Si).
func(+, [A, B|S], [B+A|S]).
func(=, [A|S], [B|S]) :- B is A.
func(clear, _, []).
func(stack, S, [S|S]).
/*
Definitions
*/
% This is NOT the Continuation-Passing Style
%
% func(Name, Si, So) :- Name =- Body, thun(Body, Si, So).
func(inscribe, [Definition|S], S) :-
Definition = [Name|Body],
atom(Name),
assertz(Name =- Body).
swons =- [swap, cons].
x =- [dup, i].
unit =- [[], cons].
enstacken =- [stack, [clear], dip].
% This IS the Continuation-Passing Style
%
combo(Name, S, S, Ei, Eo) :- Name =- Body, append(Body, Ei, Eo).
/*
Combinators
*/
combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
combo(loop, [_, false|S], S, E, E ).
combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
combo(step, [_, []|S], S, E, E ).
combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
/*
Main Loop
*/
loop :- line(Line), loop(Line, [], _Out).
loop([eof], S, S) :- !.
loop( Line, In, Out) :-
do_line(Line, In, S),
write(S), nl,
line(NextLine), !,
loop(NextLine, S, Out).
do_line(Line, In, Out) :- phrase(joy_parse(E), Line), thun(E, In, Out).
do_line(_Line, S, S) :- write('Err'), nl.

10
thun/gnu-prolog/meta.pl Normal file
View File

@ -0,0 +1,10 @@
do(DCG) :-
fd_domain(X, 0, 9),
fd_labeling(X),
number_codes(X, [C]),
DCG = `-->`(digit(C), [C]).

84
thun/gnu-prolog/metalogical.pl Normal file
View File

@ -0,0 +1,84 @@
% A Tracing Meta-Interpreter for Thun
% See https://www.metalevel.at/acomip/
tmi(true).
tmi(!).
tmi((A, B)) :- tmi(A), tmi(B).
tmi(number(A)) :- number(A).
tmi(var(A)) :- var(A).
% Meta-logical print trace.
% (Could also be captured in a list or something instead.)
tmi(thun(E, Si, _)) :- frump(Si, E), fail.
tmi(Goal) :-
checky(Goal),
clause(Goal, Body), % doesn't work for e.g. +
tmi(Body).
checky(Goal) :-
Goal \= true,
Goal \= (_,_),
Goal \= var(_),
Goal \= number(_),
Goal \= !.
format_state(Stack, Expression, Codes) :-
reverse(Stack, RStack),
phrase(format_stack(RStack), RStackCodes),
phrase(format_stack(Expression), ExpressionCodes),
append(RStackCodes, [32, 46, 32|ExpressionCodes], Codes).
frump(Stack, Expression) :-
format_state(Stack, Expression, Codes),
maplist(put_code, Codes), nl.
% do(In) :- phrase(format_stack(In), Codes), maplist(put_code, Codes).
% Print Joy expressions as text.
format_stack(Tail) --> {var(Tail)}, !, [46, 46, 46].
format_stack([T]) --> format_term(T), !.
format_stack([T|S]) --> format_term(T), " ", format_stack(S).
format_stack([]) --> [].
format_term(N) --> {number(N), number_codes(N, Codes)}, Codes.
format_term(A) --> { atom(A), atom_codes(A, Codes)}, Codes.
format_term([A|As]) --> "[", format_stack([A|As]), "]".
/*
[debug] ?- tmi(thun([1, 2, swap], Si, So)).
_-[1, 2, swap].
[1|_]-[2, swap].
[2, 1|_]-[swap].
[1, 2|_]-[].
So = [1, 2|Si] ;
false.
[debug] ?- tmi(thun([[1], 2, swons], Si, So)).
_-[[1], 2, swons].
[[1]|_]-[2, swons].
[2, [1]|_]-[swons].
[2, [1]|_]-[swap, cons].
[[1], 2|_]-[cons].
[[2, 1]|_]-[].
So = [[2, 1]|Si] .
[debug] ?- tmi(thun([[1], 2, [swons], i], Si, So)).
_-[[1], 2, [swons], i].
[[1]|_]-[2, [swons], i].
[2, [1]|_]-[[swons], i].
[[swons], 2, [1]|_]-[i].
[2, [1]|_]-[swons].
[2, [1]|_]-[swap, cons].
[[1], 2|_]-[cons].
[[2, 1]|_]-[].
So = [[2, 1]|Si] .
*/

350
thun/gnu-prolog/thun.pl Normal file
View File

@ -0,0 +1,350 @@
:- dynamic(func/3).
:- discontiguous(func/3).
/*
Copyright © 2018, 2019 Simon Forman
This file is part of Thun
Thun is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Thun is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Thun. If not see <http://www.gnu.org/licenses/>.
*/
:- dynamic(def/2).
/*
To handle comparision operators the possibility of exceptions due to
insufficiently instantiated arguments must be handled. First try to make
the comparison and set the result to a Boolean atom. If an exception
happens just leave the comparison expression as the result and some other
function or combinator will deal with it. Example:
func(>, [A, B|S], [C|S]) :- catch(
(B > A -> C=true ; C=false),
_,
C=(B>A) % in case of error.
).
To save on conceptual overhead I've defined a term_expansion/2 that sets
up the func/3 for each op.
*/
term_expansion(comparison_operator(X), (func(X, [A, B|S], [C|S]) :-
F =.. [X, B, A], catch((F -> C=true ; C=false), _, C=F))).
% I don't use Prolog-compatible op symbols in all cases.
term_expansion(comparison_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
F =.. [Y, B, A], catch((F -> C=true ; C=false), _, C=F))).
% Likewise for math operators, try to evaluate, otherwise use the
% symbolic form.
term_expansion(math_operator(X), (func(X, [A, B|S], [C|S]) :-
F =.. [X, B, A], catch(C is F, _, C=F))).
term_expansion(math_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
F =.. [Y, B, A], catch(C is F, _, C=F))).
/*
An entry point.
*/
joy(InputString, StackIn, StackOut) :-
phrase(joy_parse(Expression), InputString), !,
thun(Expression, StackIn, StackOut).
/*
Parser
joy :== number | '[' joy* ']' | atom
*/
joy_parse([T|J]) --> blanks, joy_term(T), blanks, joy_parse(J).
joy_parse([]) --> [].
joy_term(N) --> number(N), !.
joy_term(J) --> "[", !, joy_parse(J), "]".
joy_term(C) --> symbol(C).
symbol(C) --> chars(Chars), !, {Chars \= [61, 61], atom_string(C, Chars)}.
chars([Ch|Rest]) --> char(Ch), chars(Rest).
chars([Ch]) --> char(Ch).
char(Ch) --> [Ch], {Ch \== 91, Ch \== 93, code_type(Ch, graph)}.
/*
Interpreter
thun(Expression, InputStack, OutputStack)
*/
thun([], S, S).
thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
thun( [Def|E], Si, So) :- def(Def, Body), !, append(Body, E, Eo), thun(Eo, Si, So).
thun( [Func|E], Si, So) :- func(Func, Si, S), thun(E, S, So).
thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
% Some error handling.
thun([Unknown|E], Si, So) :-
damned_thing(Unknown),
write("wtf? "),
writeln(Unknown),
So = [[Unknown|E]|Si].
damned_thing(It) :-
\+ literal(It),
\+ def(It, _),
\+ func(It, _, _),
\+ combo(It, _, _, _, _).
/*
Literals
*/
literal(V) :- var(V).
literal(I) :- number(I).
literal([]).
literal([_|_]).
literal(true).
literal(false).
% Symbolic math expressions are literals.
literal(_+_).
literal(_-_).
literal(_*_).
literal(_/_).
literal(_ mod _).
% Symbolic comparisons are literals.
literal(_>_).
literal(_<_).
literal(_>=_).
literal(_=<_).
literal(_=:=_).
literal(_=\=_).
/*
Functions
*/
func(cons, [A, B|S], [[B|A]|S]).
func(swap, [A, B|S], [B, A|S]).
func(dup, [A|S], [A, A|S]).
func(pop, [_|S], S ).
% Symbolic math. Compute the answer, or derivative, or whatever, later.
math_operator(+).
math_operator(-).
math_operator(*).
math_operator(/).
math_operator(mod).
% Attempt to calculate the value of a symbolic math expression.
func(calc, [A|S], [B|S]) :- B is A.
func(sqrt, [A|S], [sqrt(A)|S]).
func(concat, [A, B|S], [C|S]) :- append(B, A, C).
func(flatten, [A|S], [B|S]) :- flatten(A, B).
func(swaack, [R|S], [S|R]).
func(stack, S , [S|S]).
func(clear, _ , []).
func(first, [[X|_]|S], [X|S]).
func(rest, [[_|X]|S], [X|S]).
func(unit, [X|S], [[X]|S]).
func(rolldown, [A, B, C|S], [B, C, A|S]).
func(dupd, [A, B|S], [A, B, B|S]).
func(over, [A, B|S], [B, A, B|S]).
func(tuck, [A, B|S], [A, B, A|S]).
func(shift, [[B|A], C|D], [A, [B|C]|D]).
func(rollup, Si, So) :- func(rolldown, So, Si).
func(uncons, Si, So) :- func(cons, So, Si).
func(bool, [ 0|S], [false|S]) :- !.
func(bool, [ 0.0|S], [false|S]) :- !.
func(bool, [ []|S], [false|S]) :- !.
func(bool, [ ""|S], [false|S]) :- !.
func(bool, [false|S], [false|S]) :- !.
func(bool, [_|S], [true|S]).
comparison_operator(>).
comparison_operator(<).
comparison_operator(>=).
comparison_operator(<=, =<).
comparison_operator(=, =:=).
comparison_operator(<>, =\=).
/*
Definitions
*/
joy_def(def(Def, Body)) --> symbol(Def), blanks, "==", joy_parse(Body).
joy_defs --> blanks, joy_def(Def), {assert_def(Def)}, blanks, joy_defs.
joy_defs --> [].
assert_defs(DefsFile) :-
read_file_to_codes(DefsFile, Codes, []),
phrase(joy_defs, Codes).
assert_def(def(Def, Body)) :-
retractall(def(Def, _)),
assertz(def(Def, Body)).
:- assert_defs("defs.txt").
/*
Combinators
*/
combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
combo(dupdip, [P, X|S], [X|S], Ei, Eo) :- append(P, [X|Ei], Eo).
combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
combo(branch, [T, F, Expr|S], S, Ei, Eo) :-
\+ Expr = true, \+ Expr = false,
catch( % Try Expr and do one or the other,
(Expr -> append(T, Ei, Eo) ; append(F, Ei, Eo)),
_, % If Expr don't grok, try both branches.
(append(T, Ei, Eo) ; append(F, Ei, Eo))
).
combo(loop, [_, false|S], S, E, E ).
combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
combo(loop, [B, Expr|S], S, Ei, Eo) :-
\+ Expr = true, \+ Expr = false,
catch( % Try Expr and do one or the other,
(Expr -> append(B, [B, loop|Ei], Eo) ; Ei=Eo),
_, % If Expr don't grok, try both branches.
(Ei=Eo ; append(B, [B, loop|Ei], Eo))
).
combo(step, [_, []|S], S, E, E ).
combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
combo(times, [_, 0|S], S, E, E ).
combo(times, [P, 1|S], S, Ei, Eo) :- append(P, Ei, Eo).
combo(times, [P, N|S], S, Ei, Eo) :- N #>= 2, M #= N - 1, append(P, [M, P, times|Ei], Eo).
combo(times, [_, N|S], S, _, _ ) :- N #< 0, fail.
combo(genrec, [R1, R0, Then, If|S],
[ Else, Then, If|S], E, [ifte|E]) :-
Quoted = [If, Then, R0, R1, genrec],
append(R0, [Quoted|R1], Else).
/*
This is a crude but servicable implementation of the map combinator.
Obviously it would be nice to take advantage of the implied parallelism.
Instead the quoted program, stack, and terms in the input list are
transformed to simple Joy expressions that run the quoted program on
prepared copies of the stack that each have one of the input terms on
top. These expressions are collected in a list and the whole thing is
evaluated (with infra) on an empty list, which becomes the output list.
The chief advantage of doing it this way (as opposed to using Prolog's
map) is that the whole state remains in the pending expression, so
there's nothing stashed in Prolog's call stack. This preserves the nice
property that you can interrupt the Joy evaluation and save or transmit
the stack+expression knowing that you have all the state.
*/
combo(map, [_, []|S], [[]|S], E, E ) :- !.
combo(map, [P, List|S], [Mapped, []|S], E, [infra|E]) :-
prepare_mapping(P, S, List, Mapped).
% Set up a program for each term in ListIn
%
% [term S] [P] infrst
%
% prepare_mapping(P, S, ListIn, ListOut).
prepare_mapping(P, S, In, Out) :- prepare_mapping(P, S, In, [], Out).
prepare_mapping( _, _, [], Out, Out) :- !.
prepare_mapping( P, S, [T|In], Acc, Out) :-
prepare_mapping(P, S, In, [[T|S], P, infrst|Acc], Out).
/*
Compiler
*/
joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), asserta(Rule).
show_joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), portray_clause(Rule).
jcmpl(Name, Expression, Rule) :-
call_residue_vars(thun(Expression, Si, So), Term),
copy_term(Term, Term, Gs),
Head =.. [func, Name, Si, So],
rule(Head, Gs, Rule).
rule(Head, [], Head ).
rule(Head, [A|B], Head :- maplist(call, [A|B])).
sjc(Name, InputString) :- phrase(joy_parse(E), InputString), show_joy_compile(Name, E).
% Simple DCGs to expand/contract definitions.
expando, Body --> [Def], {def(Def, Body)}.
contracto, [Def] --> {def(Def, Body)}, Body.
% Apply expando/contracto more than once, and descend into sub-lists.
% The K term is one of expando or contracto, and the J term is used
% on sub-lists, i.e. expando/grow and contracto/shrink.
% BTW, "rebo" is a meaningless name, don't break your brain
% trying to figure it out.
rebo(K, J) --> K , rebo(K, J).
rebo(K, J), [E] --> [[H|T]], !, {call(J, [H|T], E)}, rebo(K, J).
rebo(K, J), [A] --> [ A ], !, rebo(K, J).
rebo(_, _) --> [].
to_fixed_point(DCG, Ei, Eo) :-
phrase(DCG, Ei, E), % Apply DCG...
(Ei=E -> Eo=E ; to_fixed_point(DCG, E, Eo)). % ...until a fixed-point is reached.
grow --> to_fixed_point(rebo(expando, grow )).
shrink --> to_fixed_point(rebo(contracto, shrink)).
% format_n(N) --> {number(N), !, number_codes(N, Codes)}, Codes.
% format_n(N) --> signed_digits(Codes), !, {number_codes(N, Codes)}.
% signed_digits([45|Codes]) --> [45], !, digits(Codes).
% signed_digits( Codes ) --> digits(Codes).
% digits([Ch|Chars]) --> [Ch], {code_type(Ch, digit)}, digits(Chars).
% digits([]), [Ch] --> [Ch], {code_type(Ch, space) ; Ch=0'] }.
% digits([], [], _). % Match if followed by space, ], or nothing.

37
thun/gnu-prolog/util.pl Normal file
View File

@ -0,0 +1,37 @@
% Line is the next new-line delimited line from standard input stream as
% a list of character codes.
line(Line) :- get_code(X), line(X, Line).
line(10, []) :- !. % break on new-lines.
line(-1, [eof]) :- !. % break on EOF
line(X, [X|Line]) :- get_code(Y), !, line(Y, Line).
chars([Ch|Rest]) --> char(Ch), chars(Rest).
chars([Ch]) --> char(Ch).
char(Ch) --> [Ch], { Ch \== 0'[, Ch \== 0'], Ch >= 33, Ch =< 126 }.
blanks --> blank, !, blanks.
blanks --> [].
blank --> [32].
% TODO: negative numbers, floats, scientific notation.
num(N) --> digits(Codes), !, { num(N, Codes) }.
num(_, []) :- fail, !.
num(N, [C|Codes]) :- number_codes(N, [C|Codes]).
digits([H|T]) --> digit(H), !, digits(T).
digits([]) --> [].
digit(C) --> [C], { nonvar(C), C =< 57, C >= 48 }.