diff --git a/src/lisp/minmax.lisp b/src/lisp/minmax.lisp new file mode 100644 index 0000000..4af5e18 --- /dev/null +++ b/src/lisp/minmax.lisp @@ -0,0 +1,26 @@ +(DEFINE + (MINL (LAMBDA (M L) + (COND ((NULL L), M) + ((< M (CAR L), (MINL M (CDR L)))) + (T, (MINL (CAR L) (CDR L))) + )) + ) + (MINLIST (LAMBDA (L) + (COND ((NULL L), NIL) + ((ATOM L), L) + (T, (MINL (CAR L) (CDR L))) + )) + ) + (MAXL (LAMBDA (M L) + (COND ((NULL L), M) + ((> M (CAR L), (MINL M (CDR L)))) + (T, (MINL (CAR L) (CDR L))) + )) + ) + (MAXLIST (LAMBDA (L) + (COND ((NULL L), NIL) + ((ATOM L), L) + (T, (MAXL (CAR L) (CDR L))) + )) + ) +) diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index cf7ab08..e67c0c0 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -65,6 +65,10 @@ var sym_list = NULL var build_list = NULL var eval_last = NULL +const MAX_PARAMS = 64 +var param_vals[MAX_PARAMS] // In-flight evaluated argument values +var param_cnt + var sym_nil, sym_quote, sym_lambda, sym_cond, sym_set res[t_elem] pred_true = 0, 0, BOOL_TRUE @@ -112,6 +116,9 @@ def sweep_used#0 sweep_expr(eval_last) symptr = sym_list while symptr + // + // Sweep symbol properties + // if symptr=>apval sweep_expr(symptr=>apval) elsif symptr=>lambda @@ -125,6 +132,14 @@ def sweep_used#0 fin symptr = symptr=>link loop + if param_cnt + // + // Sweep in-flight lambda argument parameters + // + for i = 0 to param_cnt - 1 + sweep_expr(param_vals[i]) + next + fin end def collect_list(listhead, freehead)#2 @@ -653,9 +668,7 @@ end // def enter_lambda(curl, expr, params)#2 // curl, expr - var args, arglist, pairlist - var paramvals[16] - byte paramcnt + var args, arglist, pairlist, parambase, i if !expr or expr=>car <> sym_lambda puts("Invalid LAMBDA expression: "); print_expr(expr); putln @@ -664,18 +677,18 @@ def enter_lambda(curl, expr, params)#2 // curl, expr // // Evaluate the parameters // - paramcnt = 0 + parambase = param_cnt while params - paramvals[paramcnt] = eval_expr(params=>car) - params = params=>cdr - paramcnt++ - if paramcnt > 15 + param_vals[param_cnt] = eval_expr(params=>car) + params = params=>cdr + param_cnt++ + if param_cnt > MAX_PARAMS puts("Parameter overflow:"); print_expr(expr); putln break fin loop args = expr=>cdr=>car - paramcnt = 0 + i = parambase if curl == expr //puts("Tail: "); print_expr(expr); putln // @@ -683,10 +696,10 @@ def enter_lambda(curl, expr, params)#2 // curl, expr // arglist = assoc_list while args - arglist=>car=>cdr = paramvals[paramcnt] + arglist=>car=>cdr = param_vals[i] arglist = arglist=>cdr args = args=>cdr - paramcnt++ + i++ loop else //puts("Enter: "); print_expr(expr); putln @@ -707,15 +720,16 @@ def enter_lambda(curl, expr, params)#2 // curl, expr fin pairlist=>car = new_cons pairlist=>car=>car = args=>car - pairlist=>car=>cdr = paramvals[paramcnt] + pairlist=>car=>cdr = param_vals[i] args = args=>cdr - paramcnt++ + i++ loop if arglist pairlist=>cdr = assoc_list assoc_list = arglist fin fin + param_cnt = parambase //print_expr(assoc_list); putln; getc return expr, expr=>cdr=>cdr=>car end diff --git a/src/lisp/s-math.pla b/src/lisp/s-math.pla index 7801923..412dd62 100644 --- a/src/lisp/s-math.pla +++ b/src/lisp/s-math.pla @@ -57,7 +57,7 @@ def eval_num(expr) var result result = eval_expr(expr=>car) - if result and (result->type & TYPE_MASK == NUM_TYPE) + if result and result->type & TYPE_MASK == NUM_TYPE return result fin puts("Evaluated not an number type: "); print_expr(expr=>car); putln @@ -82,7 +82,7 @@ def push_int32(intptr)#0 var[2] int byte isneg - isneg = FALSE + isneg = FALSE if intptr=>[1] < 0 load32(intptr) isneg = TRUE @@ -148,13 +148,14 @@ def natv_add(symptr, expr) push_int32(@intsum) push_num(num) fpu:addXY() + fpu:pullExt(@extsum) while expr - num = eval_num(expr) - push_num(num) + push_num(eval_num(expr)) + fpu:pushExt(@extsum) fpu:addXY() + fpu:pullExt(@extsum) expr = expr=>cdr loop - fpu:pullExt(@extsum) return new_float(@extsum) fin return new_int(intsum[0], intsum[1]) @@ -245,21 +246,40 @@ def natv_neg(symptr, expr) var[5] ext num = eval_num(expr) - if num=>type == NUM_INT + if num->type == NUM_INT load32(num + intval) neg32 store32(@neg) return new_int(neg[0], neg[1]) fin - push_num(num) - fpu:negX() - fpu:pullExt(@ext) - return new_float(@ext) + num->floatval[9] = num->floatval[9] ^ $80 // Fun with float bits + return new_float(num + floatval) +end + +def natv_abs(symptr, expr) + var num + var[2] abs + var[5] ext + + num = eval_num(expr) + if num->type == NUM_INT + if num=>intval[1] < 0 + load32(num + intval) + neg32 + store32(@abs) + else + abs[0] = num=>intval[0] + abs[1] = num=>intval[1] + fin + return new_int(abs[0], abs[1]) + fin + num->floatval[9] = num->floatval[9] & $7F // Fun with float bits + return new_float(num + floatval) end def natv_gt(symptr, expr) res[t_numfloat] num1, num2 - var[5] ext + byte[10] ext memcpy(@num1, eval_num(expr), t_numfloat) memcpy(@num2, eval_num(expr=>cdr), t_numfloat) @@ -271,12 +291,12 @@ def natv_gt(symptr, expr) push_num(@num1) fpu:subXY() fpu:pullExt(@ext) - return bool_pred(ext[4] < 0) + return bool_pred(ext[9] & $80) // Check sign bit end def natv_lt(symptr, expr) res[t_numfloat] num1, num2 - var[5] ext + byte[10] ext memcpy(@num1, eval_num(expr), t_numfloat) memcpy(@num2, eval_num(expr=>cdr), t_numfloat) @@ -288,21 +308,405 @@ def natv_lt(symptr, expr) push_num(@num2) fpu:subXY() fpu:pullExt(@ext) - return bool_pred(ext[4] < 0) + return bool_pred(ext[9] & $80) // Check sign bit +end + +def natv_min(symptr, expr) + var num + var[2] intmin + var[5] extmin, ext + + num = eval_num(expr) + expr = expr=>cdr + if num->type == NUM_INT + // + // Find min as integers unless a float is encountered + // + intmin[0] = num=>intval[0] + intmin[1] = num=>intval[1] + while expr + num = eval_num(expr) + if num->type == NUM_FLOAT + push_int32(@intmin) + fpu:pullExt(@extmin) + break + fin + load32(@intmin) + if isgt32(num + intval) + intmin[0] = num=>intval[0] + intmin[1] = num=>intval[1] + fin + expr = expr=>cdr + loop + if !expr; return new_int(intmin[0], intmin[1]); fin + else + extmin[0] = num=>floatval[0] + extmin[1] = num=>floatval[1] + extmin[2] = num=>floatval[2] + extmin[3] = num=>floatval[3] + extmin[4] = num=>floatval[4] + if expr; num = eval_num(expr); fin + fin + while expr + push_num(num) + fpu:pushExt(@extmin) + fpu:subXY() + fpu:pullExt(@ext) + if ext[4] < 0 + if num->type == NUM_INT + push_int32(num + intval) + fpu:pullExt(@ext) + extmin[0] = ext[0] + extmin[1] = ext[1] + extmin[2] = ext[2] + extmin[3] = ext[3] + extmin[4] = ext[4] + else + extmin[0] = num=>floatval[0] + extmin[1] = num=>floatval[1] + extmin[2] = num=>floatval[2] + extmin[3] = num=>floatval[3] + extmin[4] = num=>floatval[4] + fin + fin + expr = expr=>cdr + if expr; num = eval_num(expr); fin + loop + return new_float(@extmin) +end + +def natv_max(symptr, expr) + var num + var[2] intmax + var[5] extmax, ext + + num = eval_num(expr) + expr = expr=>cdr + if num->type == NUM_INT + // + // Find max as integers unless a float is encountered + // + intmax[0] = num=>intval[0] + intmax[1] = num=>intval[1] + while expr + num = eval_num(expr) + if num->type == NUM_FLOAT + push_int32(@intmax) + fpu:pullExt(@extmax) + break + fin + load32(@intmax) + if islt32(num + intval) + intmax[0] = num=>intval[0] + intmax[1] = num=>intval[1] + fin + expr = expr=>cdr + loop + if !expr; return new_int(intmax[0], intmax[1]); fin + else + extmax[0] = num=>floatval[0] + extmax[1] = num=>floatval[1] + extmax[2] = num=>floatval[2] + extmax[3] = num=>floatval[3] + extmax[4] = num=>floatval[4] + if expr; num = eval_num(expr); fin + fin + while expr + fpu:pushExt(@extmax) + push_num(num) + fpu:subXY() + fpu:pullExt(@ext) + if ext[4] < 0 + if num->type == NUM_INT + push_int32(num + intval) + fpu:pullExt(@ext) + extmax[0] = ext[0] + extmax[1] = ext[1] + extmax[2] = ext[2] + extmax[3] = ext[3] + extmax[4] = ext[4] + else + extmax[0] = num=>floatval[0] + extmax[1] = num=>floatval[1] + extmax[2] = num=>floatval[2] + extmax[3] = num=>floatval[3] + extmax[4] = num=>floatval[4] + fin + fin + expr = expr=>cdr + if expr; num = eval_num(expr); fin + loop + return new_float(@extmax) +end + +def natv_pi(symptr, expr) + var[5] ext + + fpu:constPi() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_e(symptr, expr) + var[5] ext + + fpu:constE() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_logb(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:logbX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_scalebI(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + push_int32(eval_expr(expr=>cdr) + intval) + fpu:scalebXInt() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_trunc(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:truncX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_round(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:roundX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_sqrt(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:sqrtX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_cos(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:cosX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_sin(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:sinX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_tan(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:tanX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_atan(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:atanX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_log2(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:log2X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_log21(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:log21X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_ln(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:lnX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_ln1(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:ln1X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_pow2(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:pow2X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_pow21(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:pow21X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_powE(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:powEX() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_powE1(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:powE1X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_powE21(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:powE21X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_powI(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + push_int32(eval_int(expr=>cdr) + intval) + fpu:powXInt() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_powY(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + push_num(eval_num(expr=>cdr)) + fpu:pow2X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_compY(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + push_num(eval_num(expr=>cdr)) + fpu:pow2X() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_annuityY(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + push_num(eval_num(expr=>cdr)) + fpu:annuityXY() + fpu:pullExt(@ext) + return new_float(@ext) +end + +def natv_randNum(symptr, expr) + var[5] ext + + push_num(eval_num(expr)) + fpu:randNum() + fpu:pullExt(@ext) + return new_float(@ext) 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 +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("ABS")=>natv = @natv_abs +new_sym(">")=>natv = @natv_gt +new_sym("<")=>natv = @natv_lt +new_sym("MIN")=>natv = @natv_min +new_sym("MAX")=>natv = @natv_max +new_sym("PI")=>natv = @natv_pi +new_sym("MATH_E")=>natv = @natv_e +new_sym("LOGB")=>natv = @natv_logb +new_sym("SCALEB_I")=>natv = @natv_scalebI +new_sym("TRUNCATE")=>natv = @natv_trunc +new_sym("ROUND")=>natv = @natv_round +new_sym("SQRT")=>natv = @natv_sqrt +new_sym("COS")=>natv = @natv_cos +new_sym("SIN")=>natv = @natv_sin +new_sym("TAN")=>natv = @natv_tan +new_sym("ATAN")=>natv = @natv_atan +new_sym("LOG2")=>natv = @natv_log2 +new_sym("LOG2_1")=>natv = @natv_log21 +new_sym("LN")=>natv = @natv_ln +new_sym("LN_1")=>natv = @natv_ln1 +new_sym("POW2")=>natv = @natv_pow2 +new_sym("POW2_1")=>natv = @natv_pow21 +new_sym("POWE")=>natv = @natv_powE +new_sym("POWE_1")=>natv = @natv_powE1 +new_sym("POWE2_1")=>natv = @natv_powE21 +new_sym("POW_I")=>natv = @natv_powI +new_sym("POWY")=>natv = @natv_powY +new_sym("COMP")=>natv = @natv_compY +new_sym("ANNUITY")=>natv = @natv_annuityY +new_sym("RANDOM")=>natv = @natv_randNum fpu:reset() return modkeep | modinitkeep done diff --git a/src/mklisp b/src/mklisp index 41f038d..95974f8 100755 --- a/src/mklisp +++ b/src/mklisp @@ -26,4 +26,5 @@ cat lisp/maplist.lisp | ./ac.jar -ptx DRAWL.po lisp/MAPLIST.LISP TX cat lisp/gcd.lisp | ./ac.jar -ptx DRAWL.po lisp/GCD.LISP TXT cat lisp/fact.lisp | ./ac.jar -ptx DRAWL.po lisp/FACT.LISP TXT cat lisp/loop.lisp | ./ac.jar -ptx DRAWL.po lisp/LOOP.LISP TXT +cat lisp/minmax.lisp | ./ac.jar -ptx DRAWL.po lisp/MINMAX.LISP TXT cat lisp/prog.lisp | ./ac.jar -ptx DRAWL.po lisp/PROG.LISP TXT diff --git a/src/mkrel b/src/mkrel index 8b6ae12..48aada1 100755 --- a/src/mkrel +++ b/src/mkrel @@ -186,6 +186,7 @@ cp lisp/maplist.lisp prodos/bld/lisp/MAPLIST.LISP.TXT cp lisp/gcd.lisp prodos/bld/lisp/GCD.LISP.TXT cp lisp/fact.lisp prodos/bld/lisp/FACT.LISP.TXT cp lisp/loop.lisp prodos/bld/lisp/LOOP.LISP.TXT +cp lisp/minmax.lisp prodos/bld/lisp/MINMAX.LISP.TXT cp lisp/prog.lisp prodos/bld/lisp/PROG.LISP.TXT #mkdir prodos/bld/examples