Initial pass at arrays

doc/DRAWL.md

@@ -4,6 +4,7 @@ LISP interpreted on a bytecode VM running on a 1 MHz 6502 is going to be sssllll
 
 ## Missing features of LISP 1.5 in DRAWL
 
+- FUNCTION operation. Use QUOTE for functions that don't use higher up bound variables
 - General recursion. The 6502 architecture limits recursion (but see tail recursion below), so don't expect too much here
 - Arrays not implemented
 
@@ -11,7 +12,7 @@ However, the code is partitioned to allow for easy extension so some of these mi
 
 ## Features of DRAWL
 
-- 32 bit integers and 80 bir floating point with transcendental math operators
+- 32 bit integers and 80 bit floating point with transcendental math operators by way of the SANE library
 - Tail recursion handles deep recursion. Check out [loop.lisp](https://github.com/dschmenk/PLASMA/blob/master/src/lisp/loop.lisp)
 - Fully garbage collected behind the scenes
 - Optionally read LISP source file at startup

src/lisp/drawl.pla

@@ -13,6 +13,7 @@ import sexpr
   const NUM_TYPE   = $30
   const NUM_INT    = $31
   const NUM_FLOAT  = $32
+  const ARRAY_TYPE = $40
   const MARK_BIT   = $80
   const MARK_MASK  = $7F
 
@@ -29,8 +30,17 @@ import sexpr
     res[t_elem]
     word natv
     word lambda
-    char[0] name
+    word array
+    word apval
+    char name[0]
   end
+  struc t_numint
+    res[t_elem]
+    word intval[2]
+  end
+
+  var fmt_fpint
+  var fmt_fpfrac
 
   predef gc#0
   predef print_expr(expr)#0
@@ -44,11 +54,12 @@ import sexpr
 end
 
 import smath
+  predef eval_int(expr)#1
 end
 
 var prog, prog_expr, prog_return // Current PROG expressions
-var sym_cond                     // Symbol for cond()
-var pred_true                    // Predicate for TRUE
+var sym_cond, sym_fpint, sym_fpfrac
+var pred_true
 
 const FILEBUF_SIZE = 128
 var readfn                       // Read input routine
@@ -59,7 +70,7 @@ byte quit = FALSE                // Quit interpreter flag
 // (PROG ...) language extension
 //
 
-def natv_prog(expr)
+def natv_prog(symptr, expr)
   var prog_enter, prog_car, cond_expr
 
   prog_expr  = expr=>cdr
@@ -100,56 +111,68 @@ def natv_prog(expr)
   return eval_expr(prog_return)
 end
 
-def natv_return(expr)
+def natv_return(symptr, expr)
   prog_return = expr=>car
   return NULL // This value will be dropped in natv_prog
 end
 
-def natv_go(expr)
-  var label, go
-
-  expr  = expr=>car
-  label = prog // Scan prog list looking for matching SYM
-  while label
-    if label=>car == expr
-      prog_expr = label=>cdr
+def natv_go(symptr, expr)
+  expr   = expr=>car
+  symptr = prog // Scan prog list looking for matching SYM
+  while symptr
+    if symptr=>car == expr
+      prog_expr = symptr=>cdr
       return NULL
     fin
-    label = label=>cdr
+    symptr = symptr=>cdr
   loop
   puts("(GO ...) destination not found:"); print_expr(expr); putln
   return NULL
 end
 
-def natv_set(expr)
-  var valptr
-
-  valptr = eval_expr(expr=>cdr=>car)
-  set_assoc(eval_expr(expr=>car), valptr)
-  return valptr
+def natv_set(symptr, expr)
+  symptr = eval_expr(expr=>cdr=>car)
+  set_assoc(eval_expr(expr=>car), symptr)
+  return symptr
 end
 
-def natv_setq(expr)
-  var valptr
-
-  valptr = eval_expr(expr=>cdr=>car)
-  set_assoc(expr=>car, valptr)
-  return valptr
+def natv_setq(symptr, expr)
+  symptr = eval_expr(expr=>cdr=>car)
+  set_assoc(expr=>car, symptr)
+  return symptr
 end
 
 //
 // REPL native helper functions
 //
 
-def natv_bye(expr)
-  quit = TRUE
-  return new_sym("GOODBYE!")
+def natv_fpint(symptr, expr)
+  var fmt
+
+  fmt_fpint = eval_int(expr)=>intval
+  fmt = new_int(fmt_fpint,  0)
+  set_assoc(sym_fpint, fmt)
+  return fmt
 end
 
-def natv_memavail(expr)
+def natv_fpfrac(symptr, expr)
+  var fmt
+
+  fmt_fpfrac = eval_int(expr)=>intval
+  fmt = new_int(fmt_fpfrac,  0)
+  set_assoc(sym_fpfrac, fmt)
+  return fmt
+end
+
+def natv_memavail(symptr, expr)
   return new_int(heapavail, 0)
 end
 
+def natv_bye(symptr, expr)
+  quit = TRUE
+  return new_sym("GOODBYE!")
+end
+
 //
 // Keyboard and file input routines
 //
@@ -220,7 +243,6 @@ end
 def parse_cmdline#0
   var filename
 
-  puts("DRAWL (LISP 1.5) symbolic processor\n")
   readfn = @read_keybd
   filename = argNext(argFirst)
   if ^filename
@@ -239,15 +261,22 @@ end
 // REPL
 //
 
-pred_true = bool_pred(TRUE) // Capture value of TRUE
-sym_cond  = new_sym("COND") // This should actually match COND
+puts("DRAWL (LISP 1.5) symbolic processor\n")
+pred_true  = bool_pred(TRUE) // Capture value of TRUE
+sym_fpint  = new_sym("FMTFPI")
+sym_fpfrac = new_sym("FMTFPF")
+sym_fpint=>natv  = @natv_fpint
+sym_fpfrac=>natv = @natv_fpfrac
+new_assoc(sym_fpint,  new_int(fmt_fpint,  0))
+new_assoc(sym_fpfrac, new_int(fmt_fpfrac, 0))
+sym_cond = new_sym("COND") // This should actually match COND
 new_sym("PROG")=>natv   = @natv_prog
 new_sym("GO")=>natv     = @natv_go
 new_sym("RETURN")=>natv = @natv_return
 new_sym("SET")=>natv    = @natv_set
 new_sym("SETQ")=>natv   = @natv_setq
 new_sym("BYE")=>natv    = @natv_bye
-new_sym("MEM")=>natv    = @natv_memavail
+
 parse_cmdline
 while not quit
   putln; print_expr(eval_expr(readfn()))

src/lisp/s-expr.pla

@@ -12,6 +12,7 @@ const SYM_LEN    = $0F
 const NUM_TYPE   = $30
 const NUM_INT    = $31
 const NUM_FLOAT  = $32
+const ARRAY_TYPE = $40
 const MARK_BIT   = $80
 const MARK_MASK  = $7F
 
@@ -28,22 +29,29 @@ struc t_sym
   res[t_elem]
   word natv
   word lambda
-  char[0] name
+  word array
+  word apval
+  char name[0]
+end
+struc t_array
+  res[t_elem]
+  word dimension[4]
+  word arraymem
 end
 struc t_numint
   res[t_elem]
-  word[2] intval
+  word intval[2]
 end
 struc t_numfloat
   res[t_elem]
-  res[10] floatval
+  res floatval[10]
 end
 
 predef eval_expr(expr)
 
-var sym_quote, sym_lambda, sym_cond
+var sym_quote, sym_lambda, sym_cond, sym_set
 res[t_elem]   pred_true  = 0, 0, BOOL_TRUE
-res[t_elem]   pred_false = 0, 0, BOOL_FALSE
+res[t_elem]   pred_nil   = 0, 0, NIL
 
 var cons_list  = NULL
 var cons_free  = NULL
@@ -54,6 +62,10 @@ var float_free = NULL
 var sym_list   = NULL
 var assoc_list = NULL // SYM->value association list
 
+const fmt_fp          = FPSTR_FIXED|FPSTR_STRIP|FPSTR_FLEX
+export var fmt_fpint  = 6
+export var fmt_fpfrac = 4
+
 //
 // Garbage collector
 //
@@ -92,6 +104,9 @@ def sweep_used#0
     if symptr=>lambda
       sweep_expr(symptr=>lambda)
     fin
+    if symptr=>apval
+      sweep_expr(symptr=>apval)
+    fin
     symptr = symptr=>link
   loop
 end
@@ -224,6 +239,34 @@ export def new_float(extptr)#1
   return floatptr
 end
 
+def new_array(dim0, dim1, dim2, dim3)
+  var size, aptr, memptr
+
+  size = dim0 * 2
+  if dim1; size = size * dim1; fin
+  if dim2; size = size * dim2; fin
+  if dim3; size = size * dim3; fin
+  if not size
+    puts("Zero sized array!\n")
+    return NULL
+  fin
+  memptr = heapalloc(size)
+  if not memptr
+    puts("Array too large!\n")
+    return NULL
+  fin
+  memset(memptr, NULL, size)
+  aptr               = heapalloc(t_array)
+  aptr=>link         = NULL
+  aptr->type         = ARRAY_TYPE
+  aptr=>dimension[0] = dim0
+  aptr=>dimension[1] = dim1
+  aptr=>dimension[2] = dim2
+  aptr=>dimension[3] = dim3
+  aptr=>arraymem     = memptr
+  return aptr
+end
+
 def match_sym(symstr)
   var symptr
   byte len, typelen, i
@@ -257,6 +300,8 @@ export def new_sym(symstr)#1
   symptr->type   = ^symstr | SYM_TYPE
   symptr=>natv   = NULL
   symptr=>lambda = NULL
+  symptr=>array  = NULL
+  symptr=>apval  = NULL
   memcpy(symptr + name, symstr + 1, ^symstr)
   return symptr
 end
@@ -327,6 +372,7 @@ end
 
 def print_atom(atom)#0
   char prstr[32]
+  var elemptr, d, i
 
   if not atom
     puts("NIL")
@@ -342,7 +388,7 @@ def print_atom(atom)#0
             puti32(atom + intval)
             break
           is NUM_FLOAT
-            puts(ext2str(atom + floatval, @prstr, 6, 4, FPSTR_FIXED|FPSTR_STRIP|FPSTR_FLEX))
+            puts(ext2str(atom + floatval, @prstr, fmt_fpint, fmt_fpfrac, fmt_fp))
             break
         wend
         break
@@ -351,6 +397,19 @@ def print_atom(atom)#0
         memcpy(@prstr + 1, atom + name, prstr)
         puts(@prstr)
         break;
+      is ARRAY_TYPE
+        elemptr = atom=>arraymem
+        for d = 3 downto 0
+          if atom=>dimension[d]
+            puts("[ ")
+            for i = 1 to atom=>dimension[d]
+              print_atom(*elemptr); putc(' ')
+              elemptr = elemptr + 2
+            next
+            puts("]\n")
+          fin
+        next
+        break
       otherwise
         puts("Unkown atom type\n")
     wend
@@ -615,7 +674,7 @@ export def eval_expr(expr)#1
       expr_car = expr=>car
       if expr_car->type & TYPE_MASK == SYM_TYPE
         if expr_car=>natv
-          expr = expr_car=>natv(expr=>cdr) // Native function
+          expr = expr_car=>natv(expr_car, expr=>cdr) // Native function
           break
         elsif expr_car=>lambda // DEFINEd lambda S-expression
           curl, expr = enter_lambda(curl, expr_car=>lambda, expr=>cdr)
@@ -638,7 +697,15 @@ export def eval_expr(expr)#1
       //
       // Atom
       //
-      if expr->type & TYPE_MASK == SYM_TYPE; expr = assoc(expr)=>cdr; fin
+      if expr->type & TYPE_MASK == SYM_TYPE
+        if expr=>apval
+          expr = expr=>apval
+        elsif expr=>array
+          expr = expr=>array
+        else
+          expr = assoc(expr)=>cdr
+        fin
+      fin
       break
     fin
   loop
@@ -651,77 +718,69 @@ end
 //
 
 export def bool_pred(bool)
-  return bool ?? @pred_true :: @pred_false
+  return bool ?? @pred_true :: @pred_nil
 end
 
-def natv_atom(expr)
-  var result
-
-  result = eval_expr(expr=>car)
-  return bool_pred(!result or result->type <> CONS_TYPE))
+def natv_atom(symptr, expr)
+  symptr = eval_expr(expr=>car)
+  return bool_pred(!symptr or symptr->type <> CONS_TYPE))
 end
 
-def natv_null(expr)
-  var result
-
-  result = eval_expr(expr=>car)
-  return bool_pred(!result or !result->type)
+def natv_null(symptr, expr)
+  symptr = eval_expr(expr=>car)
+  return bool_pred(!symptr or !symptr->type)
 end
 
-def natv_eq(expr)
+def natv_eq(symptr, expr)
   return bool_pred(eval_expr(expr=>car) == eval_expr(expr=>cdr=>car))
 end
 
-def natv_not(expr)
-  return bool_pred(eval_expr(expr=>car) == @pred_false)
+def natv_not(symptr, expr)
+  return bool_pred(eval_expr(expr=>car) == @pred_nil)
 end
 
-def natv_and(expr)
+def natv_and(symptr, expr)
   while (expr and eval_expr(expr=>car) == @pred_true)
     expr = expr=>cdr
   loop
   return bool_pred(!expr)
 end
 
-def natv_or(expr)
-  while (expr and eval_expr(expr=>car) == @pred_false)
+def natv_or(symptr, expr)
+  while (expr and eval_expr(expr=>car) == @pred_nil)
     expr = expr=>cdr
   loop
   return bool_pred(expr)
 end
 
-def natv_cons(expr)
-  var consptr
-
-  consptr = new_cons
-  consptr=>car = eval_expr(expr=>car)
-  consptr=>cdr = eval_expr(expr=>cdr=>car)
-  return consptr
+def natv_cons(symptr, expr)
+  symptr      = new_cons
+  symptr=>car = eval_expr(expr=>car)
+  symptr=>cdr = eval_expr(expr=>cdr=>car)
+  return symptr
 end
 
-def natv_car(expr)
+def natv_car(symptr, expr)
   return eval_expr(expr=>car)=>car
 end
 
-def natv_cdr(expr)
+def natv_cdr(symptr, expr)
   return eval_expr(expr=>car)=>cdr
 end
 
-def natv_quote(expr)
+def natv_quote(symptr, expr)
   return expr=>car
 end
 
-def natv_label(expr)
-  var valptr
-
-  valptr = expr=>cdr=>car
-  set_assoc(expr=>car, valptr)
-  return valptr
+def natv_label(symptr, expr)
+  symptr = expr=>cdr=>car
+  set_assoc(expr=>car, symptr)
+  return symptr
 end
 
-def natv_define(expr)
+def natv_define(symptr, expr)
 
-  var symptr, funclist, funcptr
+  var funclist, funcptr
 
   funclist = NULL
   if expr
@@ -734,14 +793,98 @@ def natv_define(expr)
     funcptr=>car   = symptr
     expr           = expr=>cdr
     if expr
-      funcptr=>cdr   = new_cons
-      funcptr        = funcptr=>cdr
+      funcptr=>cdr = new_cons
+      funcptr      = funcptr=>cdr
     fin
   loop
   return funclist
 end
 
-def natv_print(expr)
+def eval_index(arrayptr, expr)
+  var idx[4], ii, index
+
+  idx[0] = 0
+  idx[1] = 0
+  idx[2] = 0
+  idx[3] = 0
+  ii     = 0
+  while expr and ii < 4
+    index = eval_expr(expr=>car)
+    if index->type <> NUM_INT or isuge(index=>intval, arrayptr=>dimension[ii])
+      puts("Invalid array index: "); print_expr(expr=>car); putln
+      return NULL
+    fin
+    idx[ii] = index=>intval
+    expr    = expr=>cdr
+    ii++
+  loop
+  index = 0
+  while ii
+    ii--
+    index = idx[ii] + index * arrayptr=>dimension[ii])
+  loop
+  return arrayptr=>arraymem + index * 2
+end
+
+def natv_index(symptr, expr)
+  var elemptr
+
+  if expr=>car == sym_set
+    elemptr = eval_index(symptr=>array, expr=>cdr=>car)
+    if elemptr; *elemptr = eval_expr(expr=>cdr=>cdr=>car); fin
+  else
+    elemptr = eval_index(symptr=>array, expr=>car)
+  fin
+  return elemptr ?? *elemptr :: NULL
+end
+
+def natv_array(symptr, expr)
+  var arraylist, aptr
+  var idx_expr, idx[4], ii, index
+
+  arraylist = NULL
+  if expr
+    arraylist = new_cons
+    aptr      = arraylist
+  fin
+  while expr
+    symptr       = expr=>car=>car
+    symptr=>natv = @natv_index
+    idx_expr     = expr=>car=>cdr=>car
+    idx[0]       = 0
+    idx[1]       = 0
+    idx[2]       = 0
+    idx[3]       = 0
+    ii           = 0
+    while idx_expr and ii < 4
+      index = eval_expr(idx_expr=>car)
+      if index->type <> NUM_INT
+        puts("Invalid array dimension\n"); print_expr(idx_expr=>car); putln
+        return NULL
+      fin
+      idx[ii]  = index=>intval
+      idx_expr = idx_expr=>cdr
+      ii++
+    loop
+    symptr=>array = new_array(idx[0], idx[1], idx[2], idx[3])
+    aptr=>car     = symptr
+    expr          = expr=>cdr
+    if expr
+      aptr=>cdr   = new_cons
+      aptr        = aptr=>cdr
+    fin
+  loop
+  return arraylist
+end
+
+def natv_cset(symptr, expr)
+  symptr = eval_expr(expr=>cdr=>car)
+  expr=>car=>apval = symptr
+//  return symptr
+  return eval_expr(expr=>car)
+end
+
+def natv_print(symptr, expr)
   expr = eval_expr(expr=>car)
   print_expr(expr)
   putln
@@ -752,24 +895,27 @@ end
 // Install default functions
 //
 
-new_assoc(new_sym("NIL"), NULL)
-new_assoc(new_sym("T"),   @pred_true)
-new_assoc(new_sym("F"),   @pred_false)
+new_sym("NIL")=>apval = @pred_nil)
+new_sym("T")=>apval   = @pred_true)
+new_sym("F")=>apval   = @pred_nil)
 sym_lambda = new_sym("LAMBDA")
 sym_quote  = new_sym("QUOTE")
 sym_cond   = new_sym("COND")
+sym_set    = new_sym("SET")
 sym_quote=>natv         = @natv_quote
 new_sym("CAR")=>natv    = @natv_car
 new_sym("CDR")=>natv    = @natv_cdr
 new_sym("CONS")=>natv   = @natv_cons
 new_sym("ATOM")=>natv   = @natv_atom
 new_sym("EQ")=>natv     = @natv_eq
+new_sym("CSET")=>natv   = @natv_cset
 new_sym("NOT")=>natv    = @natv_not
 new_sym("AND")=>natv    = @natv_and
 new_sym("OR")=>natv     = @natv_or
 new_sym("NULL")=>natv   = @natv_null
 new_sym("LABEL")=>natv  = @natv_label
 new_sym("DEFINE")=>natv = @natv_define
+new_sym("ARRAY")=>natv  = @natv_array
 new_sym("PRINT")=>natv  = @natv_print
 return modkeep | modinitkeep
 done

src/lisp/s-math.pla

@@ -13,6 +13,7 @@ import sexpr
   const NUM_TYPE   = $30
   const NUM_INT    = $31
   const NUM_FLOAT  = $32
+  const ARRAY_TYPE = $40
   const MARK_BIT   = $80
   const MARK_MASK  = $7F
 
@@ -29,15 +30,17 @@ import sexpr
     res[t_elem]
     word natv
     word lambda
-    char[0] name
+    word array
+    word apval
+    char name[0]
   end
   struc t_numint
     res[t_elem]
-    word[2] intval
+    word intval[2]
   end
   struc t_numfloat
     res[t_elem]
-    res[t_fpureg] floatval
+    res floatval[10]
   end
 
   predef new_sym(symstr)#1
@@ -60,6 +63,20 @@ def eval_num(expr)
   return @nan
 end
 
+export def eval_int(expr)#1 // Always return an int
+  var result
+  var[2] int
+
+  result = eval_num(expr)
+  if result->type == NUM_FLOAT
+    fpu:pushExt(result + floatval)
+    fpu:pullInt(@int)
+    int[1] = int[0] < 0 ?? -1 :: 0
+    return new_int(int[0], int[1])
+  fin
+  return result
+end
+
 def push_int32(intptr)#0
   var[2] int
   byte isneg
@@ -97,7 +114,7 @@ def push_num(numptr)#0
   fin
 end
 
-def natv_add(expr)
+def natv_add(symptr, expr)
   var num
   var[2] intsum
   var[5] extsum
@@ -142,7 +159,7 @@ def natv_add(expr)
   return new_int(intsum[0], intsum[1])
 end
 
-def natv_sub(expr)
+def natv_sub(symptr, expr)
   var num1, num2
   var[2] dif
   var[5] ext
@@ -162,7 +179,7 @@ def natv_sub(expr)
   return new_float(@ext)
 end
 
-def natv_mul(expr)
+def natv_mul(symptr, expr)
   var num1, num2
   var[2] mul
   var[5] ext
@@ -182,7 +199,7 @@ def natv_mul(expr)
   return new_float(@ext)
 end
 
-def natv_div(expr)
+def natv_div(symptr, expr)
   var num1, num2
   var[2] div
   var[5] ext
@@ -202,7 +219,7 @@ def natv_div(expr)
   return new_float(@ext)
 end
 
-def natv_rem(expr)
+def natv_rem(symptr, expr)
   var num1, num2
   var[2] rem, div
   var[5] ext
@@ -221,7 +238,7 @@ def natv_rem(expr)
   return new_float(@ext)
 end
 
-def natv_neg(expr)
+def natv_neg(symptr, expr)
   var num
   var[2] neg
   var[5] ext
@@ -239,7 +256,7 @@ def natv_neg(expr)
   return new_float(@ext)
 end
 
-def natv_gt(expr)
+def natv_gt(symptr, expr)
   var num1, num2
   var[5] ext
 
@@ -256,7 +273,7 @@ def natv_gt(expr)
   return bool_pred(ext[4] < 0)
 end
 
-def natv_lt(expr)
+def natv_lt(symptr, expr)
   var num1, num2
   var[5] ext