AZ-Prolog ユーザーズマニュアル

#### サンプルコード

### LISP

説明
plorogで書かれたLISPインタープリターです。
使用例
    % Usage
    | ?-[-'azlisp.pl'].
    yes

    | ?-top_level.
    Welcom to Lisp World ver 1.1
    lisp> (de append (x y)(cond ((eq x nil)y)(t(cons(car x)(append (cdr x) y)))))
    append
    lisp> (append '(1 2 3 4) '(5 6 7))
    (1 2 3 4 5 6 7)
    lisp> (bye)
    t
    Exit From Lisp
    yes
プログラム
    %%%%%%%%%%%%%%%%%
    %%% TOP LEVEL %%%
    %%%%%%%%%%%%%%%%%
    top_level :- lisp(user).

    lisp(See) :-
    	see(See),
    	prompt(P,P),write('Welcom to Lisp World ver 1.1'),nl,
    	repeat,
    	   prompt(_,'lisp> '),errorset(lispRead(X),succ),
    	   errorset(lispEval(X,V),succ),
    	   lispPrint(V),
    	   X == [bye],
    	   !,
    	write('Exit From Lisp'),nl,prompt(_,P).

    %%%%%%%%%%%%%%
    %%% Reader %%%
    %%%%%%%%%%%%%%
    whitespace(C) :- C<0'21.
    terminating_macro(0'27).	/* ' */
    terminating_macro(0'28).	/* ( */
    terminating_macro(0'29).	/* ) */

    lispRead(X) :- get0(C),chprompt,lispRead(X,C,CC),!,term_check(CC).
    lispRead(_) :- lisp_err('syntax error').
    %%%%
    	term_check(26) :- !,seen,fail.
        term_check(31) :- !.
        term_check(C) :- whitespace(C),!,get0(CC),term_check(CC).
        term_check(_) :- skip(31),lisp_err('extra token after S-expression').
        tskip(31) :- !.
        tskip(_) :- skip(31).
        tmatch(T,T,_) :- !.
        tmatch(_,_,C) :- tskip(C),fail.
        chprompt :- prompt('lisp> ','>>>   '),!.
        chprompt.
    %%%%
    lispRead(_,26,26) :- !.
    lispRead(X,C,CC) :- tokenRead(T,C,CCC),dispatch(X,T,CCC,CC).
      %%
    tokenRead(T,C,CC) :- whitespace(C),!,get0(CCC),tokenRead(T,CCC,CC).
    tokenRead([C],C,CC) :- terminating_macro(C),!,get0(CC).
    tokenRead([C|T],C,CC) :- get0(CCC),tokenRead1(T,CCC,CC).
      %%
    tokenRead1([],C,C) :- whitespace(C),!.
    tokenRead1([],C,C) :- terminating_macro(C),!.
    tokenRead1([C|T],C,CC) :- get0(CCC),tokenRead1(T,CCC,CC).
      %%
    dispatch(X,"(",C,CC) :- !,tokenRead(T,C,CCC),dispatch1(X,T,CCC,CC).
    dispatch(_,")",C,_) :- tskip(C),!,fail.
    dispatch(_,".",C,_) :- tskip(C),!,fail.
    dispatch([quote,X],"'",C,CC) :- !,lispRead(X,C,CC).
    dispatch(S,T,C,C) :- name(SS,T),cnvnil(SS,S).
        cnvnil(nil,[]) :- !.
        cnvnil(S,S).
      %%
    dispatch1([],")",C,C) :- !.
    dispatch1(Cdr,".",C,CC) :- !,
    	tokenRead(T,C,CCC),dispatch(Cdr,T,CCC,CCCC),
    	tokenRead(TT,CCCC,CC),tmatch(")",TT,CC).
    dispatch1([Car|Cdr],T,C,CC) :-
    	dispatch(Car,T,C,CCC),tokenRead(TT,CCC,CCCC),dispatch1(Cdr,TT,CCCC,CC).

    %%%%%%%%%%%%%%%%%
    %%%  Printer  %%%
    %%%%%%%%%%%%%%%%%

    lispPrint(X) :- lispPrint1(X),nl.

    %%%%%%
    lispPrint1([]) :- !,write(nil).
    lispPrint1([Car|Cdr]) :- !,write('('),lispPrint2([Car|Cdr]).
    lispPrint1(X) :- write(X).

    %%%%%%
    lispPrint2([Car]):- !,lispPrint1(Car),write(')').
    lispPrint2([Car,Cadr|Cddr]):-!,lispPrint1(Car),tab(1),lispPrint2([Cadr|Cddr]).
    lispPrint2([Car|Cdr]):-lispPrint1(Car),write(' . '),lispPrint1(Cdr),write(')').

    %%%%%%%%%%%%%%%%%
    %%% Evaluater %%%
    %%%%%%%%%%%%%%%%%

      %% EVAL from Top Level %%
    lispEval(L,V) :- lispEval(L,V,[]).

      %% EVAL Body %%
    lispEval(A,_,_) :- var(A),!,lisp_err('not a S-expr.'(A)).

    lispEval(N,N,_) :- integer(N),!.		/* Integer -> Integer */

    lispEval(A,V,E) :- atom(A),!,getvar(A,E,V).	/* Atom -> Binded Valuse */

    lispEval([Sform|Args],V,E) :-			/* quote, progn, cond, de */
    	specialForm_call(Sform,Args,V,E),!.

    lispEval([Func|Args],Value,E) :- !,		/* Car, Cdr, Cons, Eq, Atom */
    	evlis(Args,Args2,E),
    	lispEval2(Func,Args2,Value,E).

    lispEval(A,_,_) :- lisp_err('not a S-expr.'(A)).

    lispEval2(Func,Args2,Value,E) :-
    	subrFunction_call(Func,Args2,Value),!.

    lispEval2(Func,Args2,Value,E) :-
    	call(function(Func,closure(Env,Lambda,Body))),!,
    	bind(Lambda,Args2,Env,NewEnv),
    	prognBody(Body,Value,NewEnv).

    lispEval2([lambda,Lambda|Body],Args2,Value,Env) :- !,	/* Lambda Notation */
    	bind(Lambda,Args2,Env,NewEnv),
    	prognBody(Body,Value,NewEnv).

    lispEval2(Func,_,_,_) :- lisp_err('illegal function call'(Func)).

    bind([],[],E,E) :- !.
    bind([V|L1],[A|L2],E,[[V|A]|EE]) :- bind(L1,L2,E,EE).

      %%% Evaluate earch Argumnet %%%
    evlis(A,AL,Env) :- evlis0(A,AL,Env),!.
    evlis(A,_,_) :- lisp_err('dot list argument'(A)).

    evlis0([],[],Env) :-!.
    evlis0([P|L1],[V|L2],Env) :- lispEval(P,V,Env),!,evlis0(L1,L2,Env).

      %%% Get Value From Env  %%%
    getvar(Var,[],Val) :- gval(Var,Val),!.
    getvar(Var,[[Var|Val]|_],Val) :-!.
    getvar(Var,[_|E],Val) :- getvar(Var,E,Val).

    gval(t,t) :- !.
    gval([],[]) :- !.
    gval(Var,_) :- lisp_err('unbound variable'(Var)).

    %%%%%%%%%%%%%%%%%%%%
    %%% specialForm  %%%
    %%%%%%%%%%%%%%%%%%%%

    specialForm(quote).
    specialForm(progn).
    specialForm(cond).
    specialForm(de).

      %% Quote %%
    specialForm_call(quote,[Sexp],Sexp,_) :- !.
    specialForm_call(quote,_,_,_) :- lisp_err('quote syntax error').
      %% Progn %%%
    specialForm_call(progn,Body,V,E) :- !,prognBody(Body,V,E).
      %% Cond  %%
    specialForm_call(cond,Body,V,E) :- !,condBody(Body,V,E).
      %%   De  %%
    specialForm_call(de,[Name,Lambda|Body],Name,E) :- !,
        asserta(function(Name,closure(E,Lambda,Body))).
    specialForm_call(de,_,_,_) :- lisp_err('de syntax error').

      %% Progn Body %%
    prognBody([],[],_) :- !.
    prognBody([F],V,E) :- !,lispEval(F,V,E).
    prognBody([F|L],V,E) :- !,lispEval(F,_,E),prognBody(L,V,E).
    prognBody(_,_,_) :- lisp_err('progn syntax error').

      %% Cond Body %%
    condBody([],[],_) :- !.
    condBody([Clause|_],V,E) :- commit(Clause,V,E),!.
    condBody([_|Rest],V,E) :- !,condBody(Rest,V,E).
    condBody(_,_,_) :- lisp_err('cond syntax error').

    commit([U],V,E) :- lispEval(U,V,E),!,V/==[].
    commit([H|B],V,E) :- lispEval(H,C,E),!,C/==[],prognBody(B,V,E).
    commit(_,_,_) :- lisp_err('cond syntax error').

    %%%%%%%%%%%%%%%%%%
    %% subrFunction %%
    %%%%%%%%%%%%%%%%%%

    subrFunction(car).
    subrFunction(cdr).
    subrFunction(cons).
    subrFunction(atom).
    subrFunction(eq).

    subrFunction(print).
    subrFunction('+').
    subrFunction('-').
    subrFunction('>').
    subrFunction('<').
    subrFunction(read).
    subrFunction(terpri).
    subrFunction(help).
    subrFunction(bye).
    subrFunction(getdef).
    subrFunction(load).
    subrFunction(save).

    %%% Car Cdr Cons Atom Eq %%%
    subrFunction_call(car,[[Car|_]],Car):-!.
    subrFunction_call(cdr,[[_|Cdr]],Cdr):-!.
    subrFunction_call(cons,[Car,Cdr],[Car|Cdr]):-!.
    subrFunction_call(atom,[[_|_]],[]):-!.
    subrFunction_call(atom,[_],t):-!.
    subrFunction_call(eq,[A,B],t):- A==B,!.
    subrFunction_call(eq,[_,_],[]):-!.
    subrFunction_call('<',[A,B],t):- A',[A,B],t):- A>B,!.
    subrFunction_call('>',[_,_],[]):-!.

    subrFunction_call(print,[Any],Any):-!,lispPrint1(Any).
    subrFunction_call('+',[A,B],C) :-!, C is A + B.
    subrFunction_call('-',[A,B],C) :-!, C is A - B.
    subrFunction_call(read,[],L):-
    		prompt(_,'|:'),errorset(lispRead(L),succ),!.
    subrFunction_call(read,[],[]):-!.
    subrFunction_call(help,[],t) :- subrFunction(A),write(A),tab(1),fail.
    subrFunction_call(help,[],t) :- nl,specialForm(A),write(A),tab(1),fail.
    subrFunction_call(help,[],t) :- nl,call(function(A,closure(_,B,_))),
    				errorset(length(B,L),succ),write(A/L),
    				tab(1),fail.
    subrFunction_call(help,[],t) :-!, nl.
    subrFunction_call(getdef,[F],[lambda,B,C]) :-call(function(F,closure(_,B,C))),!.
    subrFunction_call(getdef,[_],[]):-!.
    subrFunction_call(bye,[],t):-!.
    subrFunction_call(terpri,[],t) :-!, nl.
    subrFunction_call(save,[F],t) :-!, tell(F),listing(function),told.
    subrFunction_call(load,[F],t) :- consult(F).

    %%%%%%%%%%
    %%%%%%%%%%
    /*
    lispEval([Macro|Args],V,E) :-
    	macroFunction(Macro,ExpFunc),
    	!,
    	apply(ExpFunc,[[Macro|Args],E],ExpandedForm),
    	lispEval(ExpandedForm,V,E).

     %%%  USER DEFINED FUNCTION    %%%
    function(ap,closure([],[x,y],[[cond,[[eq,x,nil],y],[t,[cons,[car,x],[ap,[cdr,x],y]]]]]),_).

    */
    %%%%%%%%
    lisp_err(X) :- write(X),nl,abort.
    %%%%%%%%

▲