%
% This is the code from the appendix of
%
% Micha Meier, "Compilation of Compound Terms in Prolog"
%

  % Compile a head compound term
  head(Term) :-
      functor(Term, F, A),
      compile_args(Term, 1, A, 1, Code,
            [branch(lab(_)), label(LR)|ReadCode]),
      read_seq(Code, ReadCode, []),
      pwrite([get_structure(F/A, reg(i), lab(LR))|Code]).

  % Compile a compound subgoal argument
  body(Term) :-
      functor(Term, F, A),
      A1 is A + 1,
      compile_body([Term|Cont], Cont, A1, [_|Code], []),
      pwrite([put_structure(F/A, reg(i))|Code]).

  % Write sequence for the arguments of a compound term
  compile_args(Term, A, A, Reg) -->
      {arg(A, Term, Arg)},
      compile_arg(Arg, Reg, last).
  compile_args(Term, I, A, Reg) -->
      {I < A, arg(I, Term, Arg), I1 is I + 1},
      compile_arg(Arg, Reg, notlast),
      compile_args(Term, I1, A, Reg).

  % Generate the write sequence for one argument
  compile_arg(Struct, Reg, last) -->
      {compound(Struct), functor(Struct, F, A)},
       [label(_), write_structure(F/A)],
       compile_args(Struct, 1, A, Reg).
   compile_arg(Struct, Reg, notlast) -->
       {compound(Struct), functor(Struct, F, A), Reg1 is Reg+1},
       [write_down(reg(Reg)), label(_), write_structure(F/A)],
       compile_args(Struct, 1, A, Reg1),
       [write_up(reg(Reg)), write_test(lab(_))].
   compile_arg(Const, _, _) -->
       {atomic(Const)},
       [write_constant(Const)].

   % Generate the read sequence and fill in the labels
   read_seq([branch(lab(L))|_]) -->
       [label(L)].
   read_seq([write_down(R)|T]) -->
       [read_down(R)],
       read_seq(T).
   read_seq([label(L), write_structure(S)|T]) -->
       [read_test(lab(L)), read_structure(S)],
       read_seq(T).
   read_seq([write_up(R), write_test(lab(L))|T]) -->
       [read_up(R), label(L)],
       read_seq(T).
   read_seq([write_constant(C)|T]) -->
       [read_constant(C)],
       read_seq(T).

   % Compile a queue of body structures
   compile_body([], [], _) --> {true}.
   compile_body([Struct|Rest], Cont, Off) -->
       {functor(Struct, F, A), Off1 is Off - 1},
       [push_constant(F/A)],
       compile_struct(Struct, 1, A, Off1, NewOff, Cont, NewCont),
       compile_body(Rest, NewCont, NewOff).

   % Compile one body structure
   compile_struct(Struct, A, A, Off, NewOff, Cont, NewCont) -->
       {arg(A, Struct, Arg)},
       compile_body_arg(Arg, Off, NewOff, Cont, NewCont).
   compile_struct(Struct, I, A, Off, NewOff, Cont, NewCont) -->
       {I < A, arg(I, Struct, Arg), I1 is I + 1},
       compile_body_arg(Arg, Off, N0, Cont, NC),
       compile_struct(Struct, I1, A, N0, NewOff, NC, NewCont).

   % Compile one argument of a body structure
   compile_body_arg(Const, Off, NewOff, C, C) -->
       {atomic(Const), NewOff is Off - 1},
       [push_constant(Const)].
   compile_body_arg(Struct, Off, NewOff, [Struct|C], C) -->
       {compound(Struct), functor(Struct, _, A),
           NewOff is Off + A},
       [push_structure(Off)].

   % Print the generated code
   pwrite([]).
   pwrite([label(Lab)|Rest]) :-
       write(Lab),
       write(:),
       pwrite(Rest).
   pwrite([Instr|Rest]) :-
       put(9),
       functor(Instr, F, A),
       write(F),
       name(F, LS),
       length(LS, Length),
       tab(20-Length),
       writeargs(Instr, 1, A),
       nl,
       pwrite(Rest).

   writeargs(Instr, A, A) :-
       arg(A, Instr, Arg),
       writearg(Arg).
   writeargs(Instr, I, A) :-
       I < A,
       arg(I, Instr, Arg),
       writearg(Arg),
       write(', '),
       I1 is I + 1,
       writeargs(Instr, I1, A).

   writearg(lab(L)) :-
       write(L).
   writearg(reg(R)) :-
       write('X'),
       write(R).
   writearg(Arg) :-
       write(Arg).

   tab(Expr) :-
   	N is Expr,
	printf("%*c", [N,0' ]).