Added PROG feature through s-expr extension mechanism. Really easy

doc/DRAWL.md

@@ -4,7 +4,6 @@ LISP interpreted on a bytecode VM running on a 1 MHz 6502 is going to be sssllll
 
 ## Missing features of LISP 1.5 in DRAWL
 
-- The PROG feature isn't present. Programming is limited to interpreting lambda S-expressions
 - Number values are limited to 32 bit integers, no floating point
 - General recursion. The 6502 architecture limits recursion (but see tail recursion below), so don't expect too much here
 - Arrays not implemented
@@ -17,7 +16,7 @@ However, the code is partitioned to allow for easy extension so some of these mi
 - Tail recursion handles handles deep recursion. Check out [loop.lisp](https://github.com/dschmenk/PLASMA/blob/master/src/lisp/loop.lisp)
 - Fully garbage collected behind the scenes
 - Optionally read LISP source file at startup
-- SET and SETQ implemented for setting variables
+- The PROG feature now present!
 
 LISP is one of the earliest computer languages. As such, it holds a special place in the anals of computer science. I've always wanted to learn why LISP is held in such high regard by so many, so I went about learning LISP by actually implementing a LISP interpreter in PLASMA. PLASMA is well suited to implement other languages due to its rich syntax, performance and libraries.
 

src/lisp/drawl.pla

@@ -49,16 +49,85 @@ import sexpr
 end
 
 //
-// REPL interface to S-expression evaluator
+// REPL and extension interface to S-expression evaluator
 //
 
+var prog, prog_expr, prog_return // Current PROG expressions
+var sym_cond                     // Symbol for cond()
+var pred_true                    // Predicate for TRUE
 const FILEBUF_SIZE = 128
-var readfn            // read input routine
-var fileref, filebuf  // file read vars
-byte quit = FALSE     // quit interpreter flag
+var readfn                       // Read input routine
+var fileref, filebuf             // File read vars
+byte quit = FALSE                // Quit interpreter flag
 
 //
-// Native functions
+// (PROG ...) language extension
+//
+
+def natv_prog(expr)
+  var prog_enter, prog_car, cond_expr
+
+  prog_expr  = expr=>cdr
+  prog       = prog_expr // Update current PROG expression
+  prog_enter = prog      // Save current prog
+  expr = expr=>car       // Set up local variables
+  while expr
+    new_assoc(expr=>car, NULL)
+    expr = expr=>cdr
+  loop
+  prog_return = NULL
+  while prog_expr and not prog_return
+    prog_car  = prog_expr=>car
+    prog_expr = prog_expr=>cdr // Assume continuation
+    if prog_car->type == CONS_TYPE
+      //
+      // List - check for (COND (...))
+      //
+      if prog_car=>car == sym_cond // Inline cond() evaluation
+        cond_expr = prog_car=>cdr
+        while cond_expr
+          if eval_expr(cond_expr=>car=>car) == pred_true
+            eval_expr(cond_expr=>car=>cdr=>car) // Drop result
+            break
+          fin
+          cond_expr = cond_expr=>cdr
+        loop
+      else
+        eval_expr(prog_car) // Drop result
+      fin
+    //else
+      //
+      // Atom - skip, i.e. (GO ) destination
+      //
+    fin
+  loop
+  prog = prog_enter
+  return eval_expr(prog_return)
+end
+
+def natv_return(expr)
+  prog_return = expr=>car
+  return NULL // This value will be dropped in natv_prog
+end
+
+def natv_go(expr)
+  var label, go
+
+  expr  = expr=>car
+  label = prog // Scan prog list looking for matching SYM
+  while label
+    if label=>car == expr
+      prog_expr = label=>cdr
+      return NULL
+    fin
+    label = label=>cdr
+  loop
+  puts("(GO ...) destination not found:"); print_expr(expr); putln
+  return NULL
+end
+
+//
+// REPL native helper functions
 //
 
 def natv_bye(expr)
@@ -149,6 +218,8 @@ def parse_cmdline#0
       fileio:newline(fileref, $7F, $0D)
       readfn = @read_file
       filebuf = heapalloc(FILEBUF_SIZE)
+    else
+      puts("Unable to open: "); puts(filename); putln
     fin
   fin
 end
@@ -157,9 +228,14 @@ end
 // REPL
 //
 
+pred_true = eval_expr(new_sym("T")) // Capture value of TRUE
+sym_cond  = new_sym("COND") // This should actually match COND
+new_sym("PROG")=>natv   = @natv_prog
+new_sym("GO")=>natv     = @natv_go
+new_sym("RETURN")=>natv = @natv_return
+new_sym("BYE")=>natv    = @natv_bye
+new_sym("MEM")=>natv    = @natv_memavail
 parse_cmdline
-new_sym("BYE")=>natv = @natv_bye
-new_sym("MEM")=>natv = @natv_memavail
 while not quit
   putln; print_expr(eval_expr(readfn()))
   gc

src/lisp/s-expr.pla

@@ -541,13 +541,13 @@ export def eval_expr(expr)#1
           curl, expr = enter_lambda(curl, expr_car=>lambda, expr=>cdr)
         elsif expr_car == sym_cond // Inline cond() evaluation
           expr = expr=>cdr
-	  while expr
-	    if eval_expr(expr=>car=>car) == @pred_true
-	      expr = expr=>car=>cdr=>car
-	      break
-	    fin
-	    expr = expr=>cdr
-	  loop
+          while expr
+            if eval_expr(expr=>car=>car) == @pred_true
+              expr = expr=>car=>cdr=>car
+              break
+            fin
+            expr = expr=>cdr
+          loop
         else // Symbol associated with lambda
           curl, expr = enter_lambda(curl, assoc(expr_car)=>cdr, expr=>cdr)
         fin

src/mklisp

@@ -24,3 +24,4 @@ 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/prog.lisp                 | ./ac.jar -ptx DRAWL.po lisp/PROG.LISP TXT

src/mkrel

@@ -184,6 +184,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/prog.lisp         prodos/bld/lisp/PROG.LISP.TXT
 
 #mkdir prodos/bld/examples
 #cp samplesrc/examples/ex.1.pla  prodos/bld/examples/EX.1.PLA.TXT