Lisp

[Mat]

I haven't done much with AutoIt recently, and had some hours spare waiting for game of thrones, so I started this. Ended up being quite fun so I finished it this afternoon.

Currently the following are available:

defun quote append rest first second third last butlast listp null list-length * + - / ceiling floor round random if = < <= > >= mapcar eval

All the definitions and tests are taken from this page: http://jtra.cz/stuff/lisp/sclr/

If you want some examples that work:

(defun foo (x) (if (= (second (ceiling x 2)) 0) (+ x 10) (- x 10)))
(mapcar 'foo '(1 2 3 4 5))

That defines a function 'foo' that takes one input 'x'. If x is odd then it subtracts 10, and if its even then adds 10. It then applies it to a list (mapcar), so the result is the list, with each value having had foo called on it.

expandcollapse popup

#include <Array.au3> ; _ArrayDisplay, _ArraySearch

; Car Type constants. Do NOT use these, use the wrapping functions instead.
Global Enum $CT_LIST, $CT_ATOM

; Memory. Do not access directly, use the mem* functions.
Global $_MEMORY[1000][3] = [[0, 0, 0]] ; car type, car, cdr

Global Const $nil[2] = [$CT_LIST, 0]

#cs

    ; An example of building a list, and evaluating it.
    ; In this case we evaluate:
    ;
    ;    (if (= 1 2) 3 (* 4 5))

    $mul = consAllocAtom("*")
    $l = listPushAtom($mul, "4")
    listPushAtom($l, "5")

    $eq = consAllocAtom("=")
    $l = listPushAtom($eq, "1")
    listPushAtom($l, "2")

    $if = consAllocAtom("if")
    $l = listPushList($if, $eq)
    $l = listPushAtom($l, "3")
    listPushList($l, $mul)

    $list = consAllocList($if)

    listPrint($list)

    Local $callstack = 0
    Local $result = lispEval($callstack, $list), $error = @error, $extended = @extended

    ConsoleWrite("> " & listToStr($result) & @LF & "Error: " & $error & ", Extended: " & $extended & @LF)
    If $error Then memDisplay()

#ce

#cs

    ; Example of callstack, defun and calling user defined functions.
    ;
    ; (defun test () 3)
    ;
    ; (defun foo (a b c) (+ a b c))
    ;
    ; (foo 1 (* 2 test) 4)

    Local $callstack = callstackCreate()

    $defun = consAllocAtom("defun")
    listPushAtom($defun, "test")
    listPushList($defun, 0)
    listPushAtom($defun, "3")

    $list = consAllocList($defun)
    listPrint($list)
    Local $result = lispEval($callstack, $list), $error = @error, $extended = @extended
    ConsoleWrite("> " & listToStr($result) & @LF & "Error: " & $error & ", Extended: " & $extended & @LF)
    If $error Then memDisplay()

    $param_list = consAllocAtom("a")
    listPushAtom($param_list, "b")
    listPushAtom($param_list, "c")

    $func_body = consAllocAtom("+")
    listPushAtom($func_body, "a")
    listPushAtom($func_body, "b")
    listPushAtom($func_body, "c")

    $defun = consAllocAtom("defun")
    listPushAtom($defun, "foo")
    listPushList($defun, $param_list)
    listPushList($defun, $func_body)

    $list = consAllocList($defun)

    listPrint($list)
    Local $result = lispEval($callstack, $list), $error = @error, $extended = @extended
    ConsoleWrite("> " & listToStr($result) & @LF & "Error: " & $error & ", Extended: " & $extended & @LF)
    If $error Then memDisplay()

    $mul = consAllocAtom("*")
    $l = listPushAtom($mul, "2")
    listPushAtom($l, "test")

    $code = consAllocAtom("foo")
    listPushAtom($code, "1")
    listPushList($code, $mul)
    listPushAtom($code, "4")

    $list = consAllocList($code)

    listPrint($list)
    Local $result = lispEval($callstack, $list), $error = @error, $extended = @extended
    ConsoleWrite("> " & listToStr($result) & @LF & "Error: " & $error & ", Extended: " & $extended & @LF)
    If $error Then memDisplay()

#ce

#cs

    ; Tests the lexer and parser
    ;
    ; (foo 1 (* 2 test) 4)

    $lexer = lexerCreate("(foo 1 '(* 2 test) ""This is a String"")")

    While 1
    $t = lexerGetToken($lexer)
    If $t = "" Then ExitLoop

    ConsoleWrite($t & " ")
    WEnd
    ConsoleWrite(@LF)

    $lexer = lexerCreate("(foo 1 '(* 2 test) ""This is a String"")")
    Local $list = parserParse($lexer)
    ConsoleWrite("> " & listToStr($list) & @LF)

#ce

; Example of using a read-eval-loop
;
; Uses InputBox to read user input, and MsgBox to show the result.

relGo(reader, writer)

Func reader()
    Local $ret = InputBox("Enter line", "Press cancel to stop rel.")
    If @error Then Return SetError(1)

    Return $ret
EndFunc   ;==>reader

Func writer($str)
    MsgBox(0, "Test", $str)
EndFunc   ;==>writer


#Region Read-Eval-Loop

Func relGo($reader, $writer)
    Local $line, $result, $error, $extended
    Local $callstack = callstackCreate()

    While 1
        $line = Call($reader)
        If @error Then ExitLoop
        If $line = "" Then ContinueLoop

        $result = relEval($callstack, $line)
        $error = @error
        $extended = @extended

        If Not $error Then
            Call($writer, listToStr($result))
        Else
            Call($writer, "Error: " & $error & ", Extended: " & $extended)
        EndIf
    WEnd
EndFunc   ;==>relGo

Func relEval(ByRef $callstack, $line)
    Local $lexer = lexerCreate($line)

    Local $list = parserParse($lexer)
    If @error Then Return SetError(@error, @extended, 0) ; Parser or Lexer threw an error

    ConsoleWrite($line & @LF)
    ConsoleWrite("> " & listToStr($list) & @LF)

    Local $result = lispEval($callstack, $list)
    Return SetError(@error, @extended, $result)
EndFunc   ;==>relEval

#EndRegion Read-Eval-Loop


#Region Lexer

; Currently very very very basic. Does the job though.


; Creates a lexer.
Func lexerCreate($str)
    Local $lexer[6]

    $lexer[0] = $str ; Data
    $lexer[1] = 1 ; Line
    $lexer[2] = 1 ; Column
    $lexer[3] = 1 ; Absolute
    $lexer[4] = "" ; Name.
    $lexer[5] = 0 ; Tail.

    Return $lexer
EndFunc   ;==>lexerCreate

; Gets the next token from the lexer.
Func lexerGetToken(ByRef $lexer)
    If IsArray($lexer[5]) Then Return lexerGetToken($lexer[5])

    ; Currently this is the most basic lexer possible.
    ; All tokens are 1 character, whitespace is ignored.

    Local $c, $tok

    ; Ignore leading whitespace
    Do
        $c = _lexerGetChar($lexer)
    Until Not StringIsSpace($c)

    Local Enum $stNone = 0, $stString, $stInt, $stSymbol, $stFloat
    Local $st = 0

    While 1
        Switch $st
            Case $stNone
                Select
                    Case ''
                        $tok = ""
                        ExitLoop
                    Case $c = '(' Or $c = ')' Or $c = '.' Or $c = ''''
                        $tok = $c
                        ExitLoop
                    Case $c = '"'
                        $st = $stString
                    Case StringIsDigit($c)
                        $tok = $c
                        $st = $stInt
                    Case Not StringRegExp($c, "[^[:graph:]]")
                        $tok = $c
                        $st = $stSymbol
                    Case Else
                        ConsoleWrite("Invalid character: '" & $c & "'." & @LF)
                        Return SetError(200, 0, 0) ; Invalid character.
                EndSelect
            Case $stString
                If $c = '\' Then
                    ; Escape Sequence
                    $c = _lexerGetChar($lexer)

                    Switch $c
                        Case '\'
                            $tok &= '\'
                        Case 'n'
                            $tok &= @CRLF
                        Case 't'
                            $tok &= @TAB
                        Case '"'
                            $tok &= '"'
                        Case Else
                            ConsoleWrite("Unknown escape sequence: '\" & $c & "'" & @LF)
                            Return SetError(201, 0, 0) ; Unknown escape sequence
                    EndSwitch
                ElseIf $c = '"' Then
                    ExitLoop
                Else
                    $tok &= $c
                EndIf
            Case $stSymbol
                If $c = ')' Then
                    _lexerPutbackChar($lexer, $c)
                    ExitLoop
                ElseIf StringIsSpace($c) Or $c = '' Then
                    ExitLoop
                ElseIf Not StringRegExp($c, "[^[:graph:]]") Then
                    $tok &= $c
                Else
                    ConsoleWrite("Invalid character: '" & $c & "'." & @LF)
                    Return SetError(200, 0, 0) ; Invalid character.
                EndIf
            Case $stInt
                If StringIsDigit($c) Then
                    $tok &= $c
                ElseIf $c = '.' Then
                    $tok &= $c
                    $st = $stFloat
                ElseIf $c = ')' Then
                    _lexerPutbackChar($lexer, $c)
                    ExitLoop
                ElseIf StringIsSpace($c) Or $c = '' Then
                    ExitLoop
                Else
                    ConsoleWrite("Invalid character: '" & $c & "'." & @LF)
                    Return SetError(200, 0, 0) ; Invalid character.
                EndIf
            Case $stFloat
                If StringIsDigit($c) Then
                    $tok &= $c
                ElseIf $c = ')' Then
                    _lexerPutbackChar($lexer, $c)
                    ExitLoop
                ElseIf StringIsSpace($c) Or $c = '' Then
                    ExitLoop
                Else
                    ConsoleWrite("Invalid character: '" & $c & "'." & @LF)
                    Return SetError(200, 0, 0) ; Invalid character.
                EndIf
        EndSwitch

        $c = _lexerGetChar($lexer)
    WEnd

    Return $tok
EndFunc   ;==>lexerGetToken

Func _lexerPutbackChar(ByRef $lexer, $c)
    _lexerGetChar($lexer, $c)
EndFunc   ;==>_lexerPutbackChar

; Gets the next character from the stream, and increments counters.
; CRLF is treated as 1 character.
Func _lexerGetChar(ByRef $lexer, $cLast = '')
    Local $c = StringMid($lexer[0], $lexer[3], 1)

    Local Static $cPrev = ''
    If $cLast <> '' Then
        $cPrev = $cLast
        Return
    EndIf

    If $cPrev <> '' Then
        $c = $cPrev
        $cPrev = ''
        Return $c
    EndIf

    If $c = "" Then ; Out of bounds.
        Return ""
    EndIf

    If $c = @CR Then ; Check for LF
        If StringMid($lexer[0], $lexer[3] + 1, 1) = @LF Then
            $c = @CRLF
            $lexer[3] += 1
        EndIf
    EndIf

    If StringInStr(@CRLF, $c) Then ; Newline
        $lexer[1] += 1
        $lexer[2] = 1
    Else
        $lexer[2] += 1
    EndIf

    $lexer[3] += 1

    Return $c
EndFunc   ;==>_lexerGetChar

#EndRegion Lexer

#Region Parser

; Dead basic. Very little error checking, it assumes that anything it doesn't
; expect is an atom, so will accept garbage.

Func parserParse(ByRef $lexer)
    Local $list = parserParseList($lexer)
    Return consAllocList($list)
EndFunc   ;==>parserParse

Func parserParseList(ByRef $lexer)
    Local $tok, $top = 0

    While 1
        $tok = lexerGetToken($lexer)

        If @error Then
            Return SetError(@error, @extended, 0) ; Lexer threw an error
        EndIf

        If $tok = "" Then ExitLoop

        If $tok = "(" Then
            If Not $top Then
                $top = parserParseList($lexer)
            Else
                listPushList($top, parserParseList($lexer))
            EndIf
        ElseIf $tok = "'" Then
            Local $q = consAllocAtom("quote")

            $tok = lexerGetToken($lexer)

            If @error Then
                Return SetError(@error, @extended, 0) ; Lexer threw an error
            EndIf

            If $tok = "(" Then
                listPushList($q, parserParseList($lexer))
            Else
                listPushAtom($q, $tok)
            EndIf

            If Not $top Then
                $top = $q
            Else
                listPushList($top, $q)
            EndIf
        ElseIf $tok = "." Then
            ; Not Implemented!
            Return SetError(301, 0, 0) ; Not Implemented
        ElseIf $tok = ")" Then
            ExitLoop
        Else
            If Not $top Then
                $top = consAllocAtom($tok)
            Else
                listPushAtom($top, $tok)
            EndIf
        EndIf
    WEnd

    Return $top
EndFunc   ;==>parserParseList

#EndRegion Parser

#Region Symbol Table

; Todo.
; This will be required before defun and user library functions can be written.

Func callstackCreate()
    Local $callstack[200]

    ; Global scope is first scope.
    $callstack[0] = 1 ; Count
    $callstack[1] = callstackCreateFrame() ; $callstack[1] is global scope.

    Return $callstack
EndFunc   ;==>callstackCreate

Func callstackCreateFrame()
    Local $frame[10][4]

    $frame[0][0] = 0 ; Count in [0][0]

    ; Frame has a row for each symbol.
    ; [symbol, params, num_params, code]

    Return $frame
EndFunc   ;==>callstackCreateFrame

Func callstackDefun(ByRef $callstack, $symbol, $params, $num_params, $code)
    Return callstackFrameDefun($callstack[$callstack[0]], $symbol, $params, $num_params, $code)
EndFunc   ;==>callstackDefun

Func callstackFrameDefun(ByRef $frame, $symbol, $params, $num_params, $code)
    $frame[0][0] += 1

    If $frame[0][0] = UBound($frame) - 1 Then
        ReDim $frame[$frame[0][0] + 10][UBound($frame, 2)]
    EndIf

    $frame[$frame[0][0]][0] = $symbol
    $frame[$frame[0][0]][1] = $params
    $frame[$frame[0][0]][2] = $num_params
    $frame[$frame[0][0]][3] = $code

    Return $frame[0][0]
EndFunc   ;==>callstackFrameDefun

Func callstackEnterFunc(ByRef $callstack, $params, $num_params, $param_values)
    Local $frame = callstackCreateFrame()

    Local $p = $params, $v = $param_values

    While $p
        callstackFrameDefun($frame, consGetCarData($p), 0, 0, consGetCar($v))

        $p = consGetCdr($p)
        $v = consGetCdr($v)

        If $p And Not $v Then
            Return SetError(111, 0, 0) ; Incorrect number of parameters given.
        EndIf
    WEnd

    Return callstackEnter($callstack, $frame)
EndFunc   ;==>callstackEnterFunc

Func callstackEnter(ByRef $callstack, $frame)
    $callstack[0] += 1

    If $callstack[0] = UBound($callstack) Then
        ; Stack overflow? Can't just keep increasing the stack.
        ConsoleWrite("STACK OVERFLOW" & @LF)
        Return SetError(108, 0, 0) ; Stack Overflow
    EndIf

    $callstack[$callstack[0]] = $frame

    Return $callstack[0]
EndFunc   ;==>callstackEnter

Func callstackLeave(ByRef $callstack)
    If $callstack[0] = 1 Then ; Attempting to leave global frame?
        Return SetError(109, 0, 0) ; Stack Underflow
    EndIf

    $callstack[$callstack[0]] = 0
    $callstack[0] -= 1

    Return $callstack[0]
EndFunc   ;==>callstackLeave

Func callstackLookup(ByRef $callstack, $symbol)
    Local $ret[2], $i

    If $callstack[0] > 1 Then
        ; Check top frame.
        $i = callstackFrameLookup($callstack[$callstack[0]], $symbol)
        If $i <> -1 Then
            $ret[0] = $callstack[0]
            $ret[1] = $i

            Return $ret
        EndIf
    EndIf

    ; Check global frame
    $i = callstackFrameLookup($callstack[1], $symbol)
    If $i <> -1 Then
        $ret[0] = 1
        $ret[1] = $i

        Return $ret
    EndIf

    Return 0
EndFunc   ;==>callstackLookup

Func callstackFrameLookup(ByRef $frame, $symbol)
    Return _ArraySearch($frame, $symbol, 0, 0, 1, 2, 1, 0)
EndFunc   ;==>callstackFrameLookup


#EndRegion Symbol Table

#Region Error Handling

; Who needs error handling anyway.
; Functions returning errors return a (hopefully) unique error code. This
; should then be returned by the caller. @extended contains the con pair
; pointer.

#EndRegion Error Handling


#Region Lisp Functions

; Evaluates a list/atom.
; Returns a cons value.
Func lispEval(ByRef $callstack, $cons)
    If $cons = 0 Then
        ; nil
        Return $nil
    ElseIf consIsAtom($cons) Then
        ; Atom on its own.

        If StringIsInt(consGetCarData($cons)) Or StringIsFloat(consGetCarData($cons)) Then
            Return consGetCar($cons)
        Else
            Local $ret = lispCallFunction($callstack, consGetCarData($cons), $nil)
            If @error Then
                Return SetError(@error, @extended, $ret)
            EndIf

            Return $ret
        EndIf
    EndIf

    Local $list = consGetCarData($cons)
    If consIsList($list) Then
        Return SetError(101, $list, 0) ; Expected a function name.
    EndIf

    Local $ret = lispCallFunction($callstack, consGetCarData($list), consGetCdr($list))
    If @error Then
        Return SetError(@error, @extended, $ret)
    EndIf

    Return $ret
EndFunc   ;==>lispEval

; Calls a function.
; $fnAtom - The atom the function is associated with.
; $cons - The head of the parameter list.
Func lispCallFunction(ByRef $callstack, $fnAtom, $list)
    Local $ret

    Local $fn = lispGetFunction($fnAtom)
    If $fn <> -1 Then

        $ret = Call(libraryGetFunctions()[$fn][1], $callstack, $list)
        If @error = 0xDEAD And @extended = 0xBEEF Then
            Return SetError(102, $list, 0) ; Function does not exist.
        ElseIf @error Then
            ; Error reported by function call
            Return SetError(@error, @extended, $ret)
        EndIf
    ElseIf IsArray($callstack) Then
        $fn = callstackLookup($callstack, $fnAtom)
        If Not IsArray($fn) Then
            Return SetError(102, $list, 0) ; Function does not exist.
        EndIf

        Local $frame = $callstack[$fn[0]]

        If consIsList($frame[$fn[1]][3]) Or $frame[$fn[1]][2] Then
            callstackEnterFunc($callstack, $frame[$fn[1]][1], $frame[$fn[1]][2], $list)

            $ret = lispEval($callstack, $frame[$fn[1]][3])
            If @error Then
                Return SetError(@error, @extended, 0)
            EndIf

            callstackLeave($callstack)
        Else
            $ret = consGetCar($frame[$fn[1]][3])
        EndIf
    Else
        Return SetError(102, $list, 0) ; Function does not exist.
    EndIf

    Return $ret
EndFunc   ;==>lispCallFunction

; Looks up a function.
Func lispGetFunction($atom)
    Local $a = libraryGetFunctions()
    Return _ArraySearch($a, $atom, 0, 0, 1, 2, 1, 0)
EndFunc   ;==>lispGetFunction


; DEfine FUNction - defines a macro in LISP.
; Syntax is:
;  (defun foo (a b c d) (+ a b c d))
; user macro is then called using:
; (foo 1 2 3 4)
; > 10
Func lispDefun(ByRef $callstack, $list) ; LISP[defun]
    Local $symbol, $params, $num_params, $code

    If Not IsArray($callstack) Then
        Return SetError(112, $list, 0) ; Defun: callstack must be defined.
    EndIf

    If consIsList($list) Then
        Return SetError(103, $list, 0) ; Defun: symbol invalid.
    EndIf

    $symbol = consGetCarData($list)

    If lispGetFunction($symbol) <> -1 Then
        Return SetError(104, $list, 0) ; Defun: symbol already exists.
    EndIf

    If consIsTail($list) Then
        Return SetError(105, $list, 0) ; Defun: 3 parameters required.
    EndIf

    $list = consGetCdr($list)

    If Not consIsList($list) Then
        ; Single parameter.

        $params = $list
        $num_params = 1
    Else
        $params = consGetCarData($list)
        $num_params = listGetLength($params)
    EndIf

    If consIsTail($list) Then
        Return SetError(105, $list, 0) ; Defun: 3 parameters required.
    EndIf

    $code = consGetCdr($list)

    callstackDefun($callstack, $symbol, $params, $num_params, $code)

    Return $nil
EndFunc   ;==>lispDefun


#EndRegion Lisp Functions


#Region Library

; For testing purposes, a manually maintained array of functions would be a
; pain in the arse.
; To solve this, a list is generated from the source code. Any functions with
; the comment LISP[...] are added, associated with the atom ...
; For obvious reasons this doesn't work compiled. Use
; _libraryFunctionsArrayCode() to get an array.
;
; http://jtra.cz/stuff/lisp/sclr/

; Returns the array of library functions, in the form:
; [Function Atom, AutoIt Function]
Func libraryGetFunctions()
    Local Static $aFunctions = _libraryParseFunctions()
    Return $aFunctions
EndFunc   ;==>libraryGetFunctions

; Gets the function list from source code.
Func _libraryParseFunctions()
    Local $a = StringRegExp(FileRead(@ScriptFullPath), _
            "(?m)(?i)^Func\s+([[:alnum:]]+)\s*\(.*\)\s*;\s*LISP\[([^\]]+)\].*$", 3)

    Local $aRet[UBound($a) / 2][2]

    For $i = 0 To UBound($a) - 1 Step +2
        $aRet[$i / 2][0] = $a[$i + 1]
        $aRet[$i / 2][1] = $a[$i]
    Next

    Return $aRet
EndFunc   ;==>_libraryParseFunctions

; Returns the function library, as parsed from the source code, as an AutoIt
; array.
Func _libraryFunctionsArrayCode()
    Local $a = libraryGetFunctions()

    Local $ret = "Global $_FUNCTIONS[" & UBound($a) & "][2] = [ _" & @CRLF

    For $i = 0 To UBound($a) - 1
        $ret &= @TAB & @TAB & _
                "[""" & $a[$i][0] & """, " & $a[$i][1] & "], _" & @CRLF
    Next
    $ret = StringTrimRight($ret, StringLen(", _" & @CRLF)) & "]"

    Return $ret
EndFunc   ;==>_libraryFunctionsArrayCode

; (quote foo) = foo
Func lispQuote(ByRef $callstack, $list) ; LISP[quote]
    Return $list
EndFunc   ;==>lispQuote


#Region List Operators

; Todo:
; assoc
; cons
; consp
; getf
; list
; mapc
; mapcan
; mapcar
; mapcon
; maplist
; member
; pop
; push
; pushnew
; rplaca
; rplacd
; set-difference
; union

Func lispAppend(ByRef $callstack, $list) ; LISP[append]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return SetError(402, $list, 0) ; Append should have list arguments

    Local $ret = consGetCarData($l), $last = listGetTail(consGetCarData($l))

    While Not consIsTail($list)
        $list = consGetCdr($list)

        $l = lispEval($callstack, $list)
        If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.
        If Not consIsList($l) Then Return SetError(402, $list, 0) ; Append should have list arguments

        If consIsNil($l) Then ContinueLoop
        consSetCdr($last, consGetCarData($l))
        $last = listGetTail(consGetCarData($l))
    WEnd

    Return consAllocList($ret)
EndFunc   ;==>lispAppend

Func lispRest(ByRef $callstack, $list) ; LISP[rest]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return $nil

    Return consGetCdr(consGetCarData($l))
EndFunc   ;==>lispRest

Func lispFirst(ByRef $callstack, $list) ; LISP[first]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return $nil

    Return consGetCar(consGetCarData($l))
EndFunc   ;==>lispFirst

Func lispSecond(ByRef $callstack, $list) ; LISP[second]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return $nil

    Return consGetCar(consGetCdr(consGetCarData($l)))
EndFunc   ;==>lispSecond

Func lispThird(ByRef $callstack, $list) ; LISP[third]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return $nil

    Return consGetCar(consGetCdr(consGetCdr(consGetCarData($l))))
EndFunc   ;==>lispThird

Func lispLast(ByRef $callstack, $list) ; LISP[last]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.
    If consIsAtom($l) Then Return $nil

    $l = consGetCarData($l)

    Local $count = 1
    If Not consIsTail($list) Then
        $list = consGetCdr($list)
        Local $c = lispEval($callstack, $list)

        If consIsList($c) Then
            Return SetError(401, $list, 0) ; Expected count atom
        EndIf

        $count = consGetCarData($c)
        If $count <= 0 Then Return $nil
    EndIf

    Local $len = listGetLength($l) - $count
    If $len <= 0 Then Return $nil

    Local $ret = $l
    For $i = 1 To $len
        $ret = consGetCdr($ret)
    Next

    Return $ret
EndFunc   ;==>lispLast

Func lispButLast(ByRef $callstack, $list) ; LISP[butlast]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.
    If consIsAtom($l) Then Return $nil

    $l = consGetCarData($l)

    Local $count = 1
    If Not consIsTail($list) Then
        $list = consGetCdr($list)
        Local $c = lispEval($callstack, $list)

        If consIsList($c) Then
            Return SetError(401, $list, 0) ; Expected count atom
        EndIf

        $count = consGetCarData($c)
        If $count <= 0 Then Return $l
    EndIf

    Local $len = listGetLength($l) - $count
    If $len <= 0 Then Return $nil

    Local $top = consDuplicate($l), $here = $top, $next
    For $i = 1 To $len - 1
        $next = consDuplicate(consGetCdr($here))
        consSetCdr($here, $next)
        $here = $next
    Next

    consSetCdr($here, 0)

    Return $top
EndFunc   ;==>lispButLast

Func lispListp(ByRef $callstack, $list) ; LISP[listp]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If consIsList($l) Then
        Return pairCreateAtom(1)
    Else
        Return $nil
    EndIf
EndFunc   ;==>lispListp

Func lispNull(ByRef $callstack, $list) ; LISP[null]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If consIsNil($l) Then
        Return pairCreateAtom(1)
    Else
        Return $nil
    EndIf
EndFunc   ;==>lispNull

Func lispListLength(ByRef $callstack, $list) ; LISP[list-length]
    Local $l = lispEval($callstack, $list)
    If @error Then Return SetError(@error, @extended, 0) ; Eval threw an error.

    If Not consIsList($l) Then Return pairCreateAtom(0)

    If listIsCyclic($l) Then Return $nil

    Return pairCreateAtom(listGetLength(consGetCarData($l)))
EndFunc   ;==>lispListLength

#EndRegion List Operators

#Region Maths

; (* a b c d ...)
Func lispMul(ByRef $callstack, $list) ; LISP[*]
    Local $product = 1
    Local $val

    Do
        $val = lispEval($callstack, $list)
        If @error Then
            Return SetError(@error, @extended, 0) ; listEval returned an error
        EndIf

        If consIsList($val) Then
            Return SetError(113, $list, 0) ; Undefined: multiplication of lists
        EndIf

        $product *= Number(consGetCarData($val))
        $list = consGetCdr($list)
    Until Not $list

    Return pairCreateAtom($product)
EndFunc   ;==>lispMul

; (+ a b c d ...)
Func lispAdd(ByRef $callstack, $list) ; LISP[+]
    Local $sum = 0
    Local $val

    Do
        $val = lispEval($callstack, $list)
        If @error Then
            Return SetError(@error, @extended, 0) ; listEval returned an error
        EndIf

        If consIsList($val) Then
            Return SetError(103, $list, 0) ; Undefined: addition with lists.
        EndIf

        $sum += Number(consGetCarData($val))
        $list = consGetCdr($list)
    Until Not $list

    Return pairCreateAtom($sum)
EndFunc   ;==>lispAdd

; (- a b c d ...)
Func lispMinus(ByRef $callstack, $list) ; LISP[-]
    Local $sum = 0, $first = True
    Local $val

    Do
        $val = lispEval($callstack, $list)
        If @error Then
            Return SetError(@error, @extended, 0) ; listEval returned an error
        EndIf

        If consIsList($val) Then
            Return SetError(103, $list, 0) ; Undefined: addition with lists.
        EndIf

        If $first Then
            If consIsTail($list) Then
                $sum = -Number(consGetCarData($val))
            Else
                $sum = Number(consGetCarData($val))
            EndIf
            $list = consGetCdr($list)
            $first = False
        Else
            $sum -= Number(consGetCarData($val))
            $list = consGetCdr($list)
        EndIf
    Until Not $list

    Return pairCreateAtom($sum)
EndFunc   ;==>lispMinus

; (/ a b c d ...)
Func lispDiv(ByRef $callstack, $list) ; LISP[/]
    Local $product = 0, $first = True
    Local $val

    Do
        $val = lispEval($callstack, $list)
        If @error Then
            Return SetError(@error, @extended, 0) ; listEval returned an error
        EndIf

        If consIsList($val) Then
            Return SetError(103, $list, 0) ; Undefined: addition with lists.
        EndIf

        If $first Then
            If consIsTail($list) Then
                $product = 1 / Number(consGetCarData($val))
            Else
                $product = Number(consGetCarData($val))
            EndIf
            $list = consGetCdr($list)
            $first = False
        Else
            $product /= Number(consGetCarData($val))
            $list = consGetCdr($list)
        EndIf
    Until Not $list

    Return pairCreateAtom($product)
EndFunc   ;==>lispDiv

Func _lispRound(ByRef $callstack, $list, $predicate)
    Local $number, $divisor

    $number = lispEval($callstack, $list)
    If @error Then
        Return SetError(@error, @extended, 0)
    EndIf
    If Not consIsAtom($number) Then
        Return SetError(403, $number, 0) ; If: number must be an atom.
    EndIf
    $number = consGetCarData($number)

    If consIsTail($list) Then
        $divisor = 1
    Else
        $divisor = lispEval($callstack, consGetCdr($list))
        If @error Then
            Return SetError(@error, @extended, 0)
        EndIf
        If Not consIsAtom($divisor) Then
            Return SetError(404, $divisor, 0) ; If: number must be an atom.
        EndIf
        $divisor = consGetCarData($divisor)
    EndIf

    Local $quotient = $predicate($number / $divisor)
    Local $remainder = $number - $quotient * $divisor

    Local $ret = consAllocAtom($quotient)
    listPushAtom($ret, $remainder)

    Return consAllocList($ret)
EndFunc   ;==>_lispRound

Func lispCeiling(ByRef $callstack, $list) ; LISP[ceiling]
    Return _lispRound($callstack, $list, Ceiling)
EndFunc   ;==>lispCeiling

Func lispFloor(ByRef $callstack, $list) ; LISP[floor]
    Return _lispRound($callstack, $list, Floor)
EndFunc   ;==>lispFloor

Func lispRound(ByRef $callstack, $list) ; LISP[round]
    Return _lispRound($callstack, $list, Round)
EndFunc   ;==>lispRound

Func lispRandom(ByRef $callstack, $list) ; LISP[random]
    Local $max

    $max = lispEval($callstack, $list)
    If @error Then
        Return SetError(@error, @extended, 0)
    EndIf
    If Not consIsAtom($max) Then
        Return SetError(403, $max, 0) ; Random: max must be an atom.
    EndIf
    $max = Number(consGetCarData($max))

    Local $result = Random() * $max

    If IsInt($max) Then $result = Int($result)

    Return pairCreateAtom($result)
EndFunc   ;==>lispRandom

#EndRegion Maths

#Region Equality+Logical+If

; (if <expr> <true_value> <false_value>)
Func lispIf(ByRef $callstack, $list) ; LISP[if]
    If $list = 0 Then
        Return SetError(105, $list, 0) ; If: At least 2 parameters required.
    EndIf

    ; Evaluate the expression
    Local $expr = lispEval($callstack, $list)
    If @error Then
        Return SetError(@error, @extended, 0)
    EndIf
    If Not consIsAtom($expr) Then
        Return SetError(108, $expr, 0) ; If: <expr> must be an atom.
    EndIf

    ; Get boolean result
    Local $result
    If consIsNil($expr) Then
        $result = False
    Else
        $result = Number(consGetCarData($expr))
    EndIf

    ; Get true and false expressions
    If consIsTail($list) Then
        Return SetError(105, $list, 0) ; If: At least 2 parameters required.
    EndIf

    Local $true_code, $false_code
    $true_code = consGetCdr($list)
    $false_code = consGetCdr($true_code)

    Local $ret
    If $result Then
        $ret = lispEval($callstack, $true_code)
    Else
        $ret = lispEval($callstack, $false_code)
    EndIf

    Return $ret
EndFunc   ;==>lispIf


; (= a b c d ...)
Func lispEquals(ByRef $callstack, $list) ; LISP[=]
    Return lispCompare($callstack, $list, compareEqual)
EndFunc   ;==>lispEquals

Func compareEqual($a, $b)
    Return ($a = $b)
EndFunc   ;==>compareEqual

; (< a b c d ...)
Func lispLess(ByRef $callstack, $list) ; LISP[<]
    Return lispCompare($callstack, $list, compareLess)
EndFunc   ;==>lispLess

Func compareLess($a, $b)
    Return ($a < $b)
EndFunc   ;==>compareLess

; (<= a b c d ...)
Func lispLessOrEqual(ByRef $callstack, $list) ; LISP[<=]
    Return lispCompare($callstack, $list, compareLessOrEqual)
EndFunc   ;==>lispLessOrEqual

Func compareLessOrEqual($a, $b)
    Return ($a <= $b)
EndFunc   ;==>compareLessOrEqual

; (> a b c d ...)
Func lispGreater(ByRef $callstack, $list) ; LISP[>]
    Return lispCompare($callstack, $list, compareGreater)
EndFunc   ;==>lispGreater

Func compareGreater($a, $b)
    Return ($a > $b)
EndFunc   ;==>compareGreater

; (>= a b c d ...)
Func lispGreaterOrEqual(ByRef $callstack, $list) ; LISP[>=]
    Return lispCompare($callstack, $list, compareGreaterOrEqual)
EndFunc   ;==>lispGreaterOrEqual

Func compareGreaterOrEqual($a, $b)
    Return ($a >= $b)
EndFunc   ;==>compareGreaterOrEqual

; Compares a list values according to a predicate.
Func lispCompare(ByRef $callstack, $list, $predicate)
    ; As a naive operators, it wouldn't make sense for this to optimise the ands

    Local $result = True
    Local $a, $b, $br

    If $list = 0 Then
        Return SetError(105, $list, 0) ; =: At least 2 parameters required.
    EndIf

    ; Evaluate a and b
    $a = $list
    $b = consGetCdr($a)

    If $b = 0 Then
        Return SetError(105, $list, 0) ; =: At least 2 parameters required.
    EndIf

    $a = lispEval($callstack, $a)
    If @error Then
        Return SetError(@error, @extended, 0)
    EndIf

    Do
        $br = lispEval($callstack, $b)
        If @error Then
            Return SetError(@error, @extended, 0)
        EndIf

        Local $result

        If Not consIsAtom($a) Then
            If Not consIsAtom($br) Then
                ; Compare lists
                $result = $result And False
            Else
                $result = $result And False
            EndIf
        Else
            If Not consIsAtom($br) Then
                $result = $result And False
            Else
                ; Compare atoms.
                $result = $result And $predicate(consGetCarData($a), consGetCarData($br))
            EndIf
        EndIf

        $b = consGetCdr($b)
        $a = $br
    Until Not $b

    If $result Then
        Return pairCreateAtom(1)
    Else
        Return $nil
    EndIf
EndFunc   ;==>lispCompare

#EndRegion Equality+Logical+If


#Region Functions, Evaluation and flow control

; (mapcar fn lists)
Func lispMapCar(ByRef $callstack, $list) ; LISP[mapcar]
    Local $fn
    Local $lists[listGetLength($list) - 1]
    Local $nils = 0

    ; Evaluate the expression
    Local $fn = lispEval($callstack, $list)
    If @error Then
        Return SetError(@error, @extended, 0)
    EndIf
    If Not consIsAtom($fn) Then
        Return SetError(108, $fn, 0) ; If: <expr> must be an atom.
    EndIf
    $fn = consGetCarData($fn)

    For $i = 0 To UBound($lists) - 1
        $list = consGetCdr($list)

        $lists[$i] = lispEval($callstack, $list)
        If @error Then Return SetError(@error, @extended, 0)

        If consIsAtom($lists[$i]) Then
            Return SetError(405, $list, 0) ; Expected a list
        EndIf
        $lists[$i] = consGetCarData($lists[$i])

        If consIsNil($lists[$i]) Then $nils += 1
    Next

    Local $ret = 0, $r, $retTail = 0
    Local $l, $next, $top
    Do
        $top = consDuplicate($lists[0])
        $l = $top

        For $i = 1 To UBound($lists) - 1
            $next = consDuplicate($lists[$i])
            consSetCdr($l, $next)
            $l = $next
        Next
        consSetCdr($l, 0)

        $r = lispCallFunction($callstack, $fn, $top)
        If @error Then Return SetError(@error, @extended, 0) ; Calling the function returned an error

        If $ret = 0 Then
            $ret = consDuplicate($r)
            $retTail = $ret
        Else
            $r = consDuplicate($r)
            consSetCdr($retTail, $r)
            $retTail = $r
        EndIf

        For $i = 0 To UBound($lists) - 1
            If $lists[$i] Then
                $lists[$i] = consGetCdr($lists[$i])
                If Not $lists[$i] Then $nils += 1
            EndIf
        Next
    Until $nils = UBound($lists)

    Return consAllocList($ret)
EndFunc   ;==>lispMapCar

Func lispFnEval(ByRef $callstack, $list) ; LISP[eval]
    Local $l = lispEval($callstack, $list)

    Return lispEval($callstack, $l)
EndFunc   ;==>lispEval


#EndRegion Functions, Evaluation and flow control


#EndRegion Library


#Region Pair functions

; Pairs are 2d arrays that are convenient for passing car values around without
; using memory. Think of them a bit like registers.

Func pairCreate($a, $b)
    Local $aRet[2] = [$a, $b]
    Return $aRet
EndFunc   ;==>pairCreate

Func pairCreateAtom($data)
    Return pairCreate($CT_ATOM, $data)
EndFunc   ;==>pairCreateAtom

Func pairCreateList($ptr)
    Return pairCreate($CT_LIST, $ptr)
EndFunc   ;==>pairCreateList

#EndRegion Pair functions

#Region List functions

; Functions that manipulate and work with lists.
; Unlike cons values, input to these functions must be in memory.

; Returns the tail of the list.
Func listGetTail($list)
    If consIsTail($list) Then
        Return $list
    Else
        Return listGetTail(consGetCdr($list))
    EndIf
EndFunc   ;==>listGetTail

; Creates a new cons pair, with the given car value, sets it as the tail of the
; list, and returns the new tail.
; Should be used by the user. Use one specific listPush* functions.
Func listPush($list, $carType, $carData)
    Local $new = consAlloc($carType, $carData)

    If Not consIsTail($list) Then
        $list = listGetTail($list)
    EndIf

    consSetCdr($list, $new)

    Return $new
EndFunc   ;==>listPush

; Creates a new cons pair, with the given car list, sets it as the tail of the
; list, and returns the new tail.
Func listPushList($list, $ptr)
    Return listPush($list, $CT_LIST, $ptr)
EndFunc   ;==>listPushList

; Creates a new cons pair, with the given car atom, sets it as the tail of the
; list, and returns the new tail.
Func listPushAtom($list, $atom)
    Return listPush($list, $CT_ATOM, $atom)
EndFunc   ;==>listPushAtom

; Prints a list to the console.
Func listPrint($list)
    ConsoleWrite(listToStr($list) & @LF)
EndFunc   ;==>listPrint

; Returns the string representation of a list.
; As an added bonus, this function will accept car data as an array, rather
; than just a pointer to a list in memory.
Func listToStr($list)
    If consIsNil($list) Then Return "NIL"

    If IsArray($list) Then ; Car value.
        If consIsList($list) Then
            Return "(" & listToStr(consGetCarData($list)) & ")"
        Else
            Return String(consGetCarData($list))
        EndIf
    Else ; Pointer
        If $list = 0 Then Return "" ; End of list

        Local $ret = listToStr(consGetCar($list))

        Local $cdr = consGetCdr($list)
        If $cdr Then
            $ret &= " " & listToStr($cdr)
        EndIf

        Return $ret
    EndIf
EndFunc   ;==>listToStr

; Checks if a list is cyclic
Func listIsCyclic($list)
    Local $start = $list

    While Not consIsTail($list)
        $list = consGetCdr($list)
        If $list = $start Then Return True
    WEnd

    Return False
EndFunc   ;==>listIsCyclic

; Gets the length of a list.
Func listGetLength($list)
    If $list = 0 Then
        Return 0
    ElseIf consIsTail($list) Then
        Return 1
    Else
        Return 1 + listGetLength(consGetCdr($list))
    EndIf
EndFunc   ;==>listGetLength

; Compares two lists.
; Only a shallow compare.
Func listCompare($a, $b)
    If $a = $b Then Return True

    Do
        If consGetCarType($a) <> consGetCarType($b) _
                Or consGetCarData($a) <> consGetCarData($b) Then
            Return False
        Else
            $a = consGetCdr($a)
            $b = consGetCdr($b)
        EndIf
    Until Not $a And Not $b

    Return True
EndFunc   ;==>listCompare

#EndRegion List functions

#Region Cons pair functions


; Cons values can be either pointers to memory, or local pairs.
; If the input is an array then it is treated as a pair, all functions can
; handle both types, even if this just means returning an error.

; Checks if this cons pair is the tail of a list (no following pair)
Func consIsTail($cons)
    If IsArray($cons) Then
        Return True
    Else
        Return consGetCdr($cons) = 0
    EndIf
EndFunc   ;==>consIsTail

; Checks if the cons value is an atom.
; nil is a special case. It is both an atom and a list.
Func consIsAtom($cons)
    Return (consGetCarType($cons) = $CT_ATOM) _ ; Is an atom
            Or (consGetCarData($cons) = 0) ; Is nil
EndFunc   ;==>consIsAtom

; Checks if the cons value is a list.
Func consIsList($cons)
    Return consGetCarType($cons) = $CT_LIST
EndFunc   ;==>consIsList

; Checks if the cons value is nil.
Func consIsNil($cons)
    Return consIsList($cons) And (consGetCarData($cons) = 0)
EndFunc   ;==>consIsNil

; Gets the type of the cons value (returns one of the $CT_* constants).
; This should NOT be used by the user. You should be using one of the consIs*
; functions above, as these will deal with special cases such as nil.
Func consGetCarType($cons)
    If IsArray($cons) Then
        Return $cons[0]
    Else
        Return memGet($cons, 0)
    EndIf
EndFunc   ;==>consGetCarType

; Gets the data of the car element of the cons pair.
Func consGetCarData($cons)
    If IsArray($cons) Then
        Return $cons[1]
    Else
        Return memGet($cons, 1)
    EndIf
EndFunc   ;==>consGetCarData

; Gets the car part of the cons pair.
; This is returned as a pair.
Func consGetCar($cons)
    If IsArray($cons) Then
        Return $cons
    Else
        Return pairCreate(consGetCarType($cons), consGetCarData($cons))
    EndIf
EndFunc   ;==>consGetCar

; Sets the type of the car part of the cons pair.
Func consSetCarType(ByRef $cons, $carType)
    If IsArray($cons) Then
        $cons[0] = $carType
    Else
        memSet($cons, 0, $carType)
    EndIf
EndFunc   ;==>consSetCarType

; Sets the data of the car part of the cons pair.
Func consSetCarData(ByRef $cons, $carData)
    If IsArray($cons) Then
        $cons[1] = $carData
    Else
        memSet($cons, 1, $carData)
    EndIf
EndFunc   ;==>consSetCarData

; Sets the car value of the cons pair.
Func consSetCar(ByRef $cons, $carType, $carData)
    consSetCarType($cons, $carType)
    consSetCarData($cons, $carData)
EndFunc   ;==>consSetCar

; Sets the car value of the cons pair (from a given pair)
Func consSetCarP(ByRef $cons, $car)
    Return consSetCar($cons, $car[0], $car[1])
EndFunc   ;==>consSetCarP

; Gets the cdr part of the cons pair.
Func consGetCdr($cons)
    If IsArray($cons) Then
        Return SetError(104, 0, 0) ; Operation only valid on pairs in memory
    Else
        Return memGet($cons, 2)
    EndIf
EndFunc   ;==>consGetCdr

; Sets the cdr part of the cons pair.
Func consSetCdr($cons, $cdr)
    If IsArray($cons) Then
        Return SetError(104, 0, 0) ; Operation only valid on pairs in memory
    Else
        memSet($cons, 2, $cdr)
    EndIf
EndFunc   ;==>consSetCdr

; Allocates a new cons pair in memory, and assigns the car value.
; Should be used by the user. Use one specific consAlloc* functions.
Func consAlloc($carType, $carData)
    Local $ptr = memAlloc()

    consSetCar($ptr, $carType, $carData)

    Return $ptr
EndFunc   ;==>consAlloc

; Create a duplicate of a cons cell in memory.
Func consDuplicate($cons)
    Local $ret = consAlloc(consGetCarType($cons), consGetCarData($cons))
    consSetCdr($ret, consGetCdr($cons))
    Return $ret
EndFunc   ;==>consDuplicate

; Allocates a new cons pair in memory, and assigns the car list
Func consAllocList($ptr)
    Return consAlloc($CT_LIST, $ptr)
EndFunc   ;==>consAllocList

; Allocates a new cons pair in memory, and assigns the car atom
Func consAllocAtom($atom)
    Return consAlloc($CT_ATOM, $atom)
EndFunc   ;==>consAllocAtom

#EndRegion Cons pair functions


#Region Memory Functions

; Currently very basic. Just allocates a car,cdr pair in an array and returns
; the index.
; Could be made a lot more complex, $_MEMORY is never accessed directly.
; Unfortunately with this model, $_MEMORY has to be a global in order to be
; redimmed.

; Allocated a cons pair of memory and returns a pointer
Func memAlloc()
    $_MEMORY[0][0] += 1

    ; Expand memory as required
    If $_MEMORY[0][0] >= UBound($_MEMORY) Then
        ReDim $_MEMORY[$_MEMORY[0][0] + 1000][3]
    EndIf

    ; Zero Memory
    $_MEMORY[$_MEMORY[0][0]][0] = 0
    $_MEMORY[$_MEMORY[0][0]][1] = 0
    $_MEMORY[$_MEMORY[0][0]][2] = 0

    Return $_MEMORY[0][0]
EndFunc   ;==>memAlloc

; Frees memory.
Func memFree(ByRef $ptr)
    ; Meh. Just leave it.
EndFunc   ;==>memFree

; Retrieves the cons pair property $v at index $i
Func memGet($i, $v)
    If $i = 0 Then
        ConsoleWrite("SIGSEGV: Attempt to dereference null pointer" & @LF)
        Return 0
    EndIf

    Return $_MEMORY[$i][$v]
EndFunc   ;==>memGet

; Sets the cons pair property $v at index $i
Func memSet($i, $v, $value)
    If $i = 0 Then
        ConsoleWrite("SIGSEGV: Attempt to dereference null pointer" & @LF)
        Return 0
    EndIf

    $_MEMORY[$i][$v] = $value
EndFunc   ;==>memSet

; Displays memory (debug)
Func memDisplay()
    ; Redim the array to be the same size as memory.
    Local $a = $_MEMORY
    ReDim $a[$a[0][0] + 1][UBound($a, 2)]

    _ArrayDisplay($a)
EndFunc   ;==>memDisplay

#EndRegion Memory Functions

Hopefully it's not too hard to read and understand. It was a bit of fun to put together.

Matt

[JohnQSmith]

Very nice simple Lisp interpreter. Good job.