Jump to content
Sign in to follow this  
Mat

Lisp

Recommended Posts

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.

#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

Share this post


Link to post
Share on other sites

Very nice simple Lisp interpreter. Good job.


Whenever someone says "pls" because it's shorter than "please", I say "no" because it's shorter than "yes".

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
Sign in to follow this  

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...