diff --git a/thun/gnu-prolog/Makefile b/thun/gnu-prolog/Makefile new file mode 100644 index 0000000..657b958 --- /dev/null +++ b/thun/gnu-prolog/Makefile @@ -0,0 +1,8 @@ + + +thun: thun.pl + gplc -o thun thun.pl + +foo: foo.pl + gplc -o foo foo.pl + diff --git a/thun/gnu-prolog/build.sh b/thun/gnu-prolog/build.sh new file mode 100755 index 0000000..feb42f4 --- /dev/null +++ b/thun/gnu-prolog/build.sh @@ -0,0 +1 @@ +gplc --min-size -o thun thun.pl util.pl diff --git a/thun/gnu-prolog/compiler.pl b/thun/gnu-prolog/compiler.pl new file mode 100644 index 0000000..eb4746d --- /dev/null +++ b/thun/gnu-prolog/compiler.pl @@ -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 . + +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). diff --git a/thun/gnu-prolog/defs.txt b/thun/gnu-prolog/defs.txt new file mode 100644 index 0000000..3ad9205 --- /dev/null +++ b/thun/gnu-prolog/defs.txt @@ -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 \ No newline at end of file diff --git a/thun/gnu-prolog/foo.pl b/thun/gnu-prolog/foo.pl new file mode 100644 index 0000000..3ef45af --- /dev/null +++ b/thun/gnu-prolog/foo.pl @@ -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 . + +*/ +/* +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]). + + + + + diff --git a/thun/gnu-prolog/gthun.pl b/thun/gnu-prolog/gthun.pl new file mode 100644 index 0000000..46ec3bb --- /dev/null +++ b/thun/gnu-prolog/gthun.pl @@ -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. + diff --git a/thun/gnu-prolog/meta.pl b/thun/gnu-prolog/meta.pl new file mode 100644 index 0000000..524937f --- /dev/null +++ b/thun/gnu-prolog/meta.pl @@ -0,0 +1,10 @@ + + +do(DCG) :- + fd_domain(X, 0, 9), + fd_labeling(X), + number_codes(X, [C]), + DCG = `-->`(digit(C), [C]). + + + diff --git a/thun/gnu-prolog/metalogical.pl b/thun/gnu-prolog/metalogical.pl new file mode 100644 index 0000000..caf4b04 --- /dev/null +++ b/thun/gnu-prolog/metalogical.pl @@ -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] . + +*/ \ No newline at end of file diff --git a/thun/gnu-prolog/thun.pl b/thun/gnu-prolog/thun.pl new file mode 100644 index 0000000..e2dd117 --- /dev/null +++ b/thun/gnu-prolog/thun.pl @@ -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 . + +*/ +:- 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. diff --git a/thun/gnu-prolog/util.pl b/thun/gnu-prolog/util.pl new file mode 100644 index 0000000..bf760e8 --- /dev/null +++ b/thun/gnu-prolog/util.pl @@ -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 }. +