diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla index 93f0788..27eb9ff 100644 --- a/src/lisp/drawl.pla +++ b/src/lisp/drawl.pla @@ -18,7 +18,7 @@ import sexpr const ARRAY_TYPE = $40 const MARK_BIT = $80 const MARK_MASK = $7F - const NULL_HACK = 1 // Hack so we can set elements to NULL + const NULL_HACK = 1 // Hack so we can set APVALs to NULL struc t_elem word link @@ -65,7 +65,7 @@ var prog, prog_expr, prog_return // Current PROG expressions var sym_cond, sym_if, sym_fpint, sym_fpfrac var pred_true -res[t_except] break_repl // Breeak out of eval processing +res[t_except] break_repl // Breeak out of eval processing const csw = $0036 // Output switch vector var scrncsw = 0 // Output screen value @@ -179,6 +179,10 @@ def natv_gc(symptr, expr) return new_int(heapavail, 0) end +// +// Useful Apple II features +// + def natv_printer(symptr, expr) byte slot @@ -197,6 +201,30 @@ def natv_printer(symptr, expr) return new_int(slot, 0) end +def natv_gr(symptr, expr) + + if eval_expr(expr=>car) + conio:grmode(TRUE) // Mixed mode + else + conio:textmode(40) // 40 column text + fin + return expr +end + +def natv_color(symptr, expr) + conio:grcolor(eval_int(expr)=>intval & $0F) + return expr +end + +def natv_plot(symptr, expr) + byte x, y + + x = eval_int(expr)=>intval + y = eval_int(expr=>cdr)=>intval + conio:grplot(x, y) + return expr +end + def natv_bye(symptr, expr) quit = TRUE return new_sym("GOODBYE!") @@ -319,6 +347,9 @@ new_sym("SET")=>natv = @natv_set new_sym("SETQ")=>natv = @natv_setq new_sym("GC")=>natv = @natv_gc new_sym("PRINTER")=>natv = @natv_printer +new_sym("GR")=>natv = @natv_gr +new_sym("COLOR")=>natv = @natv_color +new_sym("PLOT")=>natv = @natv_plot new_sym("QUIT")=>natv = @natv_bye parse_cmdline diff --git a/src/lisp/lores.lisp b/src/lisp/lores.lisp new file mode 100644 index 0000000..936d6c3 --- /dev/null +++ b/src/lisp/lores.lisp @@ -0,0 +1,24 @@ +(DEFINE + (PLOTFUNC (LAMBDA (FN) + (PROG (X Y) + (SETQ X 0) + A (SETQ Y (* 0.99 (FN (/ (- X 20) 20.0)))) + (IF (AND (> Y -1.0) (< Y 1.0)) + (PLOT X, (* (+ Y 1.0) 19.0))) + (SETQ X (+ X 1)) + (IF (< X 40) (GO A)) + (RETURN 0) + ) + )) + (PLOTSIN (LAMBDA () + (PLOTFUNC '(LAMBDA (S) (SIN (* S PI)))) + )) + (PLOTCOS (LAMBDA () + (PLOTFUNC '(LAMBDA (S) (COS (* S PI)))) + )) +) +(GR T) +(COLOR 2) +(PLOTSIN) +(COLOR 9) +(PLOTCOS) diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index c59e538..610599b 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -15,7 +15,7 @@ const NUM_FLOAT = $32 const ARRAY_TYPE = $40 const MARK_BIT = $80 const MARK_MASK = $7F -const NULL_HACK = 1 // Hack so we can set elements to NULL +const NULL_HACK = 1 // Hack so we can set APVALs to NULL struc t_elem word link @@ -723,7 +723,7 @@ def eval_args(argvals) sweep_stack[sweep_stack_top] = eval_expr(argvals=>car) sweep_stack_top++ if sweep_stack_top >= SWEEPSTACK_MAX - puts("Arg val overflow\n") + puts("Arg overflow\n") return NULL fin argvals = argvals=>cdr @@ -732,62 +732,64 @@ def eval_args(argvals) return sweep_stack_top end -def apply_args(curl, expr, argvals)#2 // curl, expr - var argsyms, arglist, pairlist, argbase +def build_args(argsyms, argbase)#0 + var arglist, pairlist + arglist = NULL + while argsyms + // + // Build argument/value pairs + // + if arglist + pairlist=>cdr = new_cons + pairlist = pairlist=>cdr + else + arglist = new_cons + pairlist = arglist + fin + pairlist=>car = new_cons + pairlist=>car=>car = argsyms=>car + pairlist=>car=>cdr = sweep_stack[argbase] + argsyms = argsyms=>cdr + argbase++ + loop + if arglist + pairlist=>cdr = assoc_list + assoc_list = arglist + fin +end + +def copy_args(argsyms, argbase)#0 + var arglist + + arglist = assoc_list + while argsyms + arglist=>car=>cdr = sweep_stack[argbase] + arglist = arglist=>cdr + argsyms = argsyms=>cdr + argbase++ + loop +end + +def apply_args(curl, expr, argvals)#2 // curl, expr if !expr or expr=>car <> sym_lambda - puts("Invalid LAMBDA expression: "); print_expr(expr); putln + puts("Bad LAMBDA: "); print_expr(expr); putln return NULL, NULL fin - argsyms = expr=>cdr=>car - argbase = eval_args(argvals) if curl == expr // - // Set associations + // Overwrite argument associations // - arglist = assoc_list - while argsyms - arglist=>car=>cdr = sweep_stack[argbase] - arglist = arglist=>cdr - argsyms = argsyms=>cdr - argbase++ - loop - if trace - puts("TAIL call:") - fin + copy_args(expr=>cdr=>car, eval_args(argvals)) else // - // Build arg list before prepending to assoc_list + // Build argument association list // - arglist = NULL - while argsyms - // - // Build argument/value pairs - // - if arglist - pairlist=>cdr = new_cons - pairlist = pairlist=>cdr - else - arglist = new_cons - pairlist = arglist - fin - pairlist=>car = new_cons - pairlist=>car=>car = argsyms=>car - pairlist=>car=>cdr = sweep_stack[argbase] - argsyms = argsyms=>cdr - argbase++ - loop - if arglist - pairlist=>cdr = assoc_list - assoc_list = arglist - fin - if trace - puts("APPLY call:") - fin + build_args(expr=>cdr=>car, eval_args(argvals)) fin if trace - print_expr(expr); putln - print_expr(assoc_list); putln + puts("\nTRACE:"); print_expr(expr) + puts("\n ASSOC:"); print_expr(assoc_list); putln fin return expr, expr=>cdr=>cdr=>car end @@ -816,37 +818,17 @@ def eval_funarg(funarg, argvals) // arglist = NULL argbase = eval_args(argvals) - argsyms = funexpr=>cdr=>car - while argsyms - // - // Build argument/value pairs - // - if arglist - pairlist=>cdr = new_cons - pairlist = pairlist=>cdr - else - arglist = new_cons - pairlist = arglist - fin - pairlist=>car = new_cons - pairlist=>car=>car = argsyms=>car - pairlist=>car=>cdr = sweep_stack[argbase] - argsyms = argsyms=>cdr - argbase++ - loop - push_sweep_stack(assoc_list) + push_sweep_stack(assoc_list) // Save current association list assoc_list = funarg=>cdr=>cdr=>car // Swap associcate list pointer - if arglist - pairlist=>cdr = assoc_list - assoc_list = arglist - fin + argsyms = funexpr=>cdr=>car + build_args(funexpr=>cdr=>car, argbase) if trace - puts("FUNARG call:"); print_expr(funarg); putln - print_expr(assoc_list); putln + puts("\nFUNARG:"); print_expr(funarg) + puts("\n ASSOC:"); print_expr(assoc_list); putln fin funexpr = eval_expr(funexpr=>cdr=>cdr=>car) - funarg=>cdr=>cdr=>car = assoc_list // Save current environ - assoc_list = pop_sweep_stack + funarg=>cdr=>cdr=>car = assoc_list // Save updated FUNARG associations + assoc_list = pop_sweep_stack // Restore association list return funexpr end diff --git a/src/lisp/s-math.pla b/src/lisp/s-math.pla index a2e77b7..3ff10ac 100644 --- a/src/lisp/s-math.pla +++ b/src/lisp/s-math.pla @@ -16,6 +16,7 @@ import sexpr const ARRAY_TYPE = $40 const MARK_BIT = $80 const MARK_MASK = $7F + const NULL_HACK = 1 // Hack so we can set APVALs to NULL struc t_elem word link @@ -53,6 +54,8 @@ end res[t_numint] nan = 0, 0, NUM_INT, 0, 0, 0, 128 // NaN +res[10] tempext + def eval_num(expr) var result @@ -115,6 +118,11 @@ def push_num(numptr)#0 fin end +def natv_numberp(symptr, expr) + expr = eval_expr(expr) + return bool_pred(expr and (expr->type & TYPE_MASK == NUM_TYPE)) +end + def natv_sum(symptr, expr) var num var[2] intsum @@ -439,22 +447,6 @@ def natv_max(symptr, expr) 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 @@ -784,9 +776,19 @@ def natv_rotate(symptr, expr) end // -// Install math functions +// Install numerical constants and functions // + +fpu:reset() +fpu:constPi() +fpu:pullExt(@tempext) +new_sym("PI")=>apval = new_float(@tempext) ^ NULL_HACK +fpu:constE() +fpu:pullExt(@tempext) +new_sym("MATH_E")=>apval = new_float(@tempext) ^ NULL_HACK +fpu:sinX() // Force load of ELEMS library +new_sym("NUMBERP")=>natv = @natv_numberp new_sym("SUM")=>natv = @natv_sum new_sym("+")=>natv = @natv_sum new_sym("-")=>natv = @natv_sub @@ -799,8 +801,6 @@ 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 @@ -829,6 +829,5 @@ new_sym("BITOR")=>natv = @natv_bitor new_sym("BITXOR")=>natv = @natv_bitxor new_sym("SHIFT")=>natv = @natv_shift new_sym("ROTATE")=>natv = @natv_rotate -fpu:reset() return modkeep | modinitkeep done diff --git a/src/mklisp b/src/mklisp index 872cde2..97aafa0 100755 --- a/src/mklisp +++ b/src/mklisp @@ -33,3 +33,4 @@ 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 +cat lisp/lores.lisp | ./ac.jar -ptx DRAWL.po lisp/LORES.LISP TXT diff --git a/src/mkrel b/src/mkrel index 48aada1..c0b3ad5 100755 --- a/src/mkrel +++ b/src/mkrel @@ -188,6 +188,7 @@ 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 +cp lisp/lores.lisp prodos/bld/lisp/LORES.LISP.TXT #mkdir prodos/bld/examples #cp samplesrc/examples/ex.1.pla prodos/bld/examples/EX.1.PLA.TXT