PowerShell で Lisp っぽいものを動かす

PowerShellの引数の区切りには空白が使われる。また、PowerShell は$argsという自動変数に引数の配列が格納される。そのため下記のように適当な関数を定義すると、空白区切りで配列を作成できる。

PS C:\demo\lisp_ps> filter : {$args}
PS C:\demo\lisp_ps> (: 1 2 3) -join ', '
1, 2, 3

つまり頑張れば、PowerShellでLispっぽく書けるはずである。

結果

結果としては、評価器 lisp.ps1 を読み込んだ状態で、lispっぽく書いたソート処理 mergesort_lisp.ps1 が動く。

PS C:\demo\lisp_ps> powershell -v 3 -nologo
PS C:\demo\lisp_ps> ls -name
lisp.ps1
mergesort_lisp.ps1
PS C:\demo\lisp_ps> . .\lisp.ps1
PS C:\demo\lisp_ps> . .\mergesort_lisp.ps1
(1, (2, (3, (4, (5, (6, ))))))

mergesort_lisp.ps1

[string](lisp `
    (: begin `
        (: define mergesort (: lambda (: xs) `
            (: mergeAll (: sequences xs))))`
        `
        (: define sequences (: lambda (: xs) `
            (: cond `
                (: eq? xs nil) nil `
                $true (: cons `
                        (: cons (: fst xs) nil) `
                        (: sequences (: snd xs))))))`
        `
        (: define mergeAll (: lambda  (: xs) `
            (: cond `
                (: eq? xs nil) nil `
                (: eq? (: snd xs) nil) (: fst xs)`
                $true `
                    (: mergeAll (: mergePairs xs)))))`
        `
        (: define mergePairs (: lambda (: xs)`
            (: cond `
                (: eq? xs nil) nil `
                (: eq? (: snd xs) nil) xs `
                $true (: cons `
                        (: merge (: fst xs) (: fst (: snd xs))) `
                        (: mergePairs (: snd (: snd xs)))))))`
        `
        (: define merge (: lambda (: xs ys)`
            (: cond `
                (: eq? xs nil) ys `
                (: eq? ys nil) xs `
                (: lt? (: fst xs) (: fst ys))`
                    (: cons (: fst xs) (: merge (: snd xs) ys))`
                $true `
                    (: cons (: fst ys) (: merge xs (: snd ys))))))`
        `
        (: mergesort (: quote (: 5 4 3 1 2 6)))`
    )`
)

lisp.ps1

# Eval
# ====
filter Invoke-Lisp ($Exp, $Env = (Get-LispBuiltInEnv))
{
    # Variable
    if ($Exp -is [string]) {return (Select-LispEnv $Exp $Env)[$Exp]}

    # Atom
    if (-not (pear? $Exp)) {return $Exp}

    $fst = Invoke-Lisp (fst $Exp) $Env
    $snd = snd $Exp

    # Syntax
    if ($fst -is [ScriptBlock]) {return & $fst $snd $Env}

    # Closure
    if (Test-LispClosure $fst) {return Invoke-LispClosure $fst $snd $Env}

    throw "${Exp} を評価できません。"
}

Set-Alias lisp Invoke-Lisp

# Pear
# ====
filter Get-LispNil {''}

filter New-LispPear
    ($Item1 = (Get-LispNil), $Item2 = (Get-LispNil))
        {[Tuple]::Create($Item1, $Item2)}

filter Get-LispPearFirst
    ([Parameter(ValueFromPipeline=$true)] $Pear)
        {,$Pear.Item1}

filter Get-LispPearSecond
    ([Parameter(ValueFromPipeline=$true)] $Pear)
        {,$Pear.Item2}

filter Test-LispPear
    ([Parameter(ValueFromPipeline=$true)] $InpuObject)
        {$InpuObject -is [Object] -and $InpuObject.GetType().Name -eq 'Tuple`2'}

filter New-LispList {Add-LispList $args}

filter Add-LispList ($Item, $List = (Get-LispNil))
{
    if ($Item.Length -eq 0) {return $List}

    ($Item.Length - 1)..0 |
        % {$l = $List} {$l = New-LispPear $Item[$_] $l} {$l}
}

filter ConvertFrom-LispList
   ([Parameter(ValueFromPipeline=$true)] $Pear)
        {for ($p = $Pear; pear? $p; $p = snd $p) {fst $p}}

Set-Alias : New-LispList
Set-Alias pear? Test-LispPear
Set-Alias fst Get-LispPearFirst
Set-Alias snd Get-LispPearSecond

# Env
# ===
filter Select-LispEnv ([string]$Keyword, $Env)
{
    for ($e = $Env; pear? $e; $e = snd $e)
        {if ((fst $e).Contains($Keyword)) {return fst $e}}

    throw "${Keyword}が定義された環境が見つかりません。"
}

# Closure
# =======
filter New-LispClosure ($ParamList, $BodyList, $ParentEnv, $ScriptBlock)
{
    $o = [PSObject]$PSBoundParameters
    $o | Add-Member -TypeName 'Lisp.Closure'
    $o
}

filter Test-LispClosure ($InputObject)
    {$InputObject -is [PSCustomObject] -and $InputObject.PSTypeNames[0] -eq 'Lisp.Closure'}

filter Invoke-LispClosure ($Closure, $ArgPear, $Env)
{
    # eval argument list
    $arg = $ArgPear | ConvertFrom-LispList | %{Invoke-Lisp $_ $Env}
    if ($arg -isnot [Array]) {$arg = ,$arg}

    # create new env
    $bound = New-LispBoundParameters $Closure.ParamList (Add-LispList $arg)
    $newEnv = New-LispPear $bound $Closure.ParentEnv

    # eval
    & $closure.ScriptBlock $closure.BodyList $newEnv
}

filter New-LispBoundParameters ($ParamPear, $ArgPear)
{
    # init variable
    $bound = @{}
    $pPear = $ParamPear
    $aPear = $ArgPear

    # bound parameter
    while ((pear? $pPear) -and (pear? $aPear))
    {
        $bound[(fst $pPear)] = fst $aPear
        $pPear = snd $pPear
        $aPear = snd $aPear
    }

    # wrong number of arguments
    if (pear? $pPear)
    {
        $ps = ($pPear | ConvertFrom-LispList) -join ', '
        throw "${ps} に対応する引数が不足しています。"
    }

    # rest argument
    $bound['rest'] = $aPear

    $bound
}

# Built In
# ========
filter Get-LispBuiltInEnv
{
    $BuiltIn = @{}

    # Variable
    $BuiltIn += Get-LispBuiltInVariable

    # Syntax
    $BuiltIn += Get-LispBuiltInSyntax

    # Closure
    $BuiltIn += Get-LispBuiltInClosure

    New-LispPear $BuiltIn
}

filter Get-LispBuiltInVariable
{
        $BuiltIn = @{}

        $BuiltIn.nil = Get-LispNil

        $BuiltIn
}

filter Get-LispBuiltInSyntax
{
    $BuiltIn = @{}

    $BuiltIn.cond = {param($body, $Env)
        $test, $list, $body = ($body | fst), ($body | snd | fst), ($body | snd | snd)
        while (-not (Invoke-Lisp $test $Env))
            {$test, $list, $body = ($body | fst), ($body | snd | fst), ($body | snd | snd)}
        Invoke-Lisp $list $Env
    }

    $BuiltIn.define = {param($body, $Env)
        $symbol = fst $body
        $e = fst $Env
        if ($e.Contains($symbol))
            {throw "${symbol}は既に定義されています。"}
        $e[$symbol] = Invoke-Lisp ($body | snd | fst) $Env
    }

    $BuiltIn.lambda = {param($body, $Env)
        New-LispClosure ($body | fst) ($body | snd | fst) $Env `
            {param($bodyList, $newEnv) Invoke-Lisp $bodyList $newEnv}
    }

    $BuiltIn.begin = {param($body, $Env)
        $r = Get-LispNil
        for ($b = $body; pear? $b; $b = snd $b)
            {$r = Invoke-Lisp (fst $b) $Env}
        $r
    }

    $BuiltIn.quote = {param($body, $Env) fst $body}

    $BuiltIn
}

filter Get-LispBuiltInClosure
{
    $BuiltIn = @{}
    $nil = Get-LispNil

    filter fun ($Keyword, $ScriptBlock)
        {$BuiltIn[$Keyword] = New-LispClosure $nil $nil $nil $ScriptBlock}

    fun cons {New-LispPear $arg[0] $arg[1]}
    fun fst {Get-LispPearFirst $arg[0]}
    fun snd {Get-LispPearSecond $arg[0]}
    fun eq? {$arg[0] -eq $arg[1]}
    fun lt? {$arg[0] -lt $arg[1]}

    $BuiltIn
}

参考

• ((Pythonで) 書く (Lisp) インタプリタ)