ExLispSrc2 - デカルト言語 - 並列ロジック プログラミング言語 Wiki - デカルト言語 - 並列ロジック プログラミング言語

--
←　前のページに戻る

拡張されたデカルト言語で実装したLispインタプリターのソース

拡張版のDescartes Lisp/λインタプリターのソースを以下に示します。

/* Descartes Lisp/λ (c) 2010 H.Niwa  */

/*
 * This program 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 2, or (at your option)
 * any later version.
 */

? <include list>;

// s式の構文解析
<s_exp (quote #r)>
	 "'"
	<s_exp #r>
	;
<s_exp #r>
	"λ"
	<A #arg1>
	<A #arg2>
	<A #arg3>
	[ "." ]
	<s_exp #sexp> 
	(
	  <s_exp #parm1>
	  <s_exp #parm2>
	  <s_exp #parm3>
	  <is #r (("λ" (#arg1 #arg2 #arg3) #sexp) #parm1 #parm2 #parm3)>
	 |
	  <is #r ("λ" (#arg1 #arg2 #arg3) #sexp)>
	)
	//<print #r>
	;
<s_exp #r>
	"λ"
	<A #arg1>
	<A #arg2>
	[ "." ]
	<s_exp #sexp> 
	(
	  <s_exp #parm1>
	  <s_exp #parm2>
	  <is #r (("λ" (#arg1 #arg2) #sexp) #parm1 #parm2)>
	 |
	  <is #r ("λ" (#arg1 #arg2) #sexp)>
	)
	//<print #r>
	;
<s_exp #r>
	"λ"
	<A #arg1>
	[ "." ]
	<s_exp #sexp> 
	(
	  <s_exp #parm1>
	  <is #r (("λ" (#arg1) #sexp) #parm1)>
	 |
	  <is #r ("λ" (#arg1) #sexp)>
	)
	//<print #r>
	;

<s_exp #r>
	 "("
	    <x <print ::sys <line _> "syntax error : lack of ')'">>
	    {#r1 
		<s_exp _>
	    }
	    (
		 ":" <s_exp #r2> ::list<append #r #r1 #r2>
	    |
	         <is #r #r1>
	    )
	 ")"
	|
	 <s_atom #r>
	;


<s_atom #r>
	(
	 <STRINGS #r>
	|
	 <SNUM #r>
	|
	 <WORD #r>
	|
	 (
	  "+"
	 |
	  "*"
	 |
	  "/"
	 |
	  "="
	 |
	  "<>"
	 |
	  ">="
	 |
	  ">"
	 |
	  "<="
	 |
	  "<"
	 )
	 <GETTOKEN #r>
	)
	;


// 変数の処理
<var ((T : T) (NIL : NIL))>;

<getval #r #x ((#l1 :#l2) : #var)>
	<is #x #l1>
	<is #r #l2>
	|
	<getval #r #x #var>
	;
<getval #x #x ()>
	;

<setval #var () _ #var>
	;
<setval #var3 (#x1 : #x2) (#val1 : #val2) #var>
	<is #var1 ((#x1:#val1):#var)>
	<setval #var3 #x2 #val2 #var1>
	;
<setval ((#x : #val) : #var) #x #val #var>
	;

<setval_let #var () #var>
	;
<setval_let ((#x : #val) : #var2) ((#x #val) : #vals) #var>
	<setval_let #var2 #vals #var>
	;

// 組み込み関数
<built_in #l (quit) #var>
	<exit>
	;
<built_in #l (quote #l) #var>
	;
<built_in #r (car #l) #var>
	<l_eval #l1 #l #var> <car #r #l1>
	;
<built_in #r (cdr #l) #var>
	<l_eval #l1 #l #var> <cdr #r #l1>
	;
<built_in #r (cons #l1 #l2) #var>
	<l_eval #p1 #l1 #var> 
	<l_eval #p2 #l2 #var> 
	<cons #r #p1 #p2>
	;
<built_in #r (atom #l) #var>
	<l_eval #l1 #l #var> <atom #r #l1>
	;
<built_in #r (equal #l1 #l2) #var>
	<l_eval #ll1 #l1 #var> 
	<l_eval #ll2 #l2 #var> 
	<equal #r #ll1 #ll2>
	;
<built_in #r (print :#l) #var>
	<l_evpr #r #l #var>
	;
<built_in #r (list :#l) #var>
	<l_list #r #l #var>
	;
<built_in #r ("+" #l1 #l2) #var>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  <#r = #ll1 + #ll2>
	| <is #r ("+" #ll1 #ll2)>)
	;
<built_in #r ("-" #l1 #l2) #var>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  <#r = #ll1 - #ll2>
	| <is #r ("-" #ll1 #ll2)>)
	;
<built_in #r ("*" #l1 #l2) #var>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  <#r = #ll1 * #ll2>
	| <is #r ("*" #ll1 #ll2)>)
	  <trace "*" ("*" #l1 #l2) ("*" #ll1 #ll2)>
	;
<built_in #r ("/" #l1 #l2) #var>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  <noteq #ll2 0>
	  <#r = #ll1 / #ll2>
	| <noteq #ll2 0> <is #r ("/" #ll1 #ll2)>)
	;
<built_in #r ("=" #l1 #l2) #var>
	<x <print "error: = ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 == #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r ("=" #ll1 #ll2)>)
	;
<built_in #r ("<>" #l1 #l2) #var>
	<x <print "error: <> ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 <> #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r ("<>" #ll1 #ll2)>)
	;
<built_in #r (">" #l1 #l2) #var>
	<x <print "error: > ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 > #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r (">" #ll1 #ll2)>)
	;
<built_in #r (">=" #l1 #l2) #var>
	<x <print "error: >= ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 >= #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r (">=" #ll1 #ll2)>)
	;
<built_in #r ("<" #l1 #l2) #var>
	<x <print "error: < ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 < #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r ("<" #ll1 #ll2)>)
	;
<built_in #r ("<=" #l1 #l2) #var>
	<x <print "error: <= ">>
	<l_eval #ll1 #l1 #var>
	<l_eval #ll2 #l2 #var>
	( ::sys <isInteger #ll1> ::sys <isInteger #ll2>
	  (
	      <compare #ll1 <= #ll2> <is #r T>
	    | <is #r NIL>
	  )
	| <is #r ("<=" #ll1 #ll2)>)
	;
<built_in #r (define (#f :#x) #val) _>
	<var #var>
	<setval #var2 #f (λ #x #val) #var>
	<setVar var #var2>
	<is #r (λ #x #val)>
	;
<built_in #r (define #x #val) #var>
	<setval #var2 #x #val #var>
	<setVar var #var2>
	<is #r #val>
	;
<built_in #r (let #v :#bodys) #var>
	<x <print "error : " (let #v :#bodys) >>
	<setval_let #var2 #v #var>
	<l_evlis #r #bodys #var2>
	;
<built_in #r (cond : #l) #var>
	<cond #r #l #var>
	<trace "cond " (cond : #l) #r>
	;
<built_in #r (load  #l) #var>
	<loadlist #r #l #var>
	;
<built_in on (trace  on) #var>
	<setVar tracemode on>
	;
<built_in off (trace  off) #var>
	<setVar tracemode off>
	;


// 組み込み関数の処理
<car #r #l>
	::sys <isList #l>
	::sys <car #r #l>
	|
	<is #r (car #l)>
	;
<cdr #r #l>
	::sys <isList #l>
	::sys <cdr #r #l>
	|
	<is #r (cdr #l)>
	;
<cons (#l1 :#l2) #l1 #l2>
	;
<atom #r #n>
	::sys <isAtom #n> <is #r T>
	|
	<is #r NIL>
	;
<equal #r #l1 #l2>
	<is #l1 #l2> <is #r T>
	|
	<is #r NIL>
	;

<cond NIL ()  #var>
	;
<cond #r ((#l1 : (#l2)) :#l3) #var>
	<l_eval #r1 #l1 #var>
	(
	  <is #r1 T>
	  <l_eval #r #l2 #var>
	 |
	  <is #r1 NIL>
	  <cond #r #l3 #var>
	 |
	  <is #r (cond : ((#l1 : (#l2)) :#l3))>
	)	
	;

<listp #l>
	::sys <isUnknown ::sys <isAtom #l>>
	;
	
<loadlist #r #filename _>
	::sys <openr #filename 
		{
		    ";" <SKIPCR>
		  |
		    <var #var>
		    <s_exp #list>
		    <print "> " #list>
		    <l_eval #r #list #var>
		    <print #r><print>
		    {
			")" 
			<print ::sys <line _> "syntax error : extra ')'">
		    }
		}
	>
	<is #r T>
	;

<tracemode off>;

<trace #id #func #val>
	<tracemode off>
	|
	<print #id "trace : " #func>
	<print " -> " #val><print>
	;

// evalの処理
<l_eval #r #p #var>
	  ::sys <isInteger #p> 
	  <is #r #p>
	|
	  ::sys <isAtom #p>
	  <getval #r1 #p #var>
	  (
	    <is #r1 #p>
	    <is #r #r1>
	    |
	    <l_eval #r #r1 #var>
	  )
	|
	  <built_in #r #p #var>
	;
<l_eval #r (("λ" #arg #prog) :#parm) #var>
	<l_evparm #parm2 #parm #var>
	<setval #var2 #arg #parm2 #var>
	<l_eval #r #prog #var2>
	<trace "(λ)" (("λ" #arg #prog) :#parm) #r>
	;
<l_eval ("λ" #arg #prog2) ("λ" #arg #prog) #var>
	<setval #var2 #arg #arg #var>
	<replace_var #prog2 #prog #var2>
	<trace "λ" ("λ" #arg #prog) ("λ" #arg #prog2)>
	;
<l_eval #r (#f :#arg) #var>
	  <l_eval #f2 #f #var>
	  (
	     <is #f2 NIL> 
	     <is #r NIL>
	   | <noteq #f #f2>
	     <trace "eval " (#f :#arg) (#f2 : #arg)>
	     <l_eval #r (#f2 :#arg) #var> 
	   |
	     <is #r (#f2 :#arg)>
	  )
	;
	
<l_evlis () () #var>
	;
<l_evlis #r (#l) #var>
	<l_eval #r #l #var>
	;
<l_evlis #r2 (#l1 : #l2) #var>
	<l_eval #r1 #l1 #var>
	<l_evlis  #r2 #l2 #var>
	;
<l_evlis #r #l #var>
	;

<l_list () () #var>
	;
<l_list (#r1 :#r2) (#l1 : #l2) #var>
	<l_eval #r1 #l1 #var>
	<l_list  #r2 #l2 #var>
	;
<l_list #l #l #var>
	;

<l_evpr () () #var>
	;
<l_evpr #r (#l) #var>
	<l_eval #r #l #var>
	<print #r>
	;
<l_evpr #r2 (#l1 : #l2) #var>
	<l_eval #r1 #l1 #var>
	<printf #r1 " ">
	<l_evpr  #r2 #l2 #var>
	;
<l_evpr #l #l #var>
	;

<l_evparm () () #var>
	;
<l_evparm ((quote :#l1) : #r2) ((quote :#l1) : #l2) #var>
	<l_evlis  #r2 #l2 #var>
	;
<l_evparm (#r1 : #r2) (#l1 : #l2) #var>
	<l_eval #r1 #l1 #var>
	<l_evlis  #r2 #l2 #var>
	;

<replace_var #body2 (("λ" #arg #body) :#parm) #var>
	<setval #var2 #arg #parm #var>
	<replace_var #body2 #body #var2>
	<trace "replace(λ)" (("λ" #arg #body) #parm) #body2>
	;
<replace_var ("λ" #arg #body2) ("λ" #arg #body) #var>
	<setval #var2 #arg #arg #var>
	<replace_var #body2 #body #var2>
	<trace "replace λ" ("λ" #arg #body) ("λ" #arg #body2) >
	;
<replace_var (#new1 : #new2) (#old1 : #old2) #var>
	<replace_var #new1 #old1 #var>  
	<replace_var #new2 #old2 #var>
	;
<replace_var () () #var>
	;
<replace_var #new #old #var>
	::sys <isAtom #old>
	<getval #new #old #var>
	;

// LISPのメイン処理
<Lisp>
	<print "Descartes Lisp/λ (c) 2010 H.Niwa">
	{
		<var #var>
		<print Ready>
		::sys <getline  #line
			(
			  ";" <SKIPCR>
			 |
			  <NULLLINE>
			 |
			  <x <print "syntax error : " #line>>
			  <s_exp #list>  
			  {
			      ")" 
			      <print ::sys <line _> "syntax error : extra ')'">
		    	  }
			  <l_eval #r #list #var>
			  <print #r>
			)>
		|
		<print> 
	}
	;


? <Lisp>;