Add source with reference counting. Super slow. Ouch

src/lisp/drawl.ref

@@ -0,0 +1,295 @@
+include "inc/cmdsys.plh"
+include "inc/args.plh"
+include "inc/fileio.plh"
+
+import sexpr
+  const TYPE_MASK  = $70
+  const NIL        = $00
+  const BOOL_FALSE = $00
+  const BOOL_TRUE  = $01
+  const CONS_TYPE  = $10
+  const SYM_TYPE   = $20
+  const SYM_LEN    = $0F
+  const NUM_TYPE   = $30
+  const NUM_INT    = $31
+  const NUM_FLOAT  = $32
+  const ARRAY_TYPE = $40
+
+  struc t_elem
+    word link
+    byte type
+    byte refcnt
+  end
+  struc t_cons
+    res[t_elem]
+    word car
+    word cdr
+  end
+  struc t_sym
+    res[t_elem]
+    word natv
+    word lambda
+    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 ref(expr)#1
+  predef deref(expr)#1
+  predef print_expr(expr)#1
+  predef parse_expr(evalptr, level, refill)#2
+  predef eval_expr(expr)#1
+  predef bool_pred(bool)#1
+  predef new_int(intlo, inthi)#1
+  predef new_sym(symstr)#1
+  predef new_assoc(symptr, valptr)#0
+  predef set_assoc(symptr, valptr)#0
+end
+
+import smath
+  predef eval_int(expr)#1
+end
+
+var prog, prog_expr, prog_return // Current PROG expressions
+var sym_cond, sym_fpint, sym_fpfrac
+var pred_true
+
+const FILEBUF_SIZE = 128
+var readfn                       // Read input routine
+var fileref, filebuf             // File read vars
+byte quit = FALSE                // Quit interpreter flag
+
+//
+// (PROG ...) language extension
+//
+
+def natv_prog(symptr, expr)
+  var prog_enter, prog_car, cond_expr
+
+  prog_expr  = expr=>cdr
+  prog       = prog_expr // Update current PROG expression
+  prog_enter = prog      // Save current prog
+  expr = expr=>car       // Set up local variables
+  while expr
+    new_assoc(expr=>car, NULL)
+    expr = expr=>cdr
+  loop
+  prog_return = NULL
+  while prog_expr and not prog_return
+    prog_car  = prog_expr=>car
+    prog_expr = prog_expr=>cdr // Assume continuation
+    if prog_car->type == CONS_TYPE
+      //
+      // List - check for (COND (...))
+      //
+      if prog_car=>car == sym_cond // Inline cond() evaluation
+        cond_expr = prog_car=>cdr
+        while cond_expr
+          if deref(eval_expr(cond_expr=>car=>car)) == pred_true
+            deref(eval_expr(cond_expr=>car=>cdr=>car)) // Drop result
+            break
+          fin
+          cond_expr = cond_expr=>cdr
+        loop
+      else
+        deref(eval_expr(prog_car)) // Drop result
+      fin
+    //else
+      //
+      // Atom - skip, i.e. (GO ) destination
+      //
+    fin
+  loop
+  prog = prog_enter
+  return eval_expr(prog_return)
+end
+
+def natv_return(symptr, expr)
+  prog_return = expr=>car
+  return NULL // This value will be dropped in natv_prog
+end
+
+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
+    symptr = symptr=>cdr
+  loop
+  puts("(GO ...) destination not found:"); print_expr(expr); putln
+  return NULL
+end
+
+def natv_set(symptr, expr)
+  symptr = eval_expr(expr=>cdr=>car)
+  set_assoc(deref(eval_expr(expr=>car)), symptr)
+  return ref(symptr)
+end
+
+def natv_setq(symptr, expr)
+  symptr = eval_expr(expr=>cdr=>car)
+  set_assoc(expr=>car, symptr)
+  return ref(symptr)
+end
+
+//
+// REPL native helper functions
+//
+
+def natv_fpint(symptr, expr)
+  var fmt
+
+  fmt_fpint = eval_int(expr)=>intval
+  deref(expr)
+  fmt = new_int(fmt_fpint,  0)
+  set_assoc(sym_fpint, fmt)
+  return fmt
+end
+
+def natv_fpfrac(symptr, expr)
+  var fmt
+
+  fmt_fpfrac = eval_int(expr)=>intval
+  deref(expr)
+  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 ref(new_sym("GOODBYE!")) // (QUOTE GOODBYE!)
+end
+
+//
+// Keyboard and file input routines
+//
+
+def refill_keybd
+  var readline
+
+  repeat
+    readline = gets('>'|$80)
+    ^(readline + ^readline + 1) = 0
+  until ^readline
+  return readline + 1
+end
+
+def read_keybd
+  var readline, expr
+
+  repeat
+    readline = gets('?'|$80)
+    ^(readline + ^readline + 1) = 0
+  until ^readline
+  drop, expr = parse_expr(readline + 1, 0, @refill_keybd)
+  //print_expr(expr); putln // DEBUG - print parsed expression
+  return expr
+end
+
+def read_fileline
+  var len
+
+  repeat
+    len = fileio:read(fileref, filebuf, FILEBUF_SIZE-1)
+    if len
+      if ^(filebuf + len - 1) == $0D
+        len-- // Remove trailing carriage return
+      fin
+      ^(filebuf + len) = 0 // NULL terminate
+    else
+      fileio:close(fileref)
+      readfn = @read_keybd
+      return FALSE
+    fin
+  until len
+  return TRUE
+end
+
+def refill_file
+  if not read_fileline
+    puts("File input prematurely ended\n")
+    return refill_keybd
+  fin
+  return filebuf
+end
+
+def read_file
+  var expr
+
+  if not read_fileline
+    return read_keybd
+  fin
+  drop, expr = parse_expr(filebuf, 0, @refill_file)
+  return expr
+end
+
+//
+// Handle command line options
+//
+
+def parse_cmdline#0
+  var filename
+
+  readfn = @read_keybd
+  filename = argNext(argFirst)
+  if ^filename
+    fileref = fileio:open(filename)
+    if fileref
+      fileio:newline(fileref, $7F, $0D)
+      readfn = @read_file
+      filebuf = heapalloc(FILEBUF_SIZE)
+    else
+      puts("Unable to open: "); puts(filename); putln
+    fin
+  fin
+end
+
+//
+// REPL
+//
+
+def rep#0
+  var expr, eval
+
+  expr = readfn()
+  eval = eval_expr(expr)
+  deref(print_expr(eval)); putln
+  if eval and eval <> expr; deref(expr); fin
+end
+
+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("MEM")=>natv    = @natv_memavail
+new_sym("BYE")=>natv    = @natv_bye
+
+parse_cmdline
+while not quit; rep; loop
+putln
+done

src/lisp/s-expr.ref

@@ -0,0 +1,979 @@
+include "inc/cmdsys.plh"
+include "inc/int32.plh"
+include "inc/fpstr.plh"
+
+const TYPE_MASK  = $70
+const NIL        = $00
+const BOOL_FALSE = $00
+const BOOL_TRUE  = $01
+const CONS_TYPE  = $10
+const SYM_TYPE   = $20
+const SYM_LEN    = $0F
+const NUM_TYPE   = $30
+const NUM_INT    = $31
+const NUM_FLOAT  = $32
+const ARRAY_TYPE = $40
+const NULL_HACK  = 1  // Hack so we can set elements to NULL
+
+struc t_elem
+  word link
+  byte type
+  byte refcnt
+end
+struc t_cons
+  res[t_elem]
+  word car
+  word cdr
+end
+struc t_sym
+  res[t_elem]
+  word natv
+  word lambda
+  word array
+  word apval
+  char name[0]
+end
+struc t_array
+  res[t_elem]
+  word dimension[4]
+  word offset[4]
+  word arraymem
+end
+struc t_numint
+  res[t_elem]
+  word intval[2]
+end
+struc t_numfloat
+  res[t_elem]
+  res floatval[10]
+end
+
+predef eval_expr(expr)#1
+predef print_expr(expr)#1
+
+var sym_nil, sym_quote, sym_lambda, sym_cond, sym_set
+res[t_elem] pred_true  = 0, 0, BOOL_TRUE, 1
+
+var sym_list   = NULL
+var cons_free  = NULL
+var int_free   = NULL
+var float_free = 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
+
+//
+// Reference manager
+//
+
+export def ref(expr)#1
+  var refexpr
+
+  puts("REF:"); print_expr(expr); putln
+  refexpr = expr
+  while expr
+    if expr->refcnt == 255; puts("Ref overflow:"); print_expr(expr); putln; return refexpr; fin
+    expr->refcnt++
+    if expr->type == CONS_TYPE
+      ref(expr=>car)
+      expr = expr=>cdr
+    else
+      return refexpr
+    fin
+  loop
+  return refexpr
+end
+
+export def deref(expr)#1
+  var refexpr, expr_next
+
+  puts("DEREF:"); print_expr(expr); putln
+  refexpr = expr
+  while expr
+    expr_next = NULL
+    if expr->refcnt == 0; puts("Ref underflow:"); print_expr(expr); putln; return NULL; fin
+    if expr->type == CONS_TYPE
+      deref(expr=>car)
+      expr_next = expr=>cdr
+    fin
+    expr->refcnt--
+    if expr->refcnt == 0
+      when expr->type
+        is CONS_TYPE
+          //puts("Free CONS\n")
+          expr=>link = cons_free
+          cons_free  = expr
+          break
+        is NUM_INT
+          //puts("Free INT:"); print_expr(expr); putln
+          expr=>link = int_free
+          int_free   = expr
+          break
+        is NUM_FLOAT
+          //puts("Free FLOAT:"); print_expr(expr); putln
+          expr=>link  = float_free
+          float_free  = expr
+          break
+        otherwise
+          // Do nothing
+          puts("0 ref count:"); print_expr(expr); putln
+      wend
+    fin
+    expr = expr_next
+  loop
+  return refexpr
+end
+
+//
+// Build ATOMS
+//
+
+export def new_cons#1
+  var consptr
+
+  if cons_free
+    consptr   = cons_free
+    cons_free = cons_free=>link
+  else
+    consptr = heapalloc(t_cons)
+  fin
+  consptr->type   = CONS_TYPE
+  consptr->refcnt = 1
+  consptr=>car    = NULL
+  consptr=>cdr    = NULL
+  return consptr
+end
+
+export def new_int(intlo, inthi)#1
+  var intptr
+
+  if int_free
+    intptr   = int_free
+    int_free = int_free=>link
+  else
+    intptr = heapalloc(t_numint)
+  fin
+  intptr->type      = NUM_INT
+  intptr->refcnt    = 1
+  intptr=>intval[0] = intlo
+  intptr=>intval[1] = inthi
+  return intptr
+end
+
+export def new_float(extptr)#1
+  var floatptr
+
+  if float_free
+    floatptr   = float_free
+    float_free = float_free=>link
+  else
+    floatptr = heapalloc(t_numfloat)
+  fin
+  floatptr->type   = NUM_FLOAT
+  floatptr->refcnt = 1
+  memcpy(floatptr + floatval, extptr, 10)
+  return floatptr
+end
+
+def new_array(dim0, dim1, dim2, dim3)
+  var ofst0, ofst1, ofst2, ofst3
+  var size, aptr, memptr
+
+  if dim3
+    ofst3 = 2
+    ofst2 = dim3  * 2
+    ofst1 = ofst2 * dim2
+    ofst0 = ofst1 * dim1
+  elsif dim2
+    ofst2 = 2
+    ofst1 = dim2 * 2
+    ofst0 = ofst1 * dim1
+  elsif dim1
+    ofst1 = 2
+    ofst0 = dim1 * 2
+  else
+    ofst0 = 2
+  fin
+  size = dim0 * ofst0
+  memptr = heapalloc(size)
+  if not memptr
+    puts("Array too large!\n")
+    return NULL
+  fin
+  memset(memptr, NULL, size)
+  aptr               = heapalloc(t_array)
+  aptr->type         = ARRAY_TYPE
+  aptr->refcnt       = 1
+  aptr=>dimension[0] = dim0
+  aptr=>dimension[1] = dim1
+  aptr=>dimension[2] = dim2
+  aptr=>dimension[3] = dim3
+  aptr=>offset[0]    = ofst0
+  aptr=>offset[1]    = ofst1
+  aptr=>offset[2]    = ofst2
+  aptr=>offset[3]    = ofst3
+  aptr=>arraymem     = memptr
+  return aptr
+end
+
+def match_sym(symstr)
+  var symptr
+  byte len, typelen, i
+
+  len     = ^symstr
+  typelen = SYM_TYPE | len
+  len--; symstr++
+  symptr  = sym_list
+  while symptr
+    if symptr->type == typelen
+      for i = 0 to len
+        if symptr->name[i] <> symstr->[i]; break; fin
+      next
+      if i > len
+        symptr->refcnt++
+        return symptr
+      fin
+    fin
+    symptr = symptr=>link
+  loop
+  return NULL
+end
+
+export def new_sym(symstr)#1
+  var symptr
+
+  symptr = match_sym(symstr)
+  if symptr; return symptr; fin // Return already existing symbol
+  symptr         = heapalloc(t_sym + ^symstr)
+  symptr=>link   = sym_list
+  sym_list       = symptr
+  symptr->type   = ^symstr | SYM_TYPE
+  symptr->refcnt = 1
+  symptr=>natv   = NULL
+  symptr=>lambda = NULL
+  symptr=>array  = NULL
+  symptr=>apval  = NULL
+  memcpy(symptr + name, symstr + 1, ^symstr)
+  return symptr
+end
+
+//
+// Build/set association between symbols and values
+//
+
+def assoc_pair(symptr)
+  var pair
+
+  if symptr->type & TYPE_MASK == SYM_TYPE
+    //
+    // Search association list for symbol
+    //
+    pair = assoc_list
+    while pair
+      if (pair=>car=>car == symptr)
+        return pair=>car
+      fin
+      pair = pair=>cdr
+    loop
+  fin
+  return NULL // SYM not associated
+end
+
+def assoc(symptr)
+  var pair
+
+  pair = assoc_pair(symptr)
+  return pair ?? pair=>cdr :: NULL
+end
+
+
+export def new_assoc(symptr, valptr)#0
+  var pair, addlist
+
+  if symptr and (symptr->type & TYPE_MASK <> SYM_TYPE)
+    puts("Not a SYM in new_assoc\n")
+    return
+  fin
+  pair         = new_cons
+  pair=>car    = ref(symptr)
+  pair=>cdr    = ref(valptr)
+  if assoc_list // Add to end of assoc_list
+    addlist = assoc_list
+    while addlist=>cdr
+      addlist = addlist=>cdr
+    loop
+    addlist=>cdr = new_cons
+    addlist      = addlist=>cdr
+  else // New list
+    assoc_list = new_cons
+    addlist    = assoc_list
+  fin
+  addlist=>car = pair
+end
+
+export def set_assoc(symptr, valptr)#0
+  var pair
+
+  //
+  // Search association list for symbol
+  //
+  pair = assoc_pair(symptr)
+  if pair
+    ref(valptr)
+    deref(pair=>cdr)
+    pair=>cdr = valptr // update association
+  else
+    new_assoc(symptr, valptr) // add association if unknown
+  fin
+end
+
+//
+// Print textual representation of S-expression
+//
+
+def print_atom(atom)#0
+  char prstr[32]
+  var elemptr, i, j, k, l
+
+  if not atom
+    puts("NIL")
+  else
+    when atom->type & TYPE_MASK
+      is NIL
+        putc(atom->type ?? 'T' :: 'F')
+        break
+      is NUM_TYPE
+        when atom->type
+          is NUM_INT
+            if atom=>intval[1] >= 0; putc(' '); fin // Add space for pos
+            puti32(atom + intval)
+            break
+          is NUM_FLOAT
+            puts(ext2str(atom + floatval, @prstr, fmt_fpint, fmt_fpfrac, fmt_fp))
+            break
+        wend
+        break
+      is SYM_TYPE
+        prstr = atom->type & SYM_LEN
+        memcpy(@prstr + 1, atom + name, prstr)
+        puts(@prstr)
+        break;
+      is ARRAY_TYPE
+        elemptr = atom=>arraymem
+        puts("[ ")
+        for i = 1 to atom=>dimension[0]
+          if atom=>dimension[1]
+            puts("\n[ ")
+            for j = 1 to atom=>dimension[1]
+              if atom=>dimension[2]
+                puts("\n[ ")
+                for k = 1 to atom=>dimension[2]
+                  if atom=>dimension[3]
+                    puts("\n[ ")
+                    for l = 1 to atom=>dimension[3]
+                      print_atom(*elemptr); putc(' ')
+                      elemptr = elemptr + 2
+                    next
+                    puts("]")
+                  else
+                    print_atom(*elemptr); putc(' ')
+                    elemptr = elemptr + 2
+                  fin
+                next
+                puts("]")
+              else
+                print_atom(*elemptr); putc(' ')
+                elemptr = elemptr + 2
+              fin
+            next
+            puts("]")
+          else
+            print_atom(*elemptr); putc(' ')
+            elemptr = elemptr + 2
+          fin
+        next
+        puts("]\n")
+        break
+      otherwise
+        puts("Unkown atom type\n")
+    wend
+  fin
+end
+
+export def print_expr(expr)#1
+  var prexpr
+
+  prexpr = expr
+  if not expr
+    puts("NIL")
+  else
+    if expr->type == CONS_TYPE
+      putc('(')
+      while expr and expr->type == CONS_TYPE
+        print_expr(expr=>car)
+        expr = expr=>cdr
+        if expr
+          if expr->type <> CONS_TYPE
+            putc('.')
+            print_atom(expr)
+            expr = NULL
+          else
+            putc(' ')
+          fin
+        fin
+      loop
+      putc(')')
+    else
+      print_atom(expr)
+    fin
+  fin
+  return prexpr
+end
+
+//
+// Parse textual representation of S-expression
+//
+
+def is_num(cptr)
+  if ^cptr == '-' or ^cptr == '+'; cptr++; fin
+  return ^cptr >= '0' and ^cptr <= '9'
+end
+
+def is_alphasym(c)
+  return (c >= '*' and c <= 'z') and (c <> '.') and (c <> ',')
+end
+
+def parse_num(evalptr)#2 // return evalptr, intptr
+  var startptr
+  var int[2], ext[5]
+  byte sign
+
+  sign = FALSE
+  if ^evalptr == '-'
+    sign = TRUE
+    evalptr++
+  elsif ^evalptr == '+'
+    evalptr++
+  fin
+  startptr = evalptr
+  while ^evalptr >= '0' and ^evalptr <= '9'
+    evalptr++
+  loop
+  if (evalptr - startptr > 10) or ^evalptr == '.' or toupper(^evalptr) == 'E'
+    if ^evalptr == '.'
+      evalptr++
+      while ^evalptr >= '0' and ^evalptr <= '9'
+        evalptr++
+      loop
+    fin
+    if toupper(^evalptr) == 'E'
+      evalptr++
+      if ^evalptr == '-' or ^evalptr == '+'; evalptr++; fin
+      while ^evalptr >= '0' and ^evalptr <= '9'
+        evalptr++
+      loop
+    fin
+    if sign; startptr--; fin
+    ^(startptr - 1) = evalptr - startptr
+    str2ext(startptr - 1, @ext)
+    return evalptr, new_float(@ext)
+  fin
+  zero32
+  while startptr <> evalptr
+    muli16(10); addi16(^startptr - '0')
+    startptr++
+  loop
+  if sign; neg32; fin
+  store32(@int)
+  return evalptr, new_int(int[0], int[1])
+end
+
+def parse_sym(evalptr)#2 // return evalptr, symptr
+  var symstr
+
+  symstr = evalptr - 1
+  while is_alphasym(^evalptr)
+    ^evalptr = toupper(^evalptr)
+    evalptr++
+  loop
+  ^symstr = evalptr - symstr - 1
+  if ^symstr > 31; ^symstr = 31; fin
+  return evalptr, new_sym(symstr)
+end
+
+export def parse_expr(evalptr, level, refill)#2 // return evalptr, exprptr
+  var exprptr, consptr, elemptr, quotecons
+
+  exprptr = NULL
+  consptr = NULL
+  while TRUE
+    //
+    // Parse textual S-expression
+    //
+    elemptr = NULL
+    when ^evalptr
+      is 0
+        if level
+          evalptr = refill() // Refill input buffer
+        else
+          return evalptr, exprptr
+        fin
+        break
+      is ' '
+      is ','
+        evalptr++
+        break
+      is ')'
+        if not exprptr
+          exprptr = ref(sym_nil)
+        fin
+        return evalptr + 1, exprptr
+      is '('
+        evalptr++
+        if level == 0
+          level++
+        else
+          evalptr, elemptr = parse_expr(evalptr, 1, refill)
+        fin
+        break
+      is '\''
+        evalptr++
+        evalptr, elemptr    = parse_expr(evalptr, 0, refill)
+        quotecons           = new_cons
+        quotecons=>car      = ref(sym_quote)
+        quotecons=>cdr      = new_cons
+        quotecons=>cdr=>car = elemptr
+        elemptr             = quotecons
+        if level == 0
+          return evalptr, elemptr
+        fin
+        break
+      is '.'
+        evalptr++
+        evalptr, elemptr = parse_expr(evalptr, 0, refill)
+        //
+        // Add expression to CDR
+        //
+        if not (consptr and consptr=>car)
+          puts("Invalid . operator\n")
+          return evalptr, exprptr
+        fin
+        consptr=>cdr = elemptr
+        elemptr = NULL
+        break
+      otherwise
+        if is_num(evalptr)
+          evalptr, elemptr = parse_num(evalptr)
+        elsif is_alphasym(^evalptr)
+          evalptr, elemptr = parse_sym(evalptr)
+        else
+          putc('\\')
+          putc(^evalptr)
+          evalptr++
+        fin
+        if level == 0
+          return evalptr, elemptr
+        fin
+    wend
+    if elemptr
+      //
+      // Add element to S-expression
+      //
+      if not consptr
+        consptr = new_cons
+        exprptr = consptr
+      else
+        if consptr=>cdr
+          puts("Improperly formed .\n")
+          return evalptr, exprptr
+        fin
+        consptr=>cdr = new_cons
+        consptr      = consptr=>cdr
+      fin
+      //
+      // Add element to CAR
+      //
+      consptr=>car = elemptr
+    fin
+  loop
+  return evalptr, exprptr
+end
+
+//
+// Evaluate expression
+//
+
+def enter_lambda(curl, expr, params)#2 // curl, expr
+  var args, arglist, pairlist, pair
+
+  if !expr or expr=>car <> sym_lambda
+    puts("Invalid LAMBDA expression: ")
+    print_expr(expr)
+    return NULL, NULL
+  fin
+  args = expr=>cdr=>car
+  if curl == expr
+    //
+    // Update current associations during tail recursion
+    //
+    while args
+      pair      = assoc_pair(args=>car)
+      arglist   = pair=>cdr
+      pair=>cdr = eval_expr(params=>car)
+      deref(arglist)
+      args   = args=>cdr
+      params = params=>cdr
+    loop
+  else
+    //
+    // Build arg list before prepending to assoc_list
+    //
+    arglist = NULL
+    while args
+      if arglist
+        pairlist=>cdr = new_cons
+        pairlist      = pairlist=>cdr
+      else
+        arglist  = new_cons
+        pairlist = arglist
+      fin
+      pair          = new_cons
+      pair=>car     = ref(args=>car)
+      pair=>cdr     = eval_expr(params=>car)
+      pairlist=>car = pair
+      args          = args=>cdr
+      params        = params=>cdr
+    loop
+    if arglist
+      pairlist=>cdr = assoc_list
+      assoc_list    = arglist
+    fin
+  fin
+  return expr, expr=>cdr=>cdr=>car
+end
+
+def exit_lambda(alist)#0
+  var args
+
+  if alist <> assoc_list
+    args = assoc_list
+    while args=>cdr <> alist
+      args = args=>cdr
+    loop
+    args=>cdr = NULL
+    deref(assoc_list)
+    assoc_list = alist
+  fin
+end
+
+export def eval_expr(expr)#1
+  var alist_enter, curl, expr_car
+
+  curl        = NULL // Current lambda
+  alist_enter = assoc_list
+  while expr
+    if expr->type == CONS_TYPE
+      //
+      // List - first element better be a function
+      //
+      expr_car = expr=>car
+      if expr_car->type & TYPE_MASK == SYM_TYPE
+        if expr_car=>natv
+          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)
+        elsif expr_car == sym_cond // Inline cond() evaluation
+          expr = expr=>cdr
+          while expr
+            if deref(eval_expr(expr=>car=>car)) == @pred_true
+              expr = expr=>car=>cdr=>car
+              break
+            fin
+            expr = expr=>cdr
+          loop
+        else // Symbol associated with lambda
+          curl, expr = enter_lambda(curl, assoc(expr_car), expr=>cdr)
+        fin
+      elsif expr_car->type == CONS_TYPE and expr_car=>car == sym_lambda
+          curl, expr = enter_lambda(NULL, expr_car, expr=>cdr) // Inline lambda
+      fin
+    else
+      //
+      // Atom
+      //
+      if expr->type & TYPE_MASK == SYM_TYPE
+        if expr=>apval
+          expr = expr=>apval ^ NULL_HACK
+        elsif expr=>array
+          expr = expr=>array
+        else
+          expr = assoc(expr)
+        fin
+      fin
+      ref(expr)
+      break
+    fin
+  loop
+  if curl; exit_lambda(alist_enter); fin
+  return expr
+end
+
+//
+// Base native functions
+//
+
+export def bool_pred(bool)
+  return bool ?? ref(@pred_true) :: NULL
+end
+
+def natv_atom(symptr, expr)
+  symptr = deref(eval_expr(expr=>car))
+  return bool_pred(!symptr or symptr->type <> CONS_TYPE))
+end
+
+def natv_null(symptr, expr)
+  return bool_pred(!deref(eval_expr(expr=>car)))
+end
+
+def natv_eq(symptr, expr)
+  byte iseq, i
+
+  iseq   = FALSE
+  symptr = eval_expr(expr=>car)
+  expr   = eval_expr(expr=>cdr=>car)
+  if symptr == expr
+    iseq = TRUE
+  elsif symptr->type == NUM_INT and expr->type == NUM_INT
+    iseq = symptr=>intval[0] == expr=>intval[0]
+    if iseq
+      iseq = symptr=>intval[1] == expr=>intval[1]
+    fin
+  elsif symptr->type == NUM_FLOAT and expr->type == NUM_FLOAT
+    iseq = TRUE
+    for i = 0 to 9
+      if symptr->floatval[i] <> expr->floatval[i]
+        iseq = FALSE
+        break
+      fin
+    next
+  fin
+  deref(symptr)
+  deref(expr)
+  return bool_pred(iseq)
+end
+
+def natv_and(symptr, expr)
+  while expr
+    symptr = eval_expr(expr=>car)
+    if !symptr; return NULL; fin
+    deref(symptr)
+    expr = expr=>cdr
+  loop
+  return ref(@pred_true)
+end
+
+def natv_or(symptr, expr)
+  while expr
+    symptr = deref(eval_expr(expr=>car))
+    if symptr; return ref(@pred_true); fin
+    expr = expr=>cdr
+  loop
+  return NULL
+end
+
+def natv_cons(symptr, expr)
+  symptr      = ref(new_cons)
+  symptr=>car = eval_expr(expr=>car)
+  symptr=>cdr = eval_expr(expr=>cdr=>car)
+  return symptr
+end
+
+def natv_car(symptr, expr)
+  return eval_expr(expr=>car)=>car
+end
+
+def natv_cdr(symptr, expr)
+  return eval_expr(expr=>car)=>cdr
+end
+
+def natv_quote(symptr, expr)
+  return ref(expr=>car)
+end
+
+def natv_label(symptr, expr)
+  symptr = expr=>cdr=>car
+  set_assoc(expr=>car, symptr)
+  return ref(symptr)
+end
+
+def natv_define(symptr, expr)
+
+  var funclist, funcptr
+
+  funclist = NULL
+  if expr
+    funclist = new_cons
+    funcptr  = funclist
+  fin
+  while expr
+    symptr         = expr=>car=>car
+    deref(symptr=>lambda)
+    symptr=>lambda = expr=>car=>cdr=>car
+    ref(symptr=>lambda)
+    funcptr=>car   = symptr
+    expr           = expr=>cdr
+    if expr
+      funcptr=>cdr = new_cons
+      funcptr      = funcptr=>cdr
+    fin
+  loop
+  return ref(funclist)
+end
+
+def eval_index(arrayptr, expr)
+  var idx[4], i, ii, index
+
+  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
+      deref(index)
+      return NULL
+    fin
+    idx[ii] = index=>intval
+    deref(index)
+    expr    = expr=>cdr
+    ii++
+  loop
+  index = 0
+  while ii
+    ii--
+    index = index + idx[ii] * arrayptr=>offset[ii]
+  loop
+  return arrayptr=>arraymem + index
+end
+
+def natv_index(symptr, expr)
+  var elemptr
+
+  if expr=>car == sym_set
+    elemptr = eval_index(symptr=>array, expr=>cdr=>cdr)
+    if elemptr; *elemptr = eval_expr(expr=>cdr=>car); fin
+  else
+    elemptr = eval_index(symptr=>array, expr)
+  fin
+  return elemptr ?? ref(*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
+        deref(index)
+        return NULL
+      fin
+      idx[ii] = index=>intval
+      deref(index)
+      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 ref(arraylist)
+end
+
+def natv_cset(symptr, expr)
+  symptr = deref(eval_expr(expr=>car))
+  if symptr->type & TYPE_MASK <> SYM_TYPE
+    puts("CSET: Not a SYM\n")
+    return NULL
+  fin
+  if symptr=>apval
+    puts("Constant already set:"); print_expr(symptr); putln
+    return NULL
+  fin
+  expr          = eval_expr(expr=>cdr=>car)
+  symptr=>apval = expr ^ NULL_HACK
+  return ref(expr)
+end
+
+def natv_csetq(symptr, expr)
+  symptr = expr=>car
+  if symptr->type & TYPE_MASK <> SYM_TYPE
+    puts("CSETQ: Not a SYM\n")
+    return NULL
+  fin
+  if symptr=>apval
+    puts("Constant already set:"); print_expr(symptr); putln
+    return NULL
+  fin
+  expr          = eval_expr(expr=>cdr=>car)
+  symptr=>apval = expr ^ NULL_HACK
+  return ref(expr)
+end
+
+def natv_print(symptr, expr)
+  expr = eval_expr(expr=>car)
+  print_expr(expr)
+  putln
+  return expr
+end
+
+//
+// Install default functions
+//
+
+new_sym("T")=>apval     = @pred_true ^ NULL_HACK
+new_sym("F")=>apval     = NULL_HACK
+sym_nil                 = new_sym("NIL")
+sym_nil=>apval          = NULL_HACK
+sym_lambda              = new_sym("LAMBDA")
+sym_cond                = new_sym("COND")
+sym_set                 = new_sym("SET")
+sym_quote               = new_sym("QUOTE")
+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("CSETQ")=>natv  = @natv_csetq
+new_sym("NOT")=>natv    = @natv_null
+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.ref

@@ -0,0 +1,342 @@
+include "inc/cmdsys.plh"
+include "inc/int32.plh"
+include "inc/fpu.plh"
+
+import sexpr
+  const TYPE_MASK  = $70
+  const NIL        = $00
+  const BOOL_FALSE = $00
+  const BOOL_TRUE  = $01
+  const CONS_TYPE  = $10
+  const SYM_TYPE   = $20
+  const SYM_LEN    = $0F
+  const NUM_TYPE   = $30
+  const NUM_INT    = $31
+  const NUM_FLOAT  = $32
+  const ARRAY_TYPE = $40
+
+  struc t_elem
+    word link
+    byte type
+    byte refcnt
+  end
+  struc t_cons
+    res[t_elem]
+    word car
+    word cdr
+  end
+  struc t_sym
+    res[t_elem]
+    word natv
+    word lambda
+    word array
+    word apval
+    char name[0]
+  end
+  struc t_numint
+    res[t_elem]
+    word intval[2]
+  end
+  struc t_numfloat
+    res[t_elem]
+    res floatval[10]
+  end
+
+  predef ref(expr)#1
+  predef deref(expr)#1
+  predef new_sym(symstr)#1
+  predef new_int(intlo, inthi)#1
+  predef new_float(extptr)#1
+  predef eval_expr(expr)#1
+  predef bool_pred(bool)#1
+end
+
+res[t_numint] nan = 0, 0, NUM_INT, 0, 0, 0, 128 // NaN
+
+def eval_num(expr)
+  var result
+
+  result = eval_expr(expr=>car)
+  if result and (result->type & TYPE_MASK == NUM_TYPE)
+    return result
+  fin
+  puts("Not an number\n")
+  deref(result)
+  return NULL
+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)
+    deref(result)
+    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
+
+  isneg  = FALSE
+  if intptr=>[1] < 0
+    load32(intptr)
+    isneg = TRUE
+    neg32
+    store32(@int)
+  else
+    int[0] = intptr=>[0]
+    int[1] = intptr=>[1]
+  fin
+  fpu:pushInt(@int[1])
+  fpu:scalebXInt(16)
+  fpu:pushInt(@int[0])
+  fpu:addXY()
+  if isneg
+    fpu:negX()
+  fin
+end
+
+def push_num(numptr)#0
+  var int
+
+  if numptr->type == NUM_FLOAT
+    fpu:pushExt(numptr + floatval)
+  elsif numptr->type == NUM_INT
+    push_int32(numptr + intval)
+  else
+    puts("Pushing non number!\n")
+    int = 0
+    fpu:pushInt(@int)
+  fin
+end
+
+def natv_add(symptr, expr)
+  var num
+  var[2] intsum
+  var[5] extsum
+
+  intsum[0] = 0
+  intsum[1] = 0
+  num       = eval_num(expr)
+  expr      = expr=>cdr
+  if num->type == NUM_INT
+    //
+    // Sum as integers unless a float is encountered
+    //
+    intsum[0] = num=>intval[0]
+    intsum[1] = num=>intval[1]
+    deref(num)
+    while expr
+      num  = eval_num(expr)
+      expr = expr=>cdr
+      if num->type == NUM_FLOAT
+        break
+      fin
+      load32(@intsum)
+      add32(num + intval)
+      store32(@intsum)
+      deref(num)
+    loop
+  fin
+  if num->type == NUM_FLOAT
+    //
+    // Sum as floating point numbers
+    //
+    push_int32(@intsum)
+    push_num(num)
+    fpu:addXY()
+    deref(num)
+    while expr
+      num = eval_num(expr)
+      push_num(num)
+      fpu:addXY()
+      deref(num)
+      expr = expr=>cdr
+    loop
+    fpu:pullExt(@extsum)
+    return new_float(@extsum)
+  fin
+  return new_int(intsum[0], intsum[1])
+end
+
+def natv_sub(symptr, expr)
+  var num1, num2
+  var[2] dif
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    sub32(num2 + intval)
+    store32(@dif)
+    deref(num1)
+    deref(num2)
+    return new_int(dif[0], dif[1])
+  fin
+  push_num(num1)
+  push_num(num2)
+  fpu:subXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return new_float(@ext)
+end
+
+def natv_mul(symptr, expr)
+  var num1, num2
+  var[2] mul
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    mul32(num2 + intval)
+    store32(@mul)
+    deref(num1)
+    deref(num2)
+    return new_int(mul[0], mul[1])
+  fin
+  push_num(num1)
+  push_num(num2)
+  fpu:mulXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return new_float(@ext)
+end
+
+def natv_div(symptr, expr)
+  var num1, num2
+  var[2] div
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    div32(num2 + intval)
+    store32(@div)
+    deref(num1)
+    deref(num2)
+    return new_int(div[0], div[1])
+  fin
+  push_num(num1)
+  push_num(num2)
+  fpu:divXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return new_float(@ext)
+end
+
+def natv_rem(symptr, expr)
+  var num1, num2
+  var[2] rem, div
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    rem[1], rem[0] = div32(num2 + intval)
+    deref(num1)
+    deref(num2)
+    return new_int(rem[0], rem[1])
+  fin
+  push_num(num1)
+  push_num(num2)
+  fpu:remXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return new_float(@ext)
+end
+
+def natv_neg(symptr, expr)
+  var num
+  var[2] neg
+  var[5] ext
+
+  num = ref(eval_num(expr))
+  if num=>type == NUM_INT
+    load32(num + intval)
+    deref(num)
+    neg32
+    store32(@neg)
+    return new_int(neg[0], neg[1])
+  fin
+  push_num(num)
+  fpu:negX()
+  fpu:pullExt(@ext)
+  deref(num)
+  return new_float(@ext)
+end
+
+def natv_gt(symptr, expr)
+  var num1, num2, bool
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    bool = isgt32(num2 + intval)
+    deref(num1)
+    deref(num2)
+    return bool_pred(bool)
+  fin
+  push_num(num2)
+  push_num(num1)
+  fpu:subXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return bool_pred(ext[4] < 0)
+end
+
+def natv_lt(symptr, expr)
+  var num1, num2, bool
+  var[5] ext
+
+  num1 = eval_num(expr)
+  num2 = eval_num(expr=>cdr)
+  if num1->type == NUM_INT and num2->type == NUM_INT
+    load32(num1 + intval)
+    bool = islt32(num2 + intval)
+    deref(num1)
+    deref(num2)
+    return bool_pred(bool)
+  fin
+  push_num(num1)
+  push_num(num2)
+  fpu:subXY()
+  fpu:pullExt(@ext)
+  deref(num1)
+  deref(num2)
+  return bool_pred(ext[4] < 0)
+end
+
+//
+// Install math functions
+//
+
+new_sym("+")=>natv      = @natv_add
+new_sym("-")=>natv      = @natv_sub
+new_sym("*")=>natv      = @natv_mul
+new_sym("/")=>natv      = @natv_div
+new_sym("REM")=>natv    = @natv_rem
+new_sym("NEG")=>natv    = @natv_neg
+new_sym(">")=>natv      = @natv_gt
+new_sym("<")=>natv      = @natv_lt
+fpu:reset()
+return modkeep | modinitkeep
+done