From 713b6ea7fa200067f8afce5ba3e4f30217e1593d Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Mon, 15 Jul 2024 09:01:10 -0700 Subject: [PATCH] Add source with reference counting. Super slow. Ouch --- src/lisp/drawl.ref | 295 +++++++++++++ src/lisp/s-expr.ref | 979 ++++++++++++++++++++++++++++++++++++++++++++ src/lisp/s-math.ref | 342 ++++++++++++++++ 3 files changed, 1616 insertions(+) create mode 100644 src/lisp/drawl.ref create mode 100644 src/lisp/s-expr.ref create mode 100644 src/lisp/s-math.ref diff --git a/src/lisp/drawl.ref b/src/lisp/drawl.ref new file mode 100644 index 0000000..14d0156 --- /dev/null +++ b/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 diff --git a/src/lisp/s-expr.ref b/src/lisp/s-expr.ref new file mode 100644 index 0000000..c5e0565 --- /dev/null +++ b/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 diff --git a/src/lisp/s-math.ref b/src/lisp/s-math.ref new file mode 100644 index 0000000..1e50c9a --- /dev/null +++ b/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