From d920a14c8f5956837b204f27bdbb7ffc7ee0a6d5 Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Tue, 9 Jul 2024 10:55:32 -0700 Subject: [PATCH] Faster and looser w/ is_alpha/is_alphasym but allow ',' as whitespace --- src/lisp/drawl.pla | 1 + src/lisp/gcd.lisp | 6 +-- src/lisp/maplist.lisp | 4 +- src/lisp/s-expr.pla | 96 ++++++++++++++++++++++++------------------- src/lisp/set.lisp | 18 ++++---- 5 files changed, 68 insertions(+), 57 deletions(-) diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla index 5530c58..279324b 100644 --- a/src/lisp/drawl.pla +++ b/src/lisp/drawl.pla @@ -45,6 +45,7 @@ import sexpr predef new_int(intlo, inthi)#1 predef new_sym(symstr)#1 predef new_assoc(symptr, valptr)#0 + predef set_assoc(symptr, valptr)#0 end // diff --git a/src/lisp/gcd.lisp b/src/lisp/gcd.lisp index 6750f00..b1b29c6 100644 --- a/src/lisp/gcd.lisp +++ b/src/lisp/gcd.lisp @@ -1,7 +1,7 @@ (label gcd (lambda (x y) - (cond ((> x y) (gcd y x)) - ((eq (rem y x) 0) x) - (t (gcd (rem y x) x)) + (cond ((> x y) , (gcd y x)) + ((eq (rem y x) 0) , x) + (t , (gcd (rem y x) x)) ) ) ) diff --git a/src/lisp/maplist.lisp b/src/lisp/maplist.lisp index 4fe1e39..da7681a 100644 --- a/src/lisp/maplist.lisp +++ b/src/lisp/maplist.lisp @@ -7,8 +7,8 @@ (maplist (lambda (l fn) (cond - ((null l) nil) - (t (cons (fn l) (maplist (cdr l) fn))) + ((null l) , nil) + (t , (cons (fn l) (maplist (cdr l) fn))) ) ) ) diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index 2e84b26..27b43df 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -237,7 +237,7 @@ def assoc(symptr) end export def new_assoc(symptr, valptr)#0 - var pair, newlist + var pair, addlist if symptr and (symptr->type & TYPE_MASK <> SYM_TYPE) puts("Not a SYM in new_assoc\n") @@ -246,13 +246,21 @@ export def new_assoc(symptr, valptr)#0 pair = new_cons pair=>car = symptr pair=>cdr = valptr - newlist = new_cons - newlist=>car = pair - newlist=>cdr = assoc_list - assoc_list = newlist + 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 -def set_assoc(symptr, valptr)#0 +export def set_assoc(symptr, valptr)#0 var pair // @@ -330,9 +338,12 @@ end def is_int(c); return c >= '0' and c <= '9'; end +def is_alpha(c) + return c >= 'A' and c <= 'z' +end + def is_alphasym(c) - c=toupper(c) - return c >= '*' and c <= 'Z' and c <> '.' + return c >= '0' and c <= 'z' end def parse_int(evalptr)#2 // return evalptr, intptr @@ -356,6 +367,7 @@ end def parse_sym(evalptr)#2 // return evalptr, symptr var symstr + symstr = evalptr - 1 while is_alphasym(^evalptr) ^evalptr = toupper(^evalptr) @@ -429,7 +441,7 @@ export def parse_expr(evalptr, level, refill)#2 // return evalptr, exprptr otherwise if (^evalptr == '-' and is_int(^(evalptr+1))) or is_int(^evalptr) evalptr, elemptr = parse_int(evalptr) - elsif is_alphasym(^evalptr) + elsif is_alpha(^evalptr) evalptr, elemptr = parse_sym(evalptr) else putc('\\') @@ -468,18 +480,8 @@ end // Evaluate expression // -def eval_atom(atom) - var pair - - if atom->type & TYPE_MASK == SYM_TYPE - atom = assoc(atom)=>cdr - fin - return atom -end - -def eval_lambda(expr, params) - var args, assoc_org, result - var newlist, pairlist, pair +def enter_lambda(expr, params) + var args, arglist, pairlist, pair if !expr or expr=>car <> sym_lambda puts("Invalid LAMBDA expression: ") @@ -489,16 +491,15 @@ def eval_lambda(expr, params) // // Build arg list before prepending to assoc_list // - assoc_org = assoc_list - args = expr=>cdr=>car - newlist = NULL + args = expr=>cdr=>car + arglist = NULL while args - if newlist + if arglist pairlist=>cdr = new_cons pairlist = pairlist=>cdr else - newlist = new_cons - pairlist = newlist + arglist = new_cons + pairlist = arglist fin pair = new_cons pair=>car = args=>car @@ -507,40 +508,49 @@ def eval_lambda(expr, params) args = args=>cdr params = params=>cdr loop - if newlist + if arglist pairlist=>cdr = assoc_list - assoc_list = newlist + assoc_list = arglist fin - result = eval_expr(expr=>cdr=>cdr=>car) - assoc_list = assoc_org - return result + return expr=>cdr=>cdr=>car end export def eval_expr(expr)#1 - if expr + var alist_enter, result + + result = NULL + alist_enter = assoc_list + while expr if expr->type == CONS_TYPE // // List - first element better be a function // if expr=>car->type & TYPE_MASK == SYM_TYPE - if expr=>car=>natv // Native function - return expr=>car=>natv(expr=>cdr) + if expr=>car=>natv + result = expr=>car=>natv(expr=>cdr) // Native function + expr = NULL elsif expr=>car=>lambda // DEFINEd lambda S-expression - return eval_lambda(expr=>car=>lambda, expr=>cdr) + expr = enter_lambda(expr=>car=>lambda, expr=>cdr) else // Symbol associated with lambda - return eval_lambda(assoc(expr=>car)=>cdr, expr=>cdr) + expr = enter_lambda(assoc(expr=>car)=>cdr, expr=>cdr) fin elsif expr=>car->type == CONS_TYPE and expr=>car=>car == sym_lambda - return eval_lambda(expr=>car, expr=>cdr) + expr = enter_lambda(expr=>car, expr=>cdr) // Inline lambda fin else // // Atom // - return expr->type & TYPE_MASK == SYM_TYPE ?? assoc(expr)=>cdr :: expr + if expr->type & TYPE_MASK == SYM_TYPE + result = assoc(expr)=>cdr + else + result = expr + fin + expr = NULL fin - fin - return NULL + loop + assoc_list = alist_enter + return result end // @@ -638,8 +648,8 @@ def natv_define(expr) while expr symptr = expr=>car=>car symptr=>lambda = expr=>car=>cdr=>car - funcptr=>car = symptr - expr = expr=>cdr + funcptr=>car = symptr + expr = expr=>cdr if expr funcptr=>cdr = new_cons funcptr = funcptr=>cdr diff --git a/src/lisp/set.lisp b/src/lisp/set.lisp index 43f70ec..b134506 100644 --- a/src/lisp/set.lisp +++ b/src/lisp/set.lisp @@ -1,21 +1,21 @@ (define (member (lambda (a x) - (cond ((null x) f) - ((eq a (car x)) t) - (t (member a (cdr x))) + (cond ((null x) , f) + ((eq a (car x)) , t) + (t , (member a (cdr x))) )) ) (union (lambda (x y) - (cond ((null x) y) - ((member (car x) y) (union (cdr x) y)) - (t (cons (car x) (union (cdr x) y))) + (cond ((null x) , y) + ((member (car x) y) , (union (cdr x) y)) + (t , (cons (car x) (union (cdr x) y))) )) ) (intersection (lambda (x y) - (cond ((null x) nil) - ((member (car x) y) (cons (car x) (intersection + (cond ((null x) , nil) + ((member (car x) y) , (cons (car x) (intersection (cdr x) y))) - (t (intersection (cdr x) y)) + (t , (intersection (cdr x) y)) )) ) )