Add LORES graphics to DRAWL

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

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)

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
+def build_args(argsyms, argbase)#0
-  var argsyms, arglist, pairlist, argbase
+  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
+    copy_args(expr=>cdr=>car, eval_args(argvals))
-    while argsyms
-      arglist=>car=>cdr = sweep_stack[argbase]
-      arglist           = arglist=>cdr
-      argsyms           = argsyms=>cdr
-      argbase++
-    loop
-    if trace
-      puts("TAIL call:")
-    fin
   else
     //
-    // Build arg list before prepending to assoc_list
+    // Build argument association list
     //
-    arglist = NULL
+    build_args(expr=>cdr=>car, eval_args(argvals))
-    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
   fin
   if trace
-    print_expr(expr); putln
+    puts("\nTRACE:"); print_expr(expr)
-    print_expr(assoc_list); putln
+    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
+  push_sweep_stack(assoc_list) // Save current association list
-  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)
   assoc_list = funarg=>cdr=>cdr=>car // Swap associcate list pointer
-  if arglist
+  argsyms = funexpr=>cdr=>car
-    pairlist=>cdr = assoc_list
+  build_args(funexpr=>cdr=>car, argbase)
-    assoc_list    = arglist
-  fin
   if trace
-    puts("FUNARG call:"); print_expr(funarg); putln
+    puts("\nFUNARG:"); print_expr(funarg)
-    print_expr(assoc_list); putln
+    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
+  funarg=>cdr=>cdr=>car = assoc_list // Save updated FUNARG associations
-  assoc_list            = pop_sweep_stack
+  assoc_list            = pop_sweep_stack // Restore association list
   return funexpr
 end
 

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

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

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