From 5396298b50c4dfeef236f593520201ac81119693 Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Fri, 5 Jul 2024 18:01:20 -0700 Subject: [PATCH] DEFINE and EVAL lambda functions --- src/toolsrc/drawl.pla | 573 +++++++++++++++++++++++++----------------- 1 file changed, 341 insertions(+), 232 deletions(-) diff --git a/src/toolsrc/drawl.pla b/src/toolsrc/drawl.pla index 1705893..7e73259 100644 --- a/src/toolsrc/drawl.pla +++ b/src/toolsrc/drawl.pla @@ -5,23 +5,10 @@ const NIL = $00 const BOOL_FALSE = $00 const BOOL_TRUE = $01 const CONS_TYPE = $10 -const LIT_TYPE = $20 -const LIT_NUM = $21 -const LIT_CHR = $22 -const LIT_STR = $23 -const SYM_TYPE = $30 +const SYM_TYPE = $20 const SYM_LEN = $0F -const FUNC_TYPE = $40 -const FUNC_EXPR = $41 -const FUNC_NATV = $42 -const VAR_TYPE = $50 -const VAR_NUM = $51 -const VAR_CHR = $52 -const VAR_STR = $53 -const VAR_BOOL = $54 -const VAR_FALSE = $55 -const ARG_TYPE = $60 -const QUOTE = $70 +const NUM_TYPE = $30 +const NUM_INT = $31 struc t_elem word link @@ -32,43 +19,30 @@ struc t_cons word car word cdr end -struc t_num - res[t_elem] - var numval -end -struc t_chr - res[t_elem] - char chrval -end -struc t_str - res[t_elem] - char[1] string -end struc t_sym res[t_elem] - word prop + var natv + var lambda char[0] name end -struc t_func +struc t_numint res[t_elem] - word lamda + var intval end -var sym_true, sym_false, sym_nil, sym_quote +predef eval_expr(expr) + +var sym_quote, sym_lambda res[t_elem] pred_true = 0, 0, BOOL_TRUE res[t_elem] pred_false = 0, 0, BOOL_FALSE -var cons_list = NULL -var cons_free = NULL -var func_list = NULL -var func_free = NULL -var var_list = NULL -var var_free = NULL -var sym_list = NULL -var sym_free = NULL -var lit_list = NULL -var lit_free = NULL - +var cons_list = NULL +var cons_free = NULL +var sym_list = NULL +var sym_free = NULL +var int_list = NULL +var int_free = NULL +var assoc_list = NULL // SYM->value association list byte quit = FALSE // @@ -87,33 +61,33 @@ def new_cons return consptr end -def match_litnum(num) - var numptr +def match_int(int) + var intptr - numptr = lit_list - while numptr - if numptr->type == LIT_NUM and numptr=>numval == num - puts("Match number: ") - puti(num); putln - return numptr + intptr = int_list + while intptr + if intptr=>intval == int + puts("Match int: ") + puti(int); putln + return intptr fin - numptr = numptr=>link + intptr = intptr=>link loop return NULL end -def add_litnum(num) - var numptr +def new_int(int) + var intptr - numptr = match_litnum(num) - if numptr; return numptr; fin - numptr = heapalloc(t_num) - numptr=>link = lit_list - lit_list = numptr - numptr->type = LIT_NUM - numptr=>numval = num - puts("New number: "); puti(num); putln - return numptr + intptr = match_int(int) + if intptr; return intptr; fin + intptr = heapalloc(t_numint) + intptr=>link = int_list + int_list = intptr + intptr->type = NUM_INT + intptr=>intval = int + puts("New int: "); puti(int); putln + return intptr end def match_sym(symstr) @@ -140,57 +114,155 @@ def match_sym(symstr) return NULL end -def add_sym(symstr) +def new_sym(symstr) 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=>prop = NULL + symptr = heapalloc(t_sym + ^symstr) + symptr=>link = sym_list + sym_list = symptr + symptr->type = ^symstr | SYM_TYPE + symptr=>natv = NULL + symptr=>lambda = NULL memcpy(symptr + name, symstr + 1, ^symstr) puts("New symbol: "); puts(symstr); putln return symptr end -def add_natvfn(funstr, funaddr) - var funsym, funptr +// +// Build/set association between symbols and values +// - funsym = add_sym(funstr) - if funsym=>prop; puts(" Property already assinged:"); puts(funstr); putln; return 0; fin - funptr = heapalloc(t_func) - funptr=>link = func_list - func_list = funptr - funptr->type = FUNC_NATV - funptr=>lamda = funaddr - funsym=>prop = funptr - puts("New native function: "); puts(funstr); putln - return funstr +def assoc(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 + fin + pair = pair=>cdr + loop + fin + return NULL // SYM not associated +end + +def new_assoc(symptr, valptr)#0 + var pair, newlist + + if symptr and (symptr->type & TYPE_MASK <> SYM_TYPE) + puts("Not a SYM in new_assoc\n") + return + fin + pair = new_cons + pair=>car = symptr + pair=>cdr = valptr + newlist = new_cons + newlist=>car = pair + newlist=>cdr = assoc_list + assoc_list = newlist +end + +def set_assoc(symptr, valptr)#0 + var pair + + // + // Search association list for symbol + // + pair = assoc(symptr) + if pair + pair=>car=>cdr = valptr // update association + else + new_assoc(symptr, valptr) // add association if unknown + fin end // -// Parse textual representation of S-expressions +// Print textual representation of S-expression // -def is_num(c); return c >= '0' and c <= '9'; end +def print_atom(atom)#0 + char prstr[32] + + 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 + puti(atom=>intval) + break + wend + break + is SYM_TYPE + prstr = atom->type & SYM_LEN + memcpy(@prstr + 1, atom + name, prstr) + puts(@prstr) + break; + otherwise + puts("Unkown atom type\n") + wend + fin +end + +def print_expr(expr)#0 + + 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 +end + +// +// Parse textual representation of S-expression +// + +def is_int(c); return c >= '0' and c <= '9'; end def is_alphasym(c); c=toupper(c); return c >= '*' and c <= 'Z' and c <> '.'; end -def parse_num(evalptr)#2 // return evalptr, numptr - var num, sign +def parse_int(evalptr)#2 // return evalptr, intptr + var int + byte sign - num = 0 - sign = 1 + int = 0 + sign = FALSE if ^evalptr == '-' - sign = -1 + sign = TRUE evalptr++ fin while ^evalptr >= '0' and ^evalptr <= '9' - num = num * 10 + ^evalptr - '0' + int = int * 10 + ^evalptr - '0' evalptr++ loop - return evalptr, add_litnum(sign * num) + return evalptr, new_int(sign ?? -int :: int) end def parse_sym(evalptr)#2 // return evalptr, symptr @@ -201,10 +273,10 @@ def parse_sym(evalptr)#2 // return evalptr, symptr loop ^symstr = evalptr - symstr - 1 if ^symstr > 31; ^symstr = 31; fin - return evalptr, add_sym(symstr) + return evalptr, new_sym(symstr) end -def parse_expr(evalptr, level)#2 // return evalptr, exprptr +def parse_expr(evalptr, level, refill)#2 // return evalptr, exprptr var exprptr, consptr, elemptr, quotecons exprptr = NULL @@ -218,14 +290,13 @@ def parse_expr(evalptr, level)#2 // return evalptr, exprptr is 0 if level // Refill input buffer - evalptr = gets('>'|$80) - ^(evalptr + ^evalptr + 1) = 0 - evalptr++ + evalptr = refill() else return evalptr, exprptr fin break is ' ' + is ',' evalptr++ break is ')' @@ -236,21 +307,24 @@ def parse_expr(evalptr, level)#2 // return evalptr, exprptr if level == 0 level++ else - evalptr, elemptr = parse_expr(evalptr, 1) + evalptr, elemptr = parse_expr(evalptr, 1, refill) fin break is '\'' evalptr++ - evalptr, elemptr = parse_expr(evalptr, 0) + evalptr, elemptr = parse_expr(evalptr, 0, refill) quotecons = new_cons quotecons=>car = 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) + evalptr, elemptr = parse_expr(evalptr, 0, refill) // // Add expression to CDR // @@ -261,8 +335,8 @@ def parse_expr(evalptr, level)#2 // return evalptr, exprptr consptr=>cdr = elemptr return evalptr, exprptr otherwise - if (^evalptr == '-' and is_num(^(evalptr+1))) or is_num(^evalptr) - evalptr, elemptr = parse_num(evalptr) + if (^evalptr == '-' and is_int(^(evalptr+1))) or is_int(^evalptr) + evalptr, elemptr = parse_int(evalptr) elsif is_alphasym(^evalptr) evalptr, elemptr = parse_sym(evalptr) else @@ -295,111 +369,78 @@ def parse_expr(evalptr, level)#2 // return evalptr, exprptr end // -// REPL routines +// Evaluate expression // -def print(expr)#0 - char prstr[32] +def eval_atom(atom) + var pair - if not expr - puts("NIL") - else - when expr->type & TYPE_MASK - is CONS_TYPE - putc('(') - print(expr=>car) - putc('.') - print(expr=>cdr) - putc(')') - break - is NIL - putc(expr->type ?? 'T' :: 'F') - break - is LIT_TYPE - is VAR_TYPE - when expr->type - is LIT_NUM - is VAR_NUM - puti(expr=>numval) - break - wend - break - is SYM_TYPE - prstr = expr->type & SYM_LEN - memcpy(@prstr + 1, expr + name, prstr) - puts(@prstr) - break; - wend + if atom->type & TYPE_MASK == SYM_TYPE + atom = assoc(atom)=>car=>cdr fin + return atom end -def read - var readline, expr +def eval_lambda(expr, params) + var args, assoc_org, result - repeat - readline = gets('?'|$80) - ^(readline + ^readline + 1) = 0 - readline++ - until ^readline - if ^readline == '!'; quit = TRUE; return NULL; fin // Quick exit from REPL - drop, expr = parse_expr(readline, 0) - print(expr); putln // DEBUG - print parsed expression - return expr + if expr=>car <> sym_lambda + puts("Invalid LAMBDA expression: ") + print_expr(expr) + return NULL + fin + assoc_org = assoc_list + args = expr=>cdr=>car + while args + new_assoc(args=>car, eval_expr(params=>car)) + args = args=>cdr + params = params=>cdr + loop + result = eval_expr(expr=>cdr=>cdr=>car) + assoc_list = assoc_org + return result end -def eval(expr) +def eval_expr(expr) if expr - when expr->type & TYPE_MASK - is CONS_TYPE - if expr=>car->type & TYPE_MASK == SYM_TYPE and expr=>car=>prop->type == FUNC_NATV - return expr=>car=>prop=>lamda(expr=>cdr) + if expr->type == CONS_TYPE + if expr=>car->type & TYPE_MASK == SYM_TYPE + if expr=>car=>natv + return expr=>car=>natv(expr=>cdr) else - puts("Bad function expression: \n"); print(expr); putln - return NULL + return eval_lambda(expr=>car=>lambda, expr=>cdr) fin - wend + elsif expr=>car->type == CONS_TYPE + if expr=>car=>car == @sym_lambda + eval_lambda(expr=>car=>car, expr=>cdr) + fin + fin + else + return eval_atom(expr) + fin fin - return expr + return NULL end // -// Install default native functions +// Base native functions // -def eval_atom(atom)#2 // return type, val - var atomtype, atomval - - when atom->type - is BOOL_FALSE - is BOOL_TRUE - is LIT_NUM - is VAR_NUM - is LIT_CHR - is VAR_CHR - is LIT_STR - is VAR_STR - is ARG_TYPE - wend - return atom->type, atomval -end - -def natv_atom(expr) - return expr->type <> CONS_TYPE ?? @pred_true :: @pred_false +def natv_atom(atom) + return !atom or atom->type <> CONS_TYPE ?? @pred_true :: @pred_false end def natv_eq(expr) - var type1, type2, val1, val2 - - type1, val1 = eval_atom(expr=>car=>prop) - type2, val2 = eval_atom(expr=>cdr=>car=>prop) - if type1 == type2 - return val1 == val2 ?? @pred_true :: @pred_false - fin - return @pred_false + return eval_atom(eval_expr(expr=>car)) == eval_atom(eval_expr(expr=>cdr=>car)) ?? @pred_true :: @pred_false end def natv_cons(expr) - return NULL + var consptr + + consptr = new_cons + consptr=>car = expr=>car + consptr=>cdr = expr=>cdr=>car + return consptr end def natv_car(expr) @@ -416,34 +457,69 @@ def natv_cdr(expr) return NULL end -def natv_cadr(expr) - if expr->TYPE == CONS_TYPE and expr=>cdr->type == CONS_TYPE - return expr=>cdr=>car - fin - return NULL -end - def natv_evcon(expr) + var conds + + conds = expr=>cdr return NULL end -def natv_defn(expr) - return NULL +def natv_define(expr) + + var symptr, funclist, funcptr + + funclist = NULL + if expr + funclist = new_cons + funcptr = funclist + fin + while expr + symptr = expr=>car=>car + symptr=>lambda = expr=>car=>cdr=>car + funcptr=>car = symptr + expr = expr=>cdr + if expr + funcptr=>cdr = new_cons + funcptr = funcptr=>cdr + fin + loop + return funclist +end + +def natv_null(expr) + var result + + result = eval_expr(expr=>car) + return !result or !result->type ?? @pred_true :: @pred_false +end + +def natv_set(expr) + var symptr, valptr + + symptr = eval_expr(expr=>car) + valptr = eval_expr(expr=>cdr=>car) + set_assoc(symptr, valptr) + return valptr +end + +def natv_setq(expr) + var symptr, valptr + + symptr = expr=>car + valptr = eval_expr(expr=>cdr=>car) + set_assoc(symptr, valptr) + return valptr end def eval_num(expr) var result - result = expr=>car - if result->type == CONS_TYPE - result = eval(result) + result = eval_expr(expr=>car) + if result->type == NUM_INT + return result=>intval fin - if result->type == LIT_NUM or result->type == VAR_NUM - return result - else - puts("Not a number\n") - fin - return NULL + puts("Not an number\n") + return 0 end def natv_add(expr) @@ -451,71 +527,104 @@ def natv_add(expr) sum = 0 while expr - sum = sum + eval_num(expr)=>numval + sum = sum + eval_num(expr) expr = expr=>cdr loop - return add_litnum(sum) + return new_int(sum) end def natv_sub(expr) var diff - diff = eval_num(expr)=>numval + diff = eval_num(expr) expr = expr=>cdr while expr - diff = diff - eval_num(expr)=>numval + diff = diff - eval_num(expr) expr = expr=>cdr loop - return add_litnum(diff) + return new_int(diff) end def natv_mul(expr) var mults - mults = eval_num(expr)=>numval + mults = eval_num(expr) expr = expr=>cdr while expr - mults = mults * eval_num(expr)=>numval + mults = mults * eval_num(expr) expr = expr=>cdr loop - return add_litnum(mults) + return new_int(mults) end def natv_div(expr) var divs - divs = eval_num(expr)=>numval + divs = eval_num(expr) expr = expr=>cdr while expr - divs = divs * eval_num(expr)=>numval + divs = divs * eval_num(expr) expr = expr=>cdr loop - return add_litnum(divs) + return new_int(divs) end -def add_defaults#0 +// +// Install default functions +// - sym_true = add_sym("T") - sym_true=>prop = @pred_true - sym_false = add_sym("F") - sym_false=>prop = @pred_false - sym_nil = add_sym("NIL") - sym_nil=>prop = @pred_false - sym_quote = add_sym("QUOTE") - add_natvfn("ATOM", @natv_atom) - add_natvfn("EQ", @natv_eq) - add_natvfn("CONS", @natv_cons) - add_natvfn("CAR", @natv_car) - add_natvfn("CDR", @natv_cdr) - add_natvfn("QUOTE", @natv_cadr) - add_natvfn("COND", @natv_evcon) - add_natvfn("DEFINE", @natv_defn) - add_natvfn("+", @natv_add) - add_natvfn("-", @natv_sub) - add_natvfn("*", @natv_mul) - add_natvfn("/", @natv_div) +def install_defaults#0 + new_assoc(new_sym("T"), @pred_true) + new_assoc(new_sym("F"), @pred_false) + new_assoc(new_sym("NIL"), @pred_false) + sym_lambda = new_sym("LAMBDA") + sym_quote = new_sym("QUOTE") + sym_quote=>natv = @natv_car) + 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("COND")=>natv = @natv_evcon) + new_sym("SET")=>natv = @natv_set) + new_sym("SETQ")=>natv = @natv_setq) + new_sym("NULL")=>natv = @natv_null) + new_sym("DEFINE")=>natv = @natv_define) + new_sym("+")=>natv = @natv_add) + new_sym("-")=>natv = @natv_sub) + new_sym("*")=>natv = @natv_mul) + new_sym("/")=>natv = @natv_div) end -add_defaults -while not quit; print(eval(read)); putln; loop +// +// REPL interface to S-expression evaluator +// + +def refill_keybd + var readline + + repeat + readline = gets('>'|$80) + ^(readline + ^readline + 1) = 0 + readline++ + until ^readline + return readline +end + +def read_keybd + var readline, expr + + repeat + readline = gets('?'|$80) + ^(readline + ^readline + 1) = 0 + readline++ + until ^readline + if ^readline == '!'; quit = TRUE; return NULL; fin // Quick exit from REPL + drop, expr = parse_expr(readline, 0, @refill_keybd) + print_expr(expr); putln // DEBUG - print parsed expression + return expr +end + +install_defaults +while not quit; print_expr(eval_expr(read_keybd)); putln; loop done