tinylisp.bas

' A QBasic interpreter for tinylisp (https://codegolf.stackexchange.com/q/62886/16766)
' Copyright 2022 D Loscutoff

DECLARE FUNCTION AsBuiltin$ (value$)
DECLARE FUNCTION AsInt$ (value#)
DECLARE FUNCTION AsNumber# (value$)
DECLARE SUB Display (value$)
DECLARE SUB DisplayRaw (value$)
DECLARE FUNCTION EvalEach! (exprList!, localNames!, localValues!)
DECLARE FUNCTION Evaluate$ (expression$, localNames!, localValues!)
DECLARE SUB Execute (exprPointer!)
DECLARE FUNCTION Lookup$ (name$, localNames!, localValues!)
DECLARE FUNCTION LookupGlobal$ (name$)
DECLARE FUNCTION NewCell! (value$, pointer!)
DECLARE FUNCTION NextToken$ (index!)
DECLARE FUNCTION Parse! (program$)
DECLARE FUNCTION ParseExprs! (index!)
DECLARE SUB StoreGlobal (name$, value$)
DECLARE FUNCTION TLCons$ (value$, list$)
DECLARE FUNCTION TLEqual! (value1$, value2$)
DECLARE FUNCTION TLHead$ (value$)
DECLARE FUNCTION TLNth$ (value$, n!)
DECLARE FUNCTION TLTail$ (value$)
DECLARE FUNCTION TLType$ (value$)

CONST MEMSIZE = 5000
CONST BUILTINS$ = "chtslevqid"
CONST NIL$ = ") 0"

' Global variable for parsing
COMMON SHARED code$
' Global variables for memory management
COMMON SHARED memvals$(), memptrs(), memnext
' Global variables for tinylisp globals
COMMON SHARED globalNames, globalValues
' Memory is two arrays, each representing one half of a cons cell
DIM memvals$(MEMSIZE), memptrs(MEMSIZE)
' memnext is the next available memory address
memnext = 1

' Load builtins into the global namespace
FOR i = 1 TO LEN(BUILTINS$)
  builtinName$ = MID$(BUILTINS$, i, 1)
  StoreGlobal builtinName$, AsBuiltin$(builtinName$)
NEXT i

' Prompt for filename and load file
CLS
INPUT "Enter the name of your tinylisp file: ", filename$
program$ = ""
OPEN filename$ FOR INPUT AS #1
  DO UNTIL EOF(1)
    LINE INPUT #1, line$
    program$ = program$ + line$ + CHR$(13)
  LOOP
CLOSE #1

' Parse and execute
CLS
parseTree = Parse(program$)
Execute parseTree



SUB Display (value$)
' Print a tinylisp value and a trailing newline

DisplayRaw value$
PRINT

END SUB


SUB DisplayRaw (value$)
' Print a tinylisp value without a trailing newline

SELECT CASE TLType$(value$)
  CASE "Builtin"
    PRINT "<builtin" + value$ + ">";
  CASE "Int"
    PRINT LTRIM$(RTRIM$(MID$(value$, 2)));
  CASE "List"
    address = AsNumber#(value$)
    addSpace = 0
    PRINT "(";
    WHILE address > 0
      IF addSpace THEN
        PRINT " ";
      ELSE
        addSpace = 1
      END IF
      DisplayRaw memvals$(address)
      address = memptrs(address)
    WEND
    PRINT ")";
  CASE ELSE
    PRINT value$;
END SELECT

END SUB


FUNCTION NextToken$ (index)
' Parse and return a token from code$ starting at index

' Skip over whitespace
WHILE index <= LEN(code$) AND MID$(code$, index, 1) <= " "
  index = index + 1
WEND

IF index > LEN(code$) THEN
  ' Walked off end of code, no more tokens available
  NextToken$ = ""
ELSE
  ' Determine token type by looking at next character
  char$ = MID$(code$, index, 1)
  IF char$ = "(" OR char$ = ")" THEN
    ' Parentheses are tokens
    NextToken$ = char$
    index = index + 1
  ELSE
    ' Scan until whitespace or parenthesis
    token$ = ""
    DO
      token$ = token$ + char$
      index = index + 1
      char$ = MID$(code$, index, 1)
    LOOP UNTIL char$ <= " " OR char$ = "(" OR char$ = ")"
    NextToken$ = token$
  END IF
END IF

END FUNCTION


FUNCTION NewCell (value$, pointer)
' Return the address of a new cons cell

' Store the information at the next available address
memvals$(memnext) = value$
memptrs(memnext) = pointer
' Return that address
NewCell = memnext
' Increment the address for next time
memnext = memnext + 1

END FUNCTION


FUNCTION Parse (program$)
' Parse program, store in memory, and return the address

code$ = program$ + " "
Parse = ParseExprs(1)

END FUNCTION


FUNCTION ParseExprs (index)
' Parse 0 or more expressions, store in memory, and return the address

firstCell = 0
lastCell = 0

token$ = NextToken$(index)
DO UNTIL token$ = "" OR token$ = ")"
  IF token$ = "(" THEN
    ' Parse a subtree recursively
    subtree = ParseExprs(index)
    nextCell = NewCell(AsList$(subtree), 0)
  ELSE
    ' Check if the token is made entirely of digits
    allDigits = 1
    FOR i = 1 TO LEN(token$)
      char$ = MID$(token$, i, 1)
      IF char$ < "0" OR char$ > "9" THEN
        allDigits = 0
        EXIT FOR
      END IF
    NEXT i
    IF allDigits THEN
      ' Integer token
      nextCell = NewCell(AsInt$(VAL(token$)), 0)
    ELSE
      ' Symbol token
      nextCell = NewCell(token$, 0)
    END IF
  END IF
  IF lastCell > 0 THEN
    ' Link lastCell to nextCell
    memptrs(lastCell) = nextCell
  ELSE
    ' No cells yet, so nextCell is actually the first cell
    firstCell = nextCell
  END IF
  lastCell = nextCell
  token$ = NextToken$(index)
LOOP

' Return the first cell (possibly nil)
ParseExprs = firstCell

END FUNCTION


SUB StoreGlobal (name$, value$)
' Add name and value to the lists constituting the global name bindings

' Storing a global should fail if a binding already exists for that name
IF LookupGlobal$(name$) <> "" THEN
  PRINT "Global binding for "; name$; " already exists"
  EXIT SUB
END IF

' Prepend the new name to the list of global names and the new value
' to the list of global values
globalNames = NewCell(name$, globalNames)
globalValues = NewCell(value$, globalValues)

END SUB


FUNCTION LookupGlobal$ (name$)
' Return the value bound to the given name at global scope

currentName = globalNames
currentValue = globalValues
WHILE currentName > 0 AND currentValue > 0
  IF memvals$(currentName) = name$ THEN
    LookupGlobal$ = memvals$(currentValue)
    EXIT FUNCTION
  ELSE
    currentName = memptrs(currentName)
    currentValue = memptrs(currentValue)
  END IF
WEND

' If no binding was found, return empty string
LookupGlobal$ = ""

END FUNCTION


FUNCTION Lookup$ (name$, localNames, localValues)
' Return the value bound to the given name at local or global scope

currentName = localNames
currentValue = localValues
WHILE currentName > 0 AND currentValue > 0
  IF memvals$(currentName) = name$ THEN
    Lookup$ = memvals$(currentValue)
    EXIT FUNCTION
  ELSE
    currentName = memptrs(currentName)
    currentValue = memptrs(currentValue)
  END IF
WEND

' If no local binding was found, try globals
Lookup$ = LookupGlobal$(name$)

END FUNCTION


SUB Execute (exprPointer)
' Evaluate a list of expressions and display each result

WHILE exprPointer > 0
  result$ = Evaluate$(memvals$(exprPointer), 0, 0)
  Display result$
  exprPointer = memptrs(exprPointer)
WEND

END SUB


FUNCTION Evaluate$ (expression$, localNames, localValues)
' Evaluate an expression and return the result

' Assign function arguments to different variables so changing them
' in the loop doesn't modify the original arguments
expr$ = expression$
names = localNames
values = localValues
DO
  SELECT CASE TLType$(expr$)
    CASE "Builtin", "Int"
      ' Builtins and integers evaluate to themselves
      Evaluate$ = expr$
      EXIT FUNCTION
    CASE "Symbol"
      ' Symbols evaluate to the name bound to them
      value$ = Lookup$(expr$, names, values)
      IF value$ = "" THEN
        ' No binding found for this name; return nil
        PRINT expr$; " is not defined"
        Evaluate$ = NIL$
      ELSE
        Evaluate$ = value$
      END IF
      EXIT FUNCTION
    CASE "List"
      address = AsNumber#(expr$)
      IF address = 0 THEN
        ' Nil evaluates to itself
        Evaluate$ = expr$
        EXIT FUNCTION
      ELSE
        ' A nonempty list is a function or macro call
        exprHead$ = Evaluate$(TLHead$(expr$), names, values)
        SELECT CASE TLType$(exprHead$)
          CASE "Builtin"
            SELECT CASE MID$(exprHead$, 2)
              CASE "i"
                ' Eliminate the if and loop again
                cond$ = Evaluate$(TLNth$(expr$, 1), names, values)
                condType$ = TLType$(cond$)
                IF condType$ = "Int" OR condType$ = "List" THEN
                  IF AsNumber#(cond$) = 0 THEN
                    ' 0 and nil are falsey
                    condTruthy = 0
                  ELSE
                    ' All other lists and ints are truthy
                    condTruthy = 1
                  END IF
                ELSE
                  ' All builtins and symbols are truthy
                  condTruthy = 1
                END IF
                IF condTruthy THEN
                  expr$ = TLNth$(expr$, 2)
                ELSE
                  expr$ = TLNth$(expr$, 3)
                END IF
              CASE "v"
                ' Eliminate the eval and loop again
                expr$ = Evaluate$(TLNth$(expr$, 1), names, values)
              CASE "q"
                ' Return the argument unevaluated
                Evaluate$ = TLNth$(expr$, 1)
                EXIT FUNCTION
              CASE "d"
                ' Evaluate the second arg and bind it to the first arg
                name$ = TLNth$(expr$, 1)
                value$ = Evaluate$(TLNth$(expr$, 2), names, values)
                StoreGlobal name$, value$
                ' Return the name
                Evaluate$ = name$
                EXIT FUNCTION
              CASE "h"
                ' Return the head of the evaluated argument
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                Evaluate$ = TLHead$(arg1$)
                EXIT FUNCTION
              CASE "t"
                ' Return the tail of the evaluated argument
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                Evaluate$ = TLTail$(arg1$)
                EXIT FUNCTION
              CASE "c"
                ' Cons the first argument to the second and return
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                arg2$ = Evaluate$(TLNth$(expr$, 2), names, values)
                Evaluate$ = TLCons$(arg1$, arg2$)
                EXIT FUNCTION
              CASE "s"
                ' Subtract the second argument from the first and return
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                arg2$ = Evaluate$(TLNth$(expr$, 2), names, values)
                result# = AsNumber#(arg1$) - AsNumber#(arg2$)
                Evaluate$ = AsInt$(result#)
                EXIT FUNCTION
              CASE "l"
                ' Return 1 if the first arg is less than the second, else 0
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                arg2$ = Evaluate$(TLNth$(expr$, 2), names, values)
                result = AsNumber#(arg1$) < AsNumber#(arg2$)
                Evaluate$ = AsInt$(-result)
                EXIT FUNCTION
              CASE "e"
                ' Return 1 if the first arg is the same as the second, else 0
                arg1$ = Evaluate$(TLNth$(expr$, 1), names, values)
                arg2$ = Evaluate$(TLNth$(expr$, 2), names, values)
                Evaluate$ = AsInt$(TLEqual(arg1$, arg2$))
                EXIT FUNCTION
              CASE ELSE
                ' ??!
                PRINT exprHead$; " is not a recognized builtin"
                Evaluate$ = NIL$
                EXIT FUNCTION
            END SELECT
          CASE "List"
            ' User-defined function or macro
            args = AsNumber#(TLTail$(expr$))
            IF TLHead$(exprHead$) = NIL$ THEN
              ' Macro--remove extra nil from beginning
              exprHead$ = TLTail$(exprHead$)
            ELSE
              ' Function--evaluate arguments
              args = EvalEach(args, names, values)
            END IF
            params$ = TLNth$(exprHead$, 0)
            body$ = TLNth$(exprHead$, 1)
            ' Set new locals, new expr, and loop
            IF TLType$(params$) = "List" THEN
              names = AsNumber#(params$)
              values = args
            ELSE
              ' Variadic function/macro; wrap the args in a singleton list
              names = AsNumber#(exprHead$)
              values = NewCell(AsList$(args), 0)
            END IF
            expr$ = body$
          CASE ELSE
            ' Error
            DisplayRaw exprHead$
            PRINT " cannot be called as a function or macro"
            Evaluate$ = NIL$
            EXIT FUNCTION
        END SELECT
      END IF
  END SELECT
LOOP

END FUNCTION


FUNCTION EvalEach (exprList, localNames, localValues)
' Take a list of expressions, evaluate each one, and return a list of results

firstCell = 0
lastCell = 0

WHILE exprList > 0
  value$ = Evaluate$(memvals$(exprList), localNames, localValues)
  nextCell = NewCell(value$, 0)
  IF lastCell > 0 THEN
    ' Link lastCell to nextCell
    memptrs(lastCell) = nextCell
  ELSE
    ' No cells yet, so nextCell is actually the first cell
    firstCell = nextCell
  END IF
  lastCell = nextCell
  exprList = memptrs(exprList)
WEND

' Return the first cell (possibly nil)
EvalEach = firstCell

END FUNCTION


FUNCTION TLHead$ (value$)
' If value$ is a list, return its head (or nil if it is nil)

IF TLType$(value$) = "List" THEN
  address = AsNumber#(value$)
  IF address > 0 THEN
    TLHead$ = memvals$(address)
  ELSE
    ' The head of nil is nil
    TLHead$ = value$
  END IF
ELSE
  ' Not a list--return nil
  PRINT "Trying to get head of non-list ";
  Display value$
  TLHead$ = NIL$
END IF

END FUNCTION


FUNCTION TLTail$ (value$)
' If value$ is a list, return its tail (or nil if it is nil)

IF TLType$(value$) = "List" THEN
  address = AsNumber#(value$)
  IF address > 0 THEN
    TLTail$ = AsList$(memptrs(address))
  ELSE
    ' The tail of nil is nil
    TLTail$ = value$
  END IF
ELSE
  ' Not a list--return nil
  PRINT "Trying to get tail of non-list ";
  Display value$
  TLTail$ = NIL$
END IF

END FUNCTION


FUNCTION TLNth$ (value$, n)
' If value$ is a list, return its nth element (or nil if it's too short)

IF TLType$(value$) = "List" THEN
  address = AsNumber#(value$)
  FOR i = 1 TO n
    IF address > 0 THEN
      address = memptrs(address)
    END IF
  NEXT i
  IF address > 0 THEN
    TLNth$ = memvals$(address)
  ELSE
    ' List contained n or fewer elements; return nil
    TLNth$ = NIL$
  END IF
ELSE
  ' Not a list--return nil
  PRINT "Trying to get nth element of non-list ";
  Display value$
  TLNth$ = NIL$
END IF

END FUNCTION


FUNCTION TLCons$ (value$, list$)
' Cons a value to a list and return the new list

IF TLType$(list$) = "List" THEN
  ' Create a new cell with value$ as head and list$ as tail
  TLCons$ = AsList$(NewCell(value$, AsNumber#(list$)))
ELSE
  PRINT "Cannot cons to non-list in tinylisp"
  TLCons$ = NIL$
END IF

END FUNCTION


FUNCTION TLType$ (value$)
' Returns the type of the given value based on its prefix sigil

SELECT CASE LEFT$(value$, 1)
  CASE "("
    TLType$ = "Int"
  CASE ")"
    TLType$ = "List"
  CASE " "
    TLType$ = "Builtin"
  CASE ELSE
    ' Anything without a prefix is a symbol
    TLType$ = "Symbol"
END SELECT

END FUNCTION


FUNCTION TLEqual (value1$, value2$)
' Return 1 if two tinylisp values are equal, 0 otherwise

IF value1$ = value2$ THEN
  ' Two equal non-lists or identical list pointers
  TLEqual = 1
ELSEIF TLType$(value1$) = "List" AND TLType$(value2$) = "List" THEN
  ' Compare two lists recursively
  IF value1$ = NIL$ OR value2$ = NIL$ THEN
    ' We already checked if they were identical, so one of them being
    ' nil here means the other one isn't
    TLEqual = 0
  ELSE
    ' With two nonempty lists, recurse over the heads and the tails
    headsEqual = TLEqual(TLHead$(value1$), TLHead$(value2$))
    tailsEqual = TLEqual(TLTail$(value1$), TLTail$(value2$))
    TLEqual = headsEqual AND tailsEqual
  END IF
ELSE
  ' Otherwise, definitely not equal
  TLEqual = 0
END IF

END FUNCTION


FUNCTION AsList$ (pointer)
' Convert a numeric pointer to a string representing a list address

AsList$ = ")" + STR$(pointer)

END FUNCTION


FUNCTION AsInt$ (value#)
' Convert a double value to a string representing a tinylisp integer

AsInt$ = "(" + STR$(value#)

END FUNCTION


FUNCTION AsBuiltin$ (value$)
' Convert a string to the builtin with that name

AsBuiltin$ = " " + value$

END FUNCTION


FUNCTION AsNumber# (value$)
' Convert a tinylisp value stored as a string to a QBasic number
' Works for both integers and list addresses

AsNumber# = VAL(MID$(value$, 2))

END FUNCTION