1% -----------------------------------------------------------------------------
    2%
    3%                               S I S   version 0.1
    4%
    5%                    (Straightforward Implementation of Scheme)
    6%
    7% This program is a compiler for the Scheme language which generates
    8% native code (for MC68000).  Quintus prolog has been used to develop the
    9% program.
   10%
   11% Sample use (on a SUN):
   12%
   13%  $ prolog
   14%  | ?- restore('sc.bin').         (load the compiler's image)
   15%  | ?- ex.
   16%  Input file name (.scm) : test
   17%  Input file is "test.scm"
   18%  Output file is "test.s"
   19%  | ?- halt.
   20%  $ asm test
   21%  $ test
   22%
   23% -----------------------------------------------------------------------------
   24%
   25% Revision history:
   26%
   27% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
   28%
   29% Version 0.0 (Dec 15, 1987).
   30%
   31%   - 'rest' arguments are not implemented (e.g. (lambda (a b . c) c)) and
   32%     a maximum of 126 arguments can be passed to a procedure.
   33%   - backquote notation is not supported
   34%   - floating point numbers and bignums are not implemented
   35%   - first class continuations are not implemented (all is ready for them
   36%     though; the stack could be copied by call-with-current-continuation
   37%     and restored by a call to the continuation)
   38%   - there is no garbage-collector and heap-overflow is not checked
   39%   - list constants will cause the assembly to abort (this is a restriction
   40%     caused by the SUN's assembler not the Scheme compiler) however, you
   41%     can use 'cons' to build a list at execution time
   42%   - symbols are not interned (i.e. symbol constants with the same name at
   43%     two different places are not eq?)
   44%   - only a small number of procedures are implemented, and they do not
   45%     check the type or number of their arguments.  The following procedures
   46%     are implemented:
   47%
   48%       not, eq?, pair? cons, car, cdr, set-car!, set-cdr!, null?,
   49%       =, <, >, +, -, *, /, -1+, force, write, newline
   50%
   51%       new procedures can be added by putting their names in the
   52%       'initial_global_env' list (in the compiler) and by adding their
   53%       definition in the 'header.s' file.
   54%
   55% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
   56%
   57% Version 0.1 (Jan 26, 1988).
   58%
   59%   - 'rest' arguments are now permitted.
   60%   - backquote notation is implemented.
   61%   - list constants now work correctly.
   62%   - symbols are now interned.
   63%   - primitive procedures now check the type and number of their arguments.
   64%   - it is now possible to open-code certain procedure calls; this is
   65%     done by typing 'integrate(all).' before compiling (note: open-coded
   66%     procedures do no error checking).
   67%   - source-code can be printed for procedures written with 'write' by
   68%     typing 'debug(on).'.
   69%   - some new procedures have been added:
   70%
   71%      append, length, list, vector, list->vector, memq, assq, symbol?,
   72%      vector?, string?, procedure?, number?, char?
   73%
   74% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
   75%
   76% Version 0.2 (Feb 3, 1988).
   77%
   78%   - procedure calls can be traced by typing 'trace(on).'.
   79%
   80% -----------------------------------------------------------------------------
   81
   82
   83
   84% -----------------------------------------------------------------------------
   85
   86% Toplevel of compiler.
   87
   88ex :-
   89    query_io_files(I,O),
   90    parse(I,Program),
   91    compile(Program,Code),
   92    write_code(Code,O).
   93
   94query_io_files(I,O) :-
   95    write_term('Input file name (.scm) : '),
   96    read_line(X),
   97    append(X,".scm",Y),
   98    name(I,Y),
   99    append(X,".s",Z),
  100    name(O,Z),
  101    write_term('Input file is "'), write_term(I), write_term('"'), newline,
  102    write_term('Output file is "'), write_term(O), write_term('"'), newline.
  103% -----------------------------------------------------------------------------
  104
  105% Basic file I/O and utilities.
  106
  107open_input(Filename) :- see(Filename).
  108read_char(Ch) :- get0(C), read_char2(C,Ch).
  109read_char2(-1,eof) :- !.
  110read_char2(C,C).
  111close_input :- seen.
  112
  113read_line(L) :- read_char(C), read_line(C,L).
  114read_line(C,[]) :- eoln(C), !.
  115read_line(C1,[C1|L]) :- read_char(C2), read_line(C2,L).
  116
  117open_output(Filename) :- tell(Filename).
  118write_char(Ch) :- put(Ch).
  119write_term(X) :- write(X).
  120newline :- nl.
  121close_output :- told.
  122
  123eoln(10).
  124
  125append([],L,L).
  126append([E|X],Y,[E|Z]) :- append(X,Y,Z).
  127
  128reverse(L1,L2) :- reverse_aux(L1,[],L2).
  129reverse_aux([],L,L).
  130reverse_aux([X|Y],L1,L2) :- reverse_aux(Y,[X|L1],L2).
  131
  132symbol([]) :- !, fail.
  133symbol(X) :- atom(X).
  134
  135% -----------------------------------------------------------------------------
  136
  137% Compiler option management.
  138
  139option_on(X) :- retract(options(Y)), !, union(X,Y,Z), asserta(options(Z)).
  140option_off(X) :- retract(options(Y)), !, difference(Y,X,Z), asserta(options(Z)).
  141
  142option(X) :- options(O), memb(X,O).
  143
  144:- dynamic options/1.  145
  146options([]).
  147
  148integrate(all) :- !, option_on([int(car),int(cdr),int('+'),int('-'),int('*'),
  149                                int('/'),int('-1+')]).
  150integrate(none) :- !, option_off([int(car),int(cdr),int('+'),int('-'),int('*'),
  151                                  int('/'),int('-1+')]).
  152integrate(X) :- option_on([int(X)]).
  153
  154debug(on) :- option_on([debug]).
  155
  156debug(off) :- option_off([debug]).
  157
  158trace(on) :- option_on([trace]).
  159
  160trace(off) :- option_off([trace]).
  161
  162% -----------------------------------------------------------------------------
  163
  164% Parser.
  165
  166parse(I,Program) :-
  167    write_term('1) Reading input...'), newline,
  168      open_input(I), get_source(Source), !, close_input,
  169    write_term('   ...done'), newline,
  170    write_term('2) Parsing...'), newline,
  171      white(Source,Start), sexprs(Program,Start,[]), !,
  172    write_term('   ...done'), newline.
  173
  174get_source(S) :- read_char(C), get_source(C,S).
  175get_source(eof,[]) :- !.
  176get_source(C,[C|S]) :- get_source(S).
  177
  178% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  179
  180% Use DCG for parser.
  181
  182blank --> [C], {C =< 32}, white.
  183blank --> ";", comment, white.
  184
  185white --> blank.
  186white --> [].
  187
  188comment --> [C], {eoln(C)}, !.
  189comment --> [C], comment.
  190
  191sexprs([H|T]) --> sexpr(H), !, sexprs(T).
  192sexprs([]) --> [].
  193
  194sexpr(L)                      --> "(", !, white, sexpr_list(L), white.
  195sexpr(vec(V))                 --> "#(", !, sexpr_vector(V), white.
  196sexpr(boo(t))                 --> "#t", !, white.
  197sexpr(boo(f))                 --> "#f", !, white.
  198sexpr(chr(N))                 --> "#\", [C], !, {N is C}, white. % "
  199sexpr(str(S))                 --> """", !, sexpr_string(S), white.
  200sexpr([quote,E])              --> "'", !, white, sexpr(E).
  201sexpr([quasiquote,E])         --> "`", !, white, sexpr(E).
  202sexpr(['unquote-splicing',E]) --> ",@", !, white, sexpr(E).
  203sexpr([unquote,E])            --> ",", !, white, sexpr(E).
  204sexpr(E)                      --> sym_or_num(E), white.
  205
  206sexpr_list([]) --> ")", !.
  207sexpr_list(_) --> ".", [C], {\+ sym_char(C)}, !, fail.
  208sexpr_list([Car|Cdr]) --> sexpr(Car), !, sexpr_rest(Cdr).
  209
  210sexpr_rest([]) --> ")", !.
  211sexpr_rest(E) --> ".", [C], {\+ sym_char(C)}, !, sexpr(E,C), !, ")".
  212sexpr_rest([Car|Cdr]) --> sexpr(Car), !, sexpr_rest(Cdr).
  213
  214sexpr_vector([]) --> ")", !.
  215sexpr_vector([First|Rest]) --> sexpr(First), !, sexpr_vector(Rest).
  216
  217sexpr_string([]) --> """", !.
  218sexpr_string([C|S]) --> chr(C), sexpr_string(S).
  219
  220chr(92) --> "\\", !.   
  221chr(34) --> "\""", !.  % "
  222chr(N)  --> [C], {C >= 32, N is C}.
  223
  224sym_or_num(E) --> [C], {sym_char(C)}, sym_string(S), {string_to_atom([C|S],E)}.
  225
  226sym_string([H|T]) --> [H], {sym_char(H)}, sym_string(T).
  227sym_string([]) --> [].
  228
  229number(N) --> unsigned_number(N).
  230number(N) --> "-", unsigned_number(M), {N is -M}.
  231number(N) --> "+", unsigned_number(N).
  232
  233unsigned_number(N) --> digit(X), unsigned_number(X,N).
  234unsigned_number(N,M) --> digit(X), {Y is N*10+X}, unsigned_number(Y,M).
  235unsigned_number(N,N) --> [].
  236
  237digit(N) --> [C], {C >= 48, C =<57, N is C-48}.
  238
  239% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  240
  241sexpr(E,C,X,Z) :- white([C|X],Y), sexpr(E,Y,Z).
  242
  243sym_char(C) :- C > 32, \+ memb(C,";()#""',`").
  244
  245string_to_atom(S,N) :- number(N,S,[]), !.
  246string_to_atom(S,I) :- lowcase(S,L), name(I,L).
  247
  248lowcase([],[]).
  249lowcase([C1|T1],[C2|T2]) :- lowercase(C1,C2), lowcase(T1,T2).
  250
  251lowercase(C1,C2) :- C1 >= 65, C1 =< 90, !, C2 is C1+32.
  252lowercase(C,C).
  253% -----------------------------------------------------------------------------
  254
  255% Compilation.
  256
  257compile(Program,Code) :-
  258    write_term('3) Compilation...'), newline,
  259      compile_list(Program,Expr), !,
  260    write_term('   ...done'), newline,
  261    write_term('4) Virtual machine code generation...'), newline,
  262      gen_program(Expr,Code), !,
  263    write_term('   ...done'), newline.
  264
  265compile_list([],cst(U)) :- !, undefined(U).
  266compile_list([Expr],C) :- !, compile_expr(Expr,C).
  267compile_list([Expr|Tail],app([pro(['#'],none,[],[],Rest,[]),C])) :-
  268    compile_expr(Expr,C),
  269    compile_list(Tail,Rest).
  270
  271compile_expr([define|Def],set(Var,C)) :- !,
  272    definition(Def,[Var,Expr]),
  273    write_term('   compiling '), write_term(Var), newline,
  274    compile_expression(Expr,C).
  275compile_expr(Expr,C) :-
  276    write_term('   compiling <expression>'), newline,
  277    compile_expression(Expr,C).
  278
  279compile_expression(E,C) :-
  280    expand(E,X),    % expand macros and convert to prolog structures
  281    alpha(X,Y),     % rename variables and convert assignments
  282    closurize(Y,C). % find out which lambda-expression are actually going to
  283                    % be 'true' closures (i.e. they have closed variables)
  284
  285% To add new predefined procedures, add their names to this list:
  286
  287initial_global_env([
  288  '#trace', '#make-promise', '#memv', '#cons', '#list', '#append', '#list->vector',
  289  not, 'eq?', 'pair?', cons, append, length, car, cdr, 'set-car!', 'set-cdr!',
  290  'null?', '=', '<', '>', '+', '-', '*', '/', '-1+', force, write, newline,
  291  list, vector, 'list->vector', memq, assq, 'symbol?', 'vector?', 'string?',
  292  'procedure?', 'number?', 'char?'
  293]).
  294
  295% -----------------------------------------------------------------------------
  296
  297% Code output to file.
  298
  299write_code(Code,O) :-
  300    write_term('5) Writing M68000 machine code...'), newline,
  301      open_output(O),
  302      emit_objects(Code,[],_), !,
  303      close_output,
  304    write_term('   ...done'), newline.
  305
  306% Emit a sequence of Scheme objects (i.e. symbols, lists, vectors, strings
  307% and procedure definitions) to the output file.  The complication is
  308% that writing an object might require writing others (e.g. for vectors
  309% the elements have to be written also (recursively)) and that a given
  310% symbol should only be output once.
  311
  312emit_objects([],Syms,Syms).
  313emit_objects([Object|Tail],Syms1,Syms3) :-
  314    emit_object(Object,Vals1,Syms1,Syms2),
  315    append(Vals1,Tail,Vals2),
  316    emit_objects(Vals2,Syms2,Syms3).
  317
  318emit_object(obj(Label,S),Vals,Syms1,Syms2) :- symbol(S), !,
  319    name(S,L),
  320    conv_obj(str(L),String,[],Vals,Syms1,Syms2),
  321    write_term(symbol_object(Label,String)), newline.
  322emit_object(obj(Label,[Car|Cdr]),Vals2,Syms1,Syms3) :-
  323    conv_obj(Car,Car_val,[],Vals1,Syms1,Syms2),
  324    conv_obj(Cdr,Cdr_val,Vals1,Vals2,Syms2,Syms3),
  325    write_term(pair_object(Label,Car_val,Cdr_val)), newline.
  326emit_object(obj(Label,vec(L)),Vals,Syms1,Syms2) :-
  327    length(L,Length),
  328    write_term(vector_object(Label,Length)), newline,
  329    emit_object_list(L,[],Vals,Syms1,Syms2).
  330emit_object(obj(Label,str(L)),[],Syms,Syms) :-
  331    length(L,Length),
  332    write_term(string_object), write_char(40),
  333    write_term(Label), comma, emit_string(L), write_char(41), newline.
  334emit_object(obj(Label,pro(L,Source)),Vals,Syms1,Syms2) :-
  335    write_term(procedure_object_begin(Label)), newline,
  336    emit_instructions(L,[],Const1),
  337    write_term(procedure_object_constants), newline,
  338    genlabel(Source_label),
  339    include_source(Source,Include),
  340    append(Const1,[const(Source_label,Include)],Const2),
  341    emit_constants(Const2,[],Vals,Syms1,Syms2),
  342    write_term(procedure_object_end), newline.
  343
  344emit_string(S) :- write_char(96), write_char(34),
  345                  emit_string2(S),
  346                  write_char(34), write_char(39).
  347
  348emit_string2([]).
  349emit_string2([C|L]) :- (C<32;C=34;C=92;C>=127), !, write_char(92),
  350                       N1 is 48+(C // 64), write_char(N1),
  351                       N2 is 48+((C // 8) mod 8), write_char(N2),
  352                       N3 is 48+(C mod 8), write_char(N3),
  353                       emit_string2(L).
  354emit_string2([C|L]) :- write_char(C), emit_string2(L).
  355
  356include_source(Source,Source) :- option(debug), !.
  357include_source(Source,[]).
  358
  359emit_instructions([],Const,Const).
  360emit_instructions([Instr|Tail],Const1,Const3) :-
  361    emit(Instr,Const1,Const2),
  362    emit_instructions(Tail,Const2,Const3).
  363
  364emit_constants([],Vals,Vals,Syms,Syms).
  365emit_constants([const(Label,Object)|Tail],Vals1,Vals3,Syms1,Syms3) :-
  366    emit(label(Label)),
  367    conv_obj(Object,Value,Vals1,Vals2,Syms1,Syms2),
  368    opcode('.long'), label(Value), newline,
  369    emit_constants(Tail,Vals2,Vals3,Syms2,Syms3).
  370
  371emit_object_list([],Vals,Vals,Syms,Syms).
  372emit_object_list([Object|Tail],Vals1,Vals3,Syms1,Syms3) :-
  373    conv_obj(Object,Value,Vals1,Vals2,Syms1,Syms2),
  374    opcode('.long'), label(Value), newline,
  375    emit_object_list(Tail,Vals2,Vals3,Syms2,Syms3).
  376
  377conv_obj(Object,Value,Vals,Vals,Syms,Syms) :- non_gc(Object,Value), !.
  378conv_obj(Object,Value,Vals,Vals,Syms,Syms) :- memb(sym(Object,Value),Syms), !.
  379conv_obj(Object,Value,Vals,[obj(Value,Object)|Vals],Syms1,Syms2) :-
  380    genlabel(Value),
  381    intern_symbol(Object,Value,Syms1,Syms2).
  382
  383intern_symbol(Object,Value,Syms,[sym(Object,Value)|Syms]) :- symbol(Object), !.
  384intern_symbol(Object,Value,Syms,Syms).
  385
  386% -----------------------------------------------------------------------------
  387
  388% Virtual machine implementation for MC68000.
  389
  390% Each virtual instruction generated is expanded into MC68000 code.  The
  391% virtual instructions are:
  392
  393% label(Label)                - declare a label
  394% dealloc(Depth)              - deallocate words from the stack
  395% return(Depth)               - deallocate and return to caller
  396% enter(Type,Nb_args,Kind)    - enter a procedure of Nb_args parameters (Type
  397%                               is the type of procedure (either 'closure' or
  398%                               'plain') and Kind specifies if the last
  399%                               parameter is a rest parameter)
  400% jump_glo(Disp,Nb_args)      - jump to a global procedure
  401% jump(Src,Nb_args)           - jump to a procedure (general form)
  402% sub_procedure(Label)        - declare a sub-procedure label
  403% push_continuation(Label)    - push a sub-procedure label (ie. a return addr.)
  404% branch_if_false(Src,Label)  - branch to label if 'Src' is false
  405% branch_always(Label)        - branch to label
  406% move(Src,Dest)              - move 'Src' to 'Dest'
  407% set_glo(Disp,Src)           - set a global variable
  408% set_clo(Depth,Disp,Src)     - set a closed variable
  409% set_loc(Disp,Src)           - set a local variable
  410% box_clo(Depth,Disp,Dest)    - put a closed variable in a cell
  411% box_loc(Disp,Dest)          - put a local variable in a cell
  412% get_clo(Depth,Disp,Dest)    - fetch the value of a mutable closed variable
  413% get_loc(Disp,Dest)          - fetch the value of a mutable local variable
  414% ref_glo(Disp,Dest)          - fetch the value of a global variable
  415% ref_clo(Depth,Disp,Dest)    - fetch the value of a closed variable
  416% ref_loc(Disp,Dest)          - fetch the value of a local variable
  417% cst(Val,Dest)               - move a constant value to 'Dest'
  418% make_closure(Body,Nb_closed,Dest) - make a closure with a given 'Body'
  419% close_loc(Disp)             - add a local variable to a closure
  420% close_clo(Disp)             - add a closed variable to a closure
  421% open_code(Proc,Nb_args)     - open code the procedure 'Proc' taking
  422%                               'Nb_args' arguments
  423
  424integrable(car,1).
  425emit(open_code(car,1)) :-
  426    opcode(movl), dregister(1),  comma, aregister(0), newline,
  427    opcode(movl), indirect(0,0), comma, dregister(1), newline.
  428
  429integrable(cdr,1).
  430emit(open_code(cdr,1)) :-
  431    opcode(movl), dregister(1), comma, aregister(0), newline,
  432    opcode(movl), autodecr(0),  comma, dregister(1), newline.
  433
  434integrable('+',2).
  435emit(open_code('+',2)) :-
  436    opcode(addl), dregister(2), comma, dregister(1), newline.
  437
  438integrable('-',1).
  439emit(open_code('-',1)) :-
  440    opcode(negl), dregister(1), newline.
  441
  442integrable('-',2).
  443emit(open_code('-',2)) :-
  444    opcode(subl), dregister(2), comma, dregister(1), newline.
  445
  446integrable('*',2).
  447emit(open_code('*',2)) :-
  448    opcode(asrl), immediate(3), comma, dregister(1), newline,
  449    opcode(muls), dregister(2), comma, dregister(1), newline.
  450
  451integrable('/',2).
  452emit(open_code('/',2)) :-
  453    opcode(divs), dregister(2), comma, dregister(1), newline,
  454    opcode(extl), dregister(1), newline,
  455    opcode(asll), immediate(3), comma, dregister(1), newline.
  456
  457integrable('-1+',1).
  458emit(open_code('-1+',1)) :-
  459    opcode(subql), immediate(8), comma, dregister(1), newline.
  460
  461emit(cst(Object,Dest),Const,Const) :- non_gc(Object,Value), !,
  462    emit_non_gc(Value,Dest).
  463emit(cst(Object,Dest),Const,[const(Label,Object)|Const]) :- !,
  464    genlabel(Label),
  465    opcode(movl), label(Label), comma, destination(Dest), newline.
  466
  467emit(make_closure(Proc,Nb_closed,Dest),Const,[const(Label,Proc)|Const]) :-
  468    genlabel(Label),
  469    Tag is Nb_closed+1-8192,
  470    opcode(movw), immediate(Tag),   comma, autoincr(5), newline,
  471    opcode(movl), aregister(5),     comma, destination(Dest), newline,
  472    opcode(movw), immediate(20153), comma, autoincr(5), newline,
  473    opcode(movl), label(Label),     comma, autoincr(5), newline.
  474
  475emit(Instr,Const,Const) :- emit(Instr).
  476
  477emit(ref_loc(Disp,Dest)) :-
  478    Byte_disp is Disp*4,
  479    opcode(movl), indirect(7,Byte_disp), comma, destination(Dest), newline.
  480
  481emit(ref_clo(Depth,Disp,Dest)) :-
  482    Byte_depth is Depth*4-4,
  483    Byte_disp  is Disp*4+6,
  484    opcode(movl), indirect(7,Byte_depth), comma, aregister(0), newline,
  485    opcode(movl), indirect(0,Byte_disp),  comma, destination(Dest), newline.
  486
  487emit(ref_glo(Disp,Dest)) :-
  488    Byte_disp is Disp*6+6,
  489    opcode(movl), indirect(6,Byte_disp), comma, destination(Dest), newline.
  490
  491emit(get_loc(Disp,Dest)) :-
  492    emit(ref_loc(Disp,-1)),
  493    opcode(movl), indirect(0,0), comma, destination(Dest), newline.
  494
  495emit(get_clo(Depth,Disp,Dest)) :-
  496    emit(ref_clo(Depth,Disp,-1)),
  497    opcode(movl), indirect(0,0), comma, destination(Dest), newline.
  498
  499emit(box_loc(Disp,Dest)) :-
  500    emit(ref_loc(Disp,0)),
  501    opcode(movl), dregister(0), comma, autodecr(4), newline,
  502    opcode(movl), aregister(4), comma, destination(Dest), newline,
  503    opcode(movl), dregister(0), comma, autodecr(4), newline.
  504
  505emit(box_clo(Depth,Disp,Dest)) :-
  506    emit(ref_clo(Depth,Disp,0)),
  507    opcode(movl), dregister(0), comma, autodecr(4), newline,
  508    opcode(movl), aregister(4), comma, destination(Dest), newline,
  509    opcode(movl), dregister(0), comma, autodecr(4), newline.
  510
  511emit(set_loc(Disp,Src)) :-
  512    emit(ref_loc(Disp,-1)),
  513    opcode(movl), source(Src), comma, indirect(0,0), newline.
  514
  515emit(set_clo(Depth,Disp,Src)) :-
  516    emit(ref_clo(Depth,Disp,-1)),
  517    opcode(movl), source(Src), comma, indirect(0,0), newline.
  518
  519emit(set_glo(Disp,Src)) :-
  520    Byte_disp1 is Disp*6+4,
  521    Byte_disp2 is Disp*6+6,
  522    opcode(movw), immediate(20115), comma, indirect(6,Byte_disp1), newline,
  523    opcode(movl), source(Src),      comma, indirect(6,Byte_disp2), newline.
  524
  525emit(move(X,X)) :- !.
  526emit(move(Src,Dest)) :-
  527    opcode(movl), destination(Src), comma, destination(Dest), newline.
  528
  529emit(branch_always(Label)) :-
  530    opcode(bra), label(Label), newline.
  531
  532emit(branch_if_false(Src,Label)) :-
  533    opcode(addql), immediate(3), comma, source(Src), newline,
  534    opcode(bcs),   label(Label), newline.
  535
  536emit(push_continuation(Label)) :- !,
  537    opcode(pea), label(Label), newline.
  538
  539emit(close_loc(Disp)) :-
  540    Byte_disp is Disp*4,
  541    opcode(movl), indirect(7,Byte_disp), comma, autoincr(5), newline.
  542
  543emit(close_clo(Depth,Disp)) :-
  544    Byte_depth is Depth*4-4,
  545    Byte_disp  is Disp*4+6,
  546    opcode(movl), indirect(7,Byte_depth), comma, aregister(0), newline,
  547    opcode(movl), indirect(0,Byte_disp),  comma, autoincr(5), newline.
  548
  549emit(sub_procedure(Label)) :-
  550    write_term(sub_procedure(Label)), newline.
  551
  552emit(jump(Src,Nb_args)) :-
  553    nb_arg_code(Nb_args,Code),
  554    genlabel(Error),
  555    opcode(btst),  source(Src),     comma, dregister(7), newline,
  556    opcode(beqs),  label(Error), newline,
  557    opcode(movl),  source(Src),     comma, aregister(0), newline,
  558    opcode(tstw),  indirect(0,-2), newline,
  559    opcode(bpls),  label(Error), newline,
  560    opcode(moveq), immediate(Code), comma, dregister(0), newline,
  561    opcode(jmp),   indirect(0,0), newline,
  562    emit(label(Error)),
  563    opcode(jmp),   indirect(6,-510), newline.
  564    
  565emit(jump_glo(Disp,Nb_args)) :-
  566    nb_arg_code(Nb_args,Code),
  567    Byte_disp is Disp*6+4,
  568    opcode(moveq), immediate(Code), comma, dregister(0), newline,
  569    opcode(jmp),   indirect(6,Byte_disp), newline.
  570
  571emit(return(Depth)) :-
  572    emit(dealloc(Depth),Const,Const),
  573    opcode(rts), newline.
  574
  575emit(dealloc(0)) :- !.
  576emit(dealloc(Depth)) :- Depth =< 2, !,
  577    Byte_depth is Depth*4,
  578    opcode(addql), immediate(Byte_depth), comma, aregister(7), newline.
  579emit(dealloc(Depth)) :-
  580    Byte_depth is Depth*4,
  581    opcode(addw), immediate(Byte_depth), comma, aregister(7), newline.
  582
  583emit(label(Label)) :-
  584    label(Label), write_char(58), newline.
  585
  586emit(enter(Type,Nb_args,rest)) :-
  587    genlabel(Label),
  588    rest_enter(Type,Handler),
  589    opcode(movw), immediate(Nb_args), comma, aregister(0), newline,
  590    opcode(lea),  label(Label),       comma, aregister(1), newline,
  591    opcode(jmp),  indirect(6,Handler), newline,
  592    emit(sub_procedure(Label)).
  593emit(enter(plain,Nb_args,none)) :-
  594    genlabel(Error),
  595    genlabel(Continue),
  596    emit_arg_check(Nb_args,Error),
  597    opcode(cmpl), indirect(6,0), comma, aregister(7), newline,
  598    opcode(bhis), label(Continue), newline,
  599    emit(label(Error)),
  600    opcode(jmp),  indirect(6,-522), newline,
  601    emit(label(Continue)),
  602    emit_push_args(Nb_args).
  603emit(enter(closure,Nb_args,none)) :-
  604    genlabel(Error),
  605    genlabel(Continue),
  606    emit_arg_check(Nb_args,Error),
  607    opcode(cmpl),  indirect(6,0), comma, aregister(7), newline,
  608    opcode(bhis),  label(Continue), newline,
  609    emit(label(Error)),
  610    opcode(jmp),   indirect(6,-516), newline,
  611    emit(label(Continue)),
  612    opcode(subql), immediate(6), comma, indirect(7,0), newline,
  613    emit_push_args(Nb_args).
  614
  615rest_enter(plain,-534).
  616rest_enter(closure,-528).
  617    
  618emit_arg_check(1,Label) :- !,
  619    opcode(bpls), label(Label), newline.
  620emit_arg_check(2,Label) :- !,
  621    opcode(bnes), label(Label), newline.
  622emit_arg_check(N,Label) :- N < 8, !,
  623    M is N+1,
  624    opcode(subqw), immediate(M), comma, dregister(0), newline,
  625    opcode(bnes),  label(Label), newline.
  626emit_arg_check(N,Label) :-
  627    M is N+1,
  628    opcode(subw), immediate(M), comma, dregister(0), newline,
  629    opcode(bnes), label(Label), newline.
  630
  631emit_push_args(0) :- !.
  632emit_push_args(1) :- !,
  633    opcode(movl), dregister(1), comma, destination(push), newline.
  634emit_push_args(2) :- !,
  635    opcode(movl), dregister(2), comma, destination(push), newline,
  636    opcode(movl), dregister(1), comma, destination(push), newline.
  637emit_push_args(3) :- !,
  638    opcode(moveml), immediate(28672), comma, destination(push), newline.
  639emit_push_args(4) :- !,
  640    opcode(moveml), immediate(30720), comma, destination(push), newline.
  641emit_push_args(N) :- !,
  642    emit_push_arg(N),
  643    emit_push_args(4).
  644
  645emit_push_arg(4) :- !.
  646emit_push_arg(N) :-
  647    Dist is -4*N, M is N-1,
  648    opcode(movl), indirect(6,Dist), comma, destination(push), newline,
  649    emit_push_arg(M).
  650    
  651nb_arg_code(1,-1) :- !.
  652nb_arg_code(2,0) :- !.
  653nb_arg_code(N,M) :- M is N+1.
  654
  655non_gc(Val,Value) :- integer(Val), Value is Val*8.
  656non_gc([],-1).
  657non_gc(boo(f),-3).
  658non_gc(boo(t),-5).
  659non_gc(Val,-7) :- undefined(Val).
  660non_gc(chr(N),Value) :- Value is N*2-131071.
  661
  662data_reg(N) :- integer(N), 1 =< N, N =< 4.
  663
  664emit_non_gc(Value,Dest) :- -128=<Value, Value<128, \+ data_reg(Dest), !,
  665    opcode(moveq), immediate(Value), comma, dregister(0), newline,
  666    emit(move(0,Dest)).
  667emit_non_gc(Value,Dest) :- -128=<Value, Value<128, Dest>=0, !,
  668    opcode(moveq), immediate(Value), comma, destination(Dest), newline.
  669emit_non_gc(Value,Dest) :-
  670    opcode(movl), immediate(Value), comma, destination(Dest), newline.
  671
  672label(Label) :-
  673    write_term(Label).
  674
  675opcode(Op) :-  write_char(9), write_term(Op), write_char(9).
  676
  677comma :- write_char(44).
  678
  679immediate(N) :- write_char(35), write_term(N).
  680
  681aregister(N) :- write_char(97), write_term(N).
  682
  683dregister(N) :- write_char(100), write_term(N).
  684
  685indirect(Areg,0) :- !,
  686    aregister(Areg),
  687    write_char(64).
  688indirect(Areg,Disp) :-
  689    aregister(Areg),
  690    write_char(64),
  691    write_char(40),
  692    write_term(Disp),
  693    write_char(41).
  694
  695autoincr(N) :- indirect(N,0), write_char(43).
  696
  697autodecr(N) :- indirect(N,0), write_char(45).
  698
  699destination(push) :- !, autodecr(7).
  700destination(pop) :- !, autoincr(7).
  701destination(top) :- !, indirect(7,0).
  702destination(N) :- N < 0, !, M is -1-N, aregister(M).
  703destination(N) :- N > 4, !, Byte_disp is -4*N, indirect(6,Byte_disp).
  704destination(N) :- dregister(N).
  705
  706source(push) :- !, destination(top).
  707source(pop) :- !, destination(top).
  708source(X) :- destination(X).
  709
  710% -----------------------------------------------------------------------------
  711
  712% Symbol generation routines.
  713
  714genvar(V) :- gensym('#',V).
  715
  716genlabel(V) :- gensym(l,V).
  717
  718gensym(Name,S) :-
  719    gennum(N),
  720    name(Name,S1),
  721    name(N,S2),
  722    append(S1,S2,S3),
  723    name(S,S3), !.
  724
  725gennum(N) :-
  726  last_num(LN),
  727  N is LN+1,
  728  retract(last_num(LN)), !,
  729  asserta(last_num(N)).
  730
  731:- dynamic last_num/1.  732
  733last_num(0).
  734
  735% -----------------------------------------------------------------------------
  736
  737% Mutable variable analysis.
  738
  739% Compute the set of all variables which are assigned in a given expression.
  740
  741mut_vars(Expr,L) :- mut_vars(Expr,[],L).
  742mut_vars(cst(C),Env,[]).
  743mut_vars(ref(V),Env,[]).
  744mut_vars(set(V,E),Env,S) :- free_var(V,Env,X), mut_vars(E,Y), union(X,Y,S).
  745mut_vars(tst(X,Y,Z),Env,S) :- mut_list([X,Y,Z],Env,S).
  746mut_vars(pro(P,K,B,_),Env,S) :- append(P,Env,X), mut_vars(B,X,S).
  747mut_vars(app(L),Env,S) :- mut_list(L,Env,S).
  748
  749mut_list([],Env,[]).
  750mut_list([E|Tail],Env,S) :-
  751    mut_vars(E,Env,X),
  752    mut_list(Tail,Env,Y),
  753    union(X,Y,S).
  754
  755mut_bindings([],_,[]).
  756mut_bindings([V|Tail],Vals,S) :-
  757    memb(val(V,Val),Vals),
  758    mut_vars(Val,X),
  759    mut_bindings(Tail,Vals,Y),
  760    union(X,Y,S).
  761
  762% -----------------------------------------------------------------------------
  763
  764% Free variable analysis.
  765
  766% Compute the set of all free variables in a given expression.
  767
  768free_vars(Expr,L) :- free_vars(Expr,[],L).
  769free_vars(cst(C),Env,[]).
  770free_vars(ref(V),Env,S) :- free_var(V,Env,S).
  771free_vars(get(V),Env,S) :- free_var(V,Env,S).
  772free_vars(box(V),Env,S) :- free_var(V,Env,S).
  773free_vars(set(V,E),Env,S) :- free_var(V,Env,X), free_vars(E,Y), union(X,Y,S).
  774free_vars(tst(X,Y,Z),Env,S) :- free_list([X,Y,Z],Env,S).
  775free_vars(pro(P,K,B,_),Env,S) :- append(P,Env,X), free_vars(B,X,S).
  776free_vars(app(L),Env,S) :- free_list(L,Env,S).
  777
  778free_list([],Env,[]).
  779free_list([E|Tail],Env,S) :-
  780    free_vars(E,Env,X),
  781    free_list(Tail,Env,Y),
  782    union(X,Y,S).
  783
  784free_var(V,Env,[]) :- memb(V,Env), !.
  785free_var(V,Env,[V]).
  786
  787% -----------------------------------------------------------------------------
  788
  789% Normalization of expressions.
  790
  791% The input is an S-expression that follows Scheme's syntax for expressions.
  792% The resulting expression will only contain the following structures:
  793%
  794%   cst(C)        a constant of value 'C'
  795%   ref(V)        a reference to variable 'V'
  796%   set(V,X)      an assignment of expression 'X' to variable 'V'
  797%   tst(X,Y,Z)    a conditionnal expression (X=test,Y=consequent,Z=alternative)
  798%   app(L)        an application (first expr in 'L'=procedure, rest=arguments)
  799%   pro(P,K,B,S)  a procedure (lambda-expression) having 'P' as formal
  800%                 parameters (i.e. the list of all parameters in order),
  801%                 the expression 'B' as body and 'S' as source-code ('K' is
  802%                 'rest' if there is a rest parameter and 'none' otherwise)
  803%
  804% Most of the conversion is done through macro expansion and is fairly
  805% straightforward.  The hardest expressions to convert are mutually or
  806% self-recursive expressions (such as 'letrec's, 'define's, etc...).
  807% They are converted first by doing a topological sort on the sub-expressions
  808% according to the variable dependencies between them.  The equivalent of a
  809% cascade of 'let's is generated for the expressions which are not really
  810% recursive.  When they really are recursive (i.e. a cycle has been discovered
  811% while doing the topological sort), a method involving a kind of 'Y' operator
  812% is used.  I will not describe it in detail but here is an example that gives
  813% a flavor of what is done:
  814%
  815% (letrec ((fact (lambda (x) (if (< x 2) 1 (* x (fact (- x 1))))))) (fact 5))
  816%
  817% is converted into the equivalent of:
  818%
  819% (let ((fact (lambda (fact)
  820%               (lambda (x)
  821%                 (let ((fact (fact fact)))
  822%                   (if (< x 2) 1 (* x (fact (- x 1)))))))))
  823%   (let ((fact (fact fact)))
  824%     (fact 5)))
  825%
  826% There is an added complication when the recursive expressions are bound
  827% to mutable variables.  In this case, an allocate/assign/use form must
  828% be generated.  For example,
  829%
  830% (letrec ((loop (lambda () (loop)))) (set! loop read))
  831%
  832% is transformed into the equivalent of:
  833%
  834% (let ((loop 'undefined))
  835%   (set! loop (lambda () (loop)))
  836%   (set! loop read))
  837
  838expand([H|T],X) :- !, expnd([H|T],X).
  839expand(V,ref(V)) :- symbol(V), !.
  840expand(C,cst(C)).
  841
  842expnd([quote,X],cst(X)) :- !.
  843expnd(['set!',V,E],set(V,X)) :- !, expand(E,X).
  844expnd([if,X,Y],Z) :- undefined(U), !, expand([if,X,Y,U],Z).
  845expnd([if,X,Y,Z],tst(A,B,C)) :- !, expand(X,A), expand(Y,B), expand(Z,C).
  846expnd([lambda,Parms|X],pro(P,K,B,[lambda,Parms|X])) :- !,
  847    parameters(Parms,P,K), body(X,B).
  848expnd([letrec,Bindings|Exprs],Y) :- !, body(Exprs,X), letrec(Bindings,X,Y).
  849expnd([begin|Tail],Y) :- !, expnd_list(Tail,X), begin(X,Y).
  850expnd(X,Z) :- macro(X,Y), !, expand(Y,Z).
  851expnd(X,Z) :- expnd_list(X,Y), add_trace(X,Y,Z).
  852
  853add_trace(X,Y,app([pro(Temps,none,Z,[])|Y])) :- option(trace), !,
  854    make_temps(Y,Temps),
  855    ref_list(Temps,Refs),
  856    begin([app([ref('#trace'),app([ref('#list')|Refs])]),app(Refs)],Z).
  857add_trace(X,Y,app(Y)).
  858
  859make_temps([],[]).
  860make_temps([E|Tail1],[V|Tail2]) :- genvar(V), make_temps(Tail1,Tail2).
  861
  862parameters(Param_pattern,Params,Kind) :- params(Param_pattern,Kind,[],Params).
  863
  864params([],none,P,P) :- !.
  865params([V|Tail],R,P1,P3) :- !, param_add(V,P1,P2), params(Tail,R,P2,P3).
  866params(V,rest,P1,P2) :- param_add(V,P1,P2).
  867
  868param_add(V,_,_) :- \+ symbol(V), !,
  869    error("Variable name must be a symbol").
  870param_add(V,P,_) :- memb(V,P), !,
  871    error("Duplicate variable name in binding list").
  872param_add(V,P1,P2) :- append(P1,[V],P2).
  873
  874expnd_list([],[]).
  875expnd_list([X|Tail1],[Y|Tail2]) :- expand(X,Y), expnd_list(Tail1,Tail2).
  876
  877begin([E],E).
  878begin([E|Tail],app([pro([V],none,X,[]),E])) :- begin(Tail,X), genvar(V).
  879
  880body(Exprs,Z) :-
  881    local_defs(Exprs,Defs,Body),
  882    expnd_list(Body,X),
  883    begin(X,Y),
  884    letrec(Defs,Y,Z).
  885
  886local_defs([[define|Def1]|Tail1],[Def2|Tail2],B) :- !,
  887    definition(Def1,Def2),
  888    local_defs(Tail1,Tail2,B).
  889local_defs(B,[],B).
  890
  891definition([[Variable|Formals]|Body],[Variable,[lambda,Formals|Body]]) :- !.
  892definition([Variable,Expression],[Variable,Expression]) :- !.
  893definition([Variable],[Variable,U]) :- undefined(U).
  894
  895letrec(Bindings,Body,X) :-
  896    split(Bindings,Vars,Vals),
  897    dependency_graph(Vals,Vars,Dep),
  898    topological_sort(Dep,Binding_order),
  899    bind_in_order(Binding_order,Body,Vals,X).
  900
  901split([],[],[]).
  902split([[Var,Val]|Tail1],Vars2,[val(Var,X)|Tail2]) :-
  903    expand(Val,X),
  904    split(Tail1,Vars1,Tail2),
  905    union([Var],Vars1,Vars2).
  906
  907dependency_graph([],_,[]).
  908dependency_graph([val(Var,Val)|Tail1],Vars,[node(Var,Dep,_)|Tail2]) :-
  909    free_vars(Val,L),
  910    intersection(Vars,L,Dep),
  911    dependency_graph(Tail1,Vars,Tail2).
  912
  913bind_in_order([],Body,Vals,Body).
  914bind_in_order([Bindings|Tail],Body,Vals,X) :-
  915    bind_in_order(Tail,Body,Vals,New_body),
  916    bind_level(Bindings,New_body,Vals,X).
  917
  918bind_level(V,Body,Vals,app([pro([V],none,Body,[]),Val])) :- symbol(V), !,
  919    memb(val(V,Val),Vals).
  920bind_level(L,Body,Vals,X) :- lambdas(L,Vals), !,
  921    mut_bindings(L,Vals,Mut1),
  922    mut_vars(Body,Mut2),
  923    union(Mut1,Mut2,Mut3),
  924    intersection(Mut3,L,Mut),
  925    difference(L,Mut,Non_mut),
  926    bind_cyclic(Mut,Non_mut,Body,Vals,X).
  927bind_level(_,_,_,_) :-
  928    error("untransformable cyclical definition").
  929
  930lambdas([],_).
  931lambdas([V|Tail],Vals) :- memb(val(V,pro(_,_,_,_)),Vals), lambdas(Tail,Vals).
  932
  933bind_cyclic([],Non_mut,Body,Vals,X) :- !,
  934    bind_non_mut(Non_mut,Body,Vals,X).
  935bind_cyclic(Mut,Non_mut,Body,Vals,app([pro(Mut,none,Z,[])|Undefs])) :- !,
  936    bind_mut(Mut,Vals,Undefs,Assignments),
  937    append(Assignments,[Body],X),
  938    begin(X,Y),
  939    bind_non_mut(Non_mut,Y,Vals,Z).
  940
  941bind_mut([],_,[],[]).
  942bind_mut([V|Tail1],Vals,[U|Tail2],[set(V,Val)|Tail3]) :-
  943    undefined(U),
  944    memb(val(V,Val),Vals),
  945    bind_mut(Tail1,Vals,Tail2,Tail3).
  946
  947bind_non_mut([],Body,_,Body) :- !.
  948bind_non_mut(L,Body,Vals,
  949             app([pro(L,none,app([pro(L,none,Body,[])|V1]),[])|V2])) :-
  950    fix_procs1(L,L,V1),
  951    fix_procs2(L,L,Vals,V1,V2).
  952
  953fix_procs1(L,[],[]).
  954fix_procs1(L,[V|Tail1],[app(X)|Tail2]) :-
  955    ref_list([V|L],X),
  956    fix_procs1(L,Tail1,Tail2).
  957
  958fix_procs2(L,[],_,_,[]).
  959fix_procs2(L,[V|T1],Vals,V1,
  960           [pro(L,none,pro(X,Y,app([pro(L,none,Z,[])|V1]),S),[])|T2]) :-
  961    memb(val(V,pro(X,Y,Z,S)),Vals),
  962    fix_procs2(L,T1,Vals,V1,T2).
  963
  964ref_list([],[]).
  965ref_list([V|Tail1],[ref(V)|Tail2]) :- ref_list(Tail1,Tail2).
  966
  967undefined(spc(undef)).
  968% -----------------------------------------------------------------------------
  969
  970% Macro definitions.
  971
  972%   (quasiquote A)  -->
  973
  974macro([quasiquote,X],Y) :- template(X,1,Y).
  975
  976template(X,0,X) :- !.
  977template([unquote,X],1,X) :- !.
  978template(['unquote-splicing'],1,_) :- !,
  979    error("Misplaced 'unquote-splicing' special form").
  980template([quasiquote,X],N,Y) :- !, M is N+1, list_template([quasiquote,X],M,Y).
  981template([unquote,X],N,Y) :- !, M is N-1, list_template([unquote,X],M,Y).
  982template([Car|Cdr],N,Y) :- list_template([Car|Cdr],N,Y).
  983template(vec(L),N,Y) :- vector_template(L,N,X), vectorize_form(X,Y).
  984template(X,N,[quote,X]).
  985
  986list_template([['unquote-splicing',X]],1,X) :- !.
  987list_template([['unquote-splicing',X]|Cdr],1,Y) :- !,
  988    template(Cdr,1,A),
  989    append_forms(X,A,Y).
  990list_template([Car|Cdr],N,Y) :-
  991    template(Car,N,A),
  992    template(Cdr,N,B),
  993    cons_forms(A,B,Y).
  994
  995vector_template([['unquote-splicing',X]],1,X) :- !.
  996vector_template([['unquote-splicing',X]|Cdr],1,Y) :- !,
  997    vector_template(Cdr,1,A),
  998    append_forms(X,A,Y).
  999vector_template([],N,[]) :- !.
 1000vector_template([Car|Cdr],N,Y) :-
 1001    template(Car,N,A),
 1002    vector_template(Cdr,N,B),
 1003    cons_forms(A,B,Y).
 1004
 1005append_forms([quote,X],[quote,Y],[quote,Z]) :- !, append(X,Y,Z).
 1006append_forms(X,Y,['#append',X,Y]).
 1007
 1008cons_forms([quote,X],[quote,Y],[quote,[X|Y]]) :- !.
 1009cons_forms(X,Y,['#cons',X,Y]).
 1010
 1011vectorize_form([quote,X],[quote,vec(X)]) :- !.
 1012vectorize_form(X,['#list->vector',X]).
 1013
 1014%   (unquote A)  -->  error
 1015
 1016macro([unquote,X],_) :-
 1017    error("Misplaced 'unquote' special form").
 1018
 1019%   (unquote-splicing A)  -->  error
 1020
 1021macro(['unquote-splicing',X],_) :-
 1022    error("Misplaced 'unquote-splicing' special form").
 1023
 1024%   (let ((a A)...) B C...)  -->  ((lambda (a...) B C...) A...)
 1025% and
 1026%   (let name ((a A)...) B C...)  -->
 1027%   ((letrec ((name (lambda (a...) B C...))) name) A...)
 1028
 1029macro([let,Name,Bindings|Body],
 1030      [[letrec,[[Name,[lambda,Vars|Body]]],Name]|Exprs]) :- symbol(Name), !,
 1031    let_bindings(Bindings,Vars,Exprs).
 1032macro([let,Bindings|Body],[[lambda,Vars|Body]|Exprs]) :-
 1033    let_bindings(Bindings,Vars,Exprs).
 1034
 1035let_bindings([],[],[]).
 1036let_bindings([[V,E]|X],[V|Y],[E|Z]) :- let_bindings(X,Y,Z).
 1037
 1038%   (let* () A B...)  -->  (let () A B...)
 1039% and
 1040%   (let* ((a A)) B C...)  -->  (let ((a A)) B C...)
 1041% and
 1042%   (let* ((a A) (b B) (c C)...) D E...)  -->
 1043%   (let ((a A)) (let* ((b B) (c C)...) D E...)
 1044
 1045macro(['let*',[]|Body],[let,[]|Body]) :- !.
 1046macro(['let*',[[V,E]]|Body],[let,[[V,E]]|Body]) :- !.
 1047macro(['let*',[[V,E]|Tail]|Body],[let,[[V,E]],['let*',Tail|Body]]).
 1048
 1049%   (and A)  -->  A
 1050% and
 1051%   (and A B C...)  -->  (let ((@ A)) (if @ (and B C...) @))
 1052
 1053macro([and,E],E) :- !.
 1054macro([and,E|Tail],[let,[[V,E]],[if,V,[and|Tail],V]]) :- genvar(V).
 1055
 1056%   (or A)  -->  A
 1057% and
 1058%   (or A B C...)  -->  (let ((@ A)) (if @ @ (or B C...)))
 1059
 1060macro([or,E],E) :- !.
 1061macro([or,E|Tail],[let,[[V,E]],[if,V,V,[or|Tail]]]) :- genvar(V).
 1062
 1063%   (cond)  -->  ?
 1064% and
 1065%   (cond (else A B...))  -->  (begin A B...)
 1066% and
 1067%   (cond (A) (B C...)...)  -->  (or A (cond (B C...)...))
 1068% and
 1069%   (cond (A B C...) (D E...)...)  -->  (if A (begin B C...) (cond (D E...)...))
 1070% and
 1071%   (cond (A => B) (C D...)...)  -->  (let ((@ A)) (if @ (B @)
 1072%                                                    (cond (C D...)...)))
 1073
 1074macro([cond],U) :- !, undefined(U).
 1075macro([cond,[else|Tail]],[begin|Tail]) :- !.
 1076macro([cond,[E]|Tail],[or,E,[cond|Tail]]) :- !.
 1077macro([cond,[E,'=>',P]|Tail],[let,[[V,E]],[if,V,[P,V],[cond|Tail]]]) :- !,
 1078    genvar(V).
 1079macro([cond,[E|Tail1]|Tail2],[if,E,[begin|Tail1],[cond|Tail2]]).
 1080
 1081%   (case A ((x...) B C...)...)  -->
 1082%   (let ((@ A)) (cond ((memv @ '(x...)) B C...)...))
 1083
 1084macro([case,Key|Clauses],[let,[[V,Key]],[cond|X]]) :-
 1085    genvar(V),
 1086    cases(V,Clauses,X).
 1087
 1088cases(V,[],[]) :- !.
 1089cases(V,[[else|Tail]],[[else|Tail]]) :- !.
 1090cases(V,[[Set|Tail1]|Tail2],[[['#memv',V,[quote,Set]]|Tail1]|X]) :-
 1091    cases(V,Tail2,X).
 1092
 1093%   (define ...)  -->  error
 1094
 1095macro([define|_],_) :- error("Misplaced 'define' special form").
 1096
 1097%   (delay A)  -->  (make-promise (lambda () A))
 1098
 1099macro([delay,E],['#make-promise',[lambda,[],E]]).
 1100
 1101%   (do ((a A B)...) (C D...) E F...)  -->
 1102%   (let @ ((a A)...) (if C (begin ? D...) (let () E F... (@ a/B...))))
 1103
 1104macro([do,Bindings,[Test|Result]|Body],
 1105      [let,Loop,Inits,[if,Test,[begin,U|Result],[let,[]|New_body]]]) :-
 1106    genvar(Loop),
 1107    undefined(U),
 1108    do_bindings(Bindings,Inits,Steps),
 1109    append(Body,[[Loop|Steps]],New_body).
 1110
 1111do_bindings([],[],[]).
 1112do_bindings([[V,I]|X],[[V,I]|Y],[V|Z]) :- do_bindings(X,Y,Z).
 1113do_bindings([[V,I,S]|X],[[V,I]|Y],[S|Z]) :- do_bindings(X,Y,Z).
 1114
 1115% -----------------------------------------------------------------------------
 1116
 1117% Alpha conversion (renaming of variables) and assignment conversion.
 1118
 1119% This phase renames all of the variables local to the expression (to eliminate
 1120% aliasing problems) and adds 'boxes' (cells) to handle assignment to local
 1121% variables.  For each mutable variable (i.e. a local variable that is assigned
 1122% somewhere in the expression), create a box containing the value of the
 1123% variable.  References to mutable variables is done by dereferencing the box
 1124% it is associated to.  For example, the normal form of this expression:
 1125%
 1126% (lambda (x y) (set! x (- x y)) x)
 1127%
 1128% is transformed into the equivalent of:
 1129%
 1130% (lambda (x y) (let ((x (box x))) (set-box! x (- (get x) y)) (get x)))
 1131
 1132alpha(Expr,C) :- alpha(Expr,C,[]).
 1133
 1134alpha(cst(C),cst(C),Env).
 1135alpha(ref(V),get(T),Env) :- memb(var(V,T,mut),Env), !.
 1136alpha(ref(V),ref(T),Env) :- memb(var(V,T,non_mut),Env), !.
 1137alpha(ref(V),ref(V),Env).
 1138alpha(set(V,E),set(T,C),Env) :- memb(var(V,T,mut),Env), !, alpha(E,C,Env).
 1139alpha(set(V,E),set(V,C),Env) :- alpha(E,C,Env).
 1140alpha(tst(X,Y,Z),tst(A,B,C),Env) :- alpha_list([X,Y,Z],[A,B,C],Env).
 1141alpha(app(L),app(C),Env) :- alpha_list(L,C,Env).
 1142alpha(pro(Params1,Kind,Body1,S),pro(Params2,Kind,Body3,S),Env) :-
 1143    mut_vars(Body1,Mutable),
 1144    rename(Mutable,Params1,Params2,Bindings,Box1,Box2),
 1145    append(Bindings,Env,New_env),
 1146    alpha(Body1,Body2,New_env),
 1147    alpha_pro(Box1,Box2,Body2,Body3).
 1148
 1149alpha_pro([],_,Body,Body) :- !.
 1150alpha_pro(Box1,Box2,Body,app([pro(Box2,none,Body,[])|X])) :- boxes(Box1,X).
 1151
 1152boxes([],[]).
 1153boxes([V|Tail1],[box(V)|Tail2]) :- boxes(Tail1,Tail2).
 1154
 1155rename(Mut,[],[],[],[],[]).
 1156rename(Mut,[V|T1],[X|T2],[var(V,Y,mut)|T3],[X|T4],[Y|T5]) :- memb(V,Mut), !,
 1157    genvar(X), genvar(Y), rename(Mut,T1,T2,T3,T4,T5).
 1158rename(Mut,[V|T1],[X|T2],[var(V,X,non_mut)|T3],T4,T5) :-
 1159    genvar(X), rename(Mut,T1,T2,T3,T4,T5).
 1160
 1161alpha_list([],[],Env).
 1162alpha_list([E|T1],[C|T2],Env) :- alpha(E,C,Env), alpha_list(T1,T2,Env).
 1163
 1164% -----------------------------------------------------------------------------
 1165
 1166% Closure analysis.
 1167
 1168% For every procedure definition (i.e. lambda-expression) in the given
 1169% expression, compute the set of closed variables of the procedure
 1170% and the set of parameters which are referenced in the procedure
 1171% and augment the procedure definition by these sets.  A closed variable
 1172% is a variable that is declared_as in a lambda-expression and used
 1173% in a sub-lambda-expression.  For example, the expression:
 1174%
 1175% (lambda (x y z) (map (lambda (n) (+ y n)) x))
 1176%
 1177% would be augmented to this:
 1178%
 1179% (lambda (x y z) [] [x y] (map (lambda (n) [y] [n] (+ y n)) x))
 1180%
 1181% because,
 1182% 'y' is a closed variable,
 1183% 'map' and '+' are global variables,
 1184% 'x', 'z' and 'n' are non-closed local variables.
 1185
 1186closurize(Expr,C) :- closurize(Expr,C,[]).
 1187
 1188closurize(cst(C),cst(C),Env).
 1189closurize(ref(V),ref(V),Env).
 1190closurize(get(V),get(V),Env).
 1191closurize(box(V),box(V),Env).
 1192closurize(set(V,E),set(V,C),Env) :-
 1193    closurize(E,C,Env).
 1194closurize(tst(X,Y,Z),tst(A,B,C),Env) :-
 1195    closurize_list([X,Y,Z],[A,B,C],Env).
 1196closurize(app(L),app(C),Env) :-
 1197    closurize_list(L,C,Env).
 1198closurize(pro(Params,Kind,Body1,S),pro(Params,Kind,Closed,Used,Body2,S),Env) :-
 1199    free_vars(Body1,Free),
 1200    intersection(Free,Env,Closed),
 1201    make_set(Params,Vars),
 1202    intersection(Free,Vars,Used),
 1203    union(Vars,Env,New_env),
 1204    closurize(Body1,Body2,New_env).
 1205
 1206closurize_list([],[],Env).
 1207closurize_list([E|Tail1],[C|Tail2],Env) :-
 1208    closurize(E,C,Env),
 1209    closurize_list(Tail1,Tail2,Env).
 1210
 1211% -----------------------------------------------------------------------------
 1212
 1213% Code generation for the virtual machine.
 1214
 1215gen_program(Expr,[obj(entry,pro(Main_code,[]))]) :-
 1216    initial_global_env(G1),
 1217    gen(Expr,t,env([],[],G1),env([],[],G2),Main_code,[]).
 1218
 1219gen_procedure(Params,Kind,Closed,Body,Source,pro(Code1,Source),G1,G2) :-
 1220    gen_proc_entry(Params,Kind,Closed,Locals,Code1,Code2),
 1221    gen(Body,t,env(Locals,Closed,G1),env(Locals,Closed,G2),Code2,[]).
 1222
 1223% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
 1224
 1225% Use DCG for code generation.
 1226
 1227gen_proc_entry(Params1,Kind,[],Params2) --> !,
 1228    {length(Params1,Nb_args), reverse(Params1,Params2)},
 1229    [enter(plain,Nb_args,Kind)].
 1230gen_proc_entry(Params1,Kind,Closed,[temp|Params2]) -->
 1231    {length(Params1,Nb_args), reverse(Params1,Params2)},
 1232    [enter(closure,Nb_args,Kind)].
 1233
 1234% gen(Expr,Dest,Env1,Env2)
 1235%
 1236% Generate intermediate code for expression Expr given the run-time environment
 1237% Env1.  Env2 is the environment after having executed Expr.  Dest specifies
 1238% where to put the result: 'd' means discard the result, 't' means the
 1239% expression is in tail position, 'push' means push the result on the run-time
 1240% stack otherwise Dest is a virtual register number.
 1241
 1242gen(cst(C),d,E1,E1) --> !, [].
 1243gen(cst(C),t,E1,E2) --> !, gen(cst(C),1,E1,E2), gen_return(E2).
 1244gen(cst(C),D,E1,E2) --> !, {fix(D,E1,E2)}, [cst(C,D)].
 1245
 1246gen(ref(V),d,E1,E1) --> !, [].
 1247gen(ref(V),t,E1,E2) --> !, gen(ref(V),1,E1,E2), gen_return(E2).
 1248gen(ref(V),D,E1,E2) --> {loc(V,E1,X), fix(D,E1,E2)}, !, [ref_loc(X,D)].
 1249gen(ref(V),D,E1,E2) --> {clo(V,E1,X,Y), fix(D,E1,E2)}, !, [ref_clo(X,Y,D)].
 1250gen(ref(V),D,E1,E3) --> {glo(V,E1,E2,X), fix(D,E2,E3)}, !, [ref_glo(X,D)].
 1251
 1252gen(get(V),d,E1,E1) --> !, [].
 1253gen(get(V),t,E1,E2) --> !, gen(get(V),1,E1,E2), gen_return(E2).
 1254gen(get(V),D,E1,E2) --> {loc(V,E1,X), fix(D,E1,E2)}, !, [get_loc(X,D)].
 1255gen(get(V),D,E1,E2) --> {clo(V,E1,X,Y), fix(D,E1,E2)}, !, [get_clo(X,Y,D)].
 1256
 1257gen(box(V),d,E1,E1) --> !, [].
 1258gen(box(V),t,E1,E2) --> !, gen(box(V),1,E1,E2), gen_return(E2).
 1259gen(box(V),D,E1,E2) --> {loc(V,E1,X), fix(D,E1,E2)}, !, [box_loc(X,D)].
 1260gen(box(V),D,E1,E2) --> {clo(V,E1,X,Y), fix(D,E1,E2)}, !, [box_clo(X,Y,D)].
 1261
 1262gen(set(V,E),d,E1,E2) --> !, gen(set(V,E),1,E1,E2).
 1263gen(set(V,E),t,E1,E2) --> !, gen(set(V,E),1,E1,E2), gen_return(E2).
 1264gen(set(V,E),D,E1,E3) --> !, gen(E,D,E1,E2), gen_set(V,D,E2,E3).
 1265
 1266gen_set(V,S,E1,E1) --> {loc(V,E1,X)}, !, [set_loc(X,S)].
 1267gen_set(V,S,E1,E1) --> {clo(V,E1,X,Y)}, !, [set_clo(X,Y,S)].
 1268gen_set(V,S,E1,E2) --> {glo(V,E1,E2,X)}, !, [set_glo(X,S)].
 1269
 1270gen(tst(X,Y,Z),t,E1,E5) --> !,
 1271    {genlabel(Label1)},
 1272    gen(X,1,E1,E2),
 1273    [branch_if_false(1,Label1)],
 1274    gen(Y,t,E2,E3),
 1275    [label(Label1)],
 1276    {join_env(E2,E3,E4)},
 1277    gen(Z,t,E4,E5).
 1278gen(tst(X,Y,Z),D,E1,E5) -->
 1279    {genlabel(Label1), genlabel(Label2)},
 1280    gen(X,1,E1,E2),
 1281    [branch_if_false(1,Label1)],
 1282    gen(Y,D,E2,E3),
 1283    [branch_always(Label2)],
 1284    [label(Label1)],
 1285    {join_env(E2,E3,E4)},
 1286    gen(Z,D,E4,E5),
 1287    [label(Label2)].
 1288
 1289gen(app([pro(P,none,C,U,B,_)|A]),D,E1,E2) --> !, gen_app_pro(P,C,U,B,A,D,E1,E2).
 1290gen(app(L),d,E1,E2) --> !, gen(app(L),1,E1,E2).
 1291gen(app([ref(V)|Args]),t,E1,E2) -->
 1292    {length(Args,Nb_args), option(int(V)), integrable(V,Nb_args)}, !,
 1293    gen_app_args(Args,1,E1,E2),
 1294    [open_code(V,Nb_args)],
 1295    gen_return(E2).
 1296gen(app([ref(V)|Args]),t,E1,E3) --> {glo(V,E1,E2,X)}, !,
 1297    gen_app_args(Args,1,E2,E3),
 1298    {length(Args,Nb_args), depth(E3,Depth)},
 1299    [dealloc(Depth)],
 1300    [jump_glo(X,Nb_args)].
 1301gen(app([Proc|Args]),t,E1,E2) --> !,
 1302    gen_app_args([Proc|Args],0,E1,E2),
 1303    {depth(E2,Depth), length(Args,Nb_args)},
 1304    [dealloc(Depth)],
 1305    [jump(0,Nb_args)].
 1306gen(app([ref(V)|Args]),D,E1,E4) -->
 1307    {length(Args,Nb_args), option(int(V)), integrable(V,Nb_args)}, !,
 1308    gen_app_args(Args,1,E1,E2),
 1309    [open_code(V,Nb_args)],
 1310    [move(1,D)],
 1311    {join_env(E1,E2,E3), fix(D,E3,E4)}.
 1312gen(app([ref(V)|Args]),D,E1,E5) --> {glo(V,E1,E2,X)}, !,
 1313    gen_app_args(Args,1,E2,E3),
 1314    {genlabel(Label), length(Args,Nb_args)},
 1315    [push_continuation(Label)],
 1316    [jump_glo(X,Nb_args)],
 1317    [sub_procedure(Label)],
 1318    [move(1,D)],
 1319    {join_env(E1,E3,E4), fix(D,E4,E5)}.
 1320gen(app([Proc|Args]),D,E1,E4) --> !,
 1321    gen_app_args([Proc|Args],0,E1,E2),
 1322    {genlabel(Label), length(Args,Nb_args)},
 1323    [push_continuation(Label)],
 1324    [jump(0,Nb_args)],
 1325    [sub_procedure(Label)],
 1326    [move(1,D)],
 1327    {join_env(E1,E2,E3), fix(D,E3,E4)}.
 1328
 1329gen_app_args(L,N,E1,E3) -->
 1330    {split_args(L,N,Non_trivial,Trivial)},
 1331    gen_non_trivial_args(Non_trivial,E1,E2),
 1332    gen_trivial_args(Trivial,E2,E3).
 1333
 1334gen_non_trivial_args([],E1,E1) --> !, [].
 1335gen_non_trivial_args([arg(Dest,Arg)],E1,E2) --> !,
 1336    gen(Arg,1,E1,E2),
 1337    [move(1,Dest)].
 1338gen_non_trivial_args([arg(Dest,Arg)|Tail],E1,E4) --> !,
 1339    gen(Arg,push,E1,E2),
 1340    gen_non_trivial_args(Tail,E2,E3),
 1341    [move(pop,Dest)],
 1342    {fix(pop,E3,E4)}.
 1343
 1344gen_trivial_args([],E1,E1) --> [].
 1345gen_trivial_args([arg(Dest,Arg)|Tail],E1,E3) -->
 1346    gen(Arg,Dest,E1,E2),
 1347    gen_trivial_args(Tail,E2,E3).
 1348
 1349gen_app_pro(P,C,U,B,A,D,E1,E5) -->
 1350    gen_alloc_args(P,U,A,N,E1,E2),
 1351    gen_body(B,D,N,E2,E3),
 1352    {join_env(E1,E3,E4), fix(D,E4,E5)}.
 1353
 1354gen_alloc_args([],U,[],0,E1,E1) --> !, [].
 1355gen_alloc_args([V|Tail1],U,[A|Tail2],N,E1,E4) --> {memb(V,U)}, !,
 1356    gen(A,push,E1,E2),
 1357    {rename_temp(V,E2,E3)},
 1358    gen_alloc_args(Tail1,U,Tail2,M,E3,E4),
 1359    {N is M+1}.
 1360gen_alloc_args([V|Tail1],U,[A|Tail2],N,E1,E3) --> !,
 1361    gen(A,d,E1,E2),
 1362    gen_alloc_args(Tail1,U,Tail2,N,E2,E3).
 1363
 1364gen_body(B,D,0,E1,E2) --> !, gen(B,D,E1,E2).
 1365gen_body(B,t,N,E1,E2) --> !, gen(B,t,E1,E2).
 1366gen_body(B,push,N,E1,E2) --> !,
 1367    gen(B,1,E1,E2),
 1368    [dealloc(N)],
 1369    [move(1,push)].
 1370gen_body(B,D,N,E1,E2) --> !,
 1371    gen(B,D,E1,E2),
 1372    [dealloc(N)].
 1373
 1374gen(pro(Params,Kind,Closed,Used,Body,Source),d,E1,E1) --> !, [].
 1375gen(pro(Params,Kind,Closed,Used,Body,Source),t,E1,E2) --> !,
 1376    gen(pro(Params,Kind,Closed,Used,Body,Source),1,E1,E2),
 1377    gen_return(E2).
 1378gen(pro(Params,Kind,[],Used,Body,Source),D,env(L,C,G1),E) --> !,
 1379    {gen_procedure(Params,Kind,[],Body,Source,Proc,G1,G2),
 1380     fix(D,env(L,C,G2),E)},
 1381    [cst(Proc,D)].
 1382gen(pro(Params,Kind,Closed,Used,Body,Source),D,env(L,C,G1),E) --> !,
 1383    {gen_procedure(Params,Kind,Closed,Body,Source,Proc,G1,G2),
 1384     fix(D,env(L,C,G2),E), length(Closed,Nb_closed)},
 1385    [make_closure(Proc,Nb_closed,D)],
 1386    gen_close_var(Closed,E).
 1387
 1388gen_close_var([],Env) --> [].
 1389gen_close_var([V|Tail],Env) --> {loc(V,Env,X)}, !,
 1390    [close_loc(X)],
 1391    gen_close_var(Tail,Env).
 1392gen_close_var([V|Tail],Env) --> {clo(V,Env,X,Y)}, !,
 1393    [close_clo(X,Y)],
 1394    gen_close_var(Tail,Env).
 1395
 1396gen_return(Env) -->
 1397    {depth(Env,Depth)},
 1398    [return(Depth)].
 1399
 1400% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
 1401
 1402% Utilities for code generation.
 1403
 1404join_env(env(L1,C,G1),env(L2,C,G2),env(L1,C,G2)).
 1405
 1406depth(env(L,C,G),Depth) :- length(L,Depth).
 1407
 1408loc(V,env(L,C,G),Y) :- length(L,Depth), position(V,L,X), Y is Depth-X-1.
 1409
 1410clo(V,env(L,C,G),Depth,X) :- length(L,Depth), position(V,C,X).
 1411
 1412glo(V,env(L,C,G),env(L,C,G),X) :-
 1413    \+ memb(V,L),
 1414    \+ memb(V,C),
 1415    position(V,G,X), !.
 1416glo(V,env(L,C,G1),env(L,C,G2),X) :-
 1417    \+ memb(V,L),
 1418    \+ memb(V,C),
 1419    append(G1,[V],G2),
 1420    position(V,G2,X).
 1421
 1422position(X,L,P) :- position(X,L,P,0).
 1423position(X,[X|Tail],N,N) :- !.
 1424position(X,[_|Tail],P,N) :- M is N+1, position(X,Tail,P,M).
 1425
 1426fix(push,env(L1,C,G),env(L2,C,G)) :- !, append(L1,[temp],L2).
 1427fix(pop,env(L1,C,G),env(L2,C,G)) :- !, append(L2,[_],L1).
 1428fix(Dest,Env,Env).
 1429
 1430rename_temp(V,env(L1,C,G),env(L3,C,G)) :-
 1431    append(L2,[temp],L1),
 1432    append(L2,[V],L3).
 1433
 1434split_args([],N,[],[]).
 1435split_args([Arg|Tail1],N,Tail2,[arg(N,Arg)|Tail3]) :- trivial(Arg), !,
 1436    M is N+1,
 1437    split_args(Tail1,M,Tail2,Tail3).
 1438split_args([Arg|Tail1],N,Tail2,Tail3) :-
 1439    M is N+1,
 1440    split_args(Tail1,M,Tail4,Tail3),
 1441    append(Tail4,[arg(N,Arg)],Tail2).
 1442
 1443trivial(cst(_)).
 1444trivial(ref(_)).
 1445trivial(get(_)).
 1446trivial(box(_)).
 1447% -----------------------------------------------------------------------------
 1448
 1449% Set manipulation.
 1450
 1451memb(X,[X|T]) :- !.
 1452memb(X,[Y|T]) :- memb(X,T).
 1453
 1454remove(E,[],[]) :- !.
 1455remove(E,[E|T],T) :- !.
 1456remove(E,[X|T],[X|S]) :- remove(E,T,S).
 1457
 1458make_set([],[]).
 1459make_set([X|Y],Z) :- make_set(Y,S), union([X],S,Z).
 1460
 1461union([],S,S) :- !.
 1462union(S,[],S) :- !.
 1463union([E|T1],[E|T2],[E|T3]) :- !, union(T1,T2,T3).
 1464union([E1|T1],[E2|T2],[E1|T3]) :- E1 @< E2, !, union(T1,[E2|T2],T3).
 1465union([E1|T1],[E2|T2],[E2|T3]) :- E1 @> E2, !, union([E1|T1],T2,T3).
 1466
 1467intersection([],S,[]) :- !.
 1468intersection(S,[],[]) :- !.
 1469intersection([E|T1],[E|T2],[E|T3]) :- !, intersection(T1,T2,T3).
 1470intersection([E1|T1],[E2|T2],T3) :- E1 @< E2, !, intersection(T1,[E2|T2],T3).
 1471intersection([E1|T1],[E2|T2],T3) :- E1 @> E2, !, intersection([E1|T1],T2,T3).
 1472
 1473difference([],S,[]) :- !.
 1474difference(S,[],S) :- !.
 1475difference([E|T1],[E|T2],T3) :- !, difference(T1,T2,T3).
 1476difference([E1|T1],[E2|T2],[E1|T3]) :- E1 @< E2, !, difference(T1,[E2|T2],T3).
 1477difference([E1|T1],[E2|T2],T3) :- E1 @> E2, !, difference([E1|T1],T2,T3).
 1478
 1479% -----------------------------------------------------------------------------
 1480
 1481% Graph manipulation.
 1482
 1483% A graph is a set of nodes of the form: node(Name,Set_of_neighbors,Info)
 1484
 1485% Transitive closure of a graph.
 1486
 1487transitive_closure(G1,G2) :-
 1488    add_neighbors(G1,X),
 1489    transitive_closure(G1,X,G2), !.
 1490transitive_closure(X,X,X).
 1491transitive_closure(_,G1,G2) :- transitive_closure(G1,G2).
 1492
 1493add_neighbors(G1,G2) :- add_neighbors(G1,G1,G2).
 1494add_neighbors(G,[],[]).
 1495add_neighbors(G,[node(X,N1,Info)|Tail1],[node(X,N2,Info)|Tail2]) :-
 1496    union_of_neighbors(G,N1,N1,N2),
 1497    add_neighbors(G,Tail1,Tail2).
 1498
 1499union_of_neighbors(G,[],N,N).
 1500union_of_neighbors(G,[X|Tail],N1,N3) :-
 1501    memb(node(X,N,_),G),
 1502    union(N,N1,N2),
 1503    union_of_neighbors(G,Tail,N2,N3).
 1504
 1505% Topological sorting (modified to handle cycles).
 1506
 1507topological_sort(G1,L) :- transitive_closure(G1,G2), topo_sort(G2,L).
 1508
 1509topo_sort([],[]).
 1510topo_sort(G1,[X|Tail]) :- memb(node(X,[],_),G1), !,
 1511    remove_node(X,G1,G2),
 1512    topo_sort(G2,Tail).
 1513topo_sort(G1,[N|Tail]) :-
 1514    topo_sort_find_cycle(G1,G1,N),
 1515    remove_nodes(N,G1,G2),
 1516    topo_sort(G2,Tail).
 1517
 1518topo_sort_find_cycle(G,[node(X,N,_)|_],N) :- memb(X,N), cyclic(G,N,N), !.
 1519topo_sort_find_cycle(G,[_|Tail],N) :- topo_sort_find_cycle(G,Tail,N).
 1520
 1521cyclic(G,N,[]).
 1522cyclic(G,N,[X|Tail]) :- memb(node(X,N,_),G), cyclic(G,N,Tail).
 1523
 1524remove_nodes([],G,G).
 1525remove_nodes([X|Tail],G1,G3) :- remove_node(X,G1,G2), remove_nodes(Tail,G2,G3).
 1526
 1527remove_node(X,[],[]) :- !.
 1528remove_node(X,[node(X,_,_)|Tail1],Tail2) :- !, remove_node(X,Tail1,Tail2).
 1529remove_node(X,[node(Y,N1,Info)|Tail1],[node(Y,N2,Info)|Tail2]) :-
 1530    remove(X,N1,N2),
 1531    remove_node(X,Tail1,Tail2)