From 0ddec876ac6b84dda006f9987e56753bba31f34e Mon Sep 17 00:00:00 2001
From: David Schmenk <dschmenk@sbcglobal.net>
Date: Fri, 12 Jul 2024 11:59:51 -0700
Subject: [PATCH] Added PROG feature through s-expr extension mechanism. Really
 easy

---
 doc/DRAWL.md          |   3 +-
 images/apple/DRAWL.po | Bin 143360 -> 143360 bytes
 src/lisp/drawl.pla    |  90 ++++++++++++++++++++++++++++++++++++++----
 src/lisp/s-expr.pla   |  14 +++----
 src/mklisp            |   1 +
 src/mkrel             |   1 +
 6 files changed, 93 insertions(+), 16 deletions(-)

diff --git a/doc/DRAWL.md b/doc/DRAWL.md
index 6a9cf9d..4d96269 100644
--- a/doc/DRAWL.md
+++ b/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.
 
diff --git a/images/apple/DRAWL.po b/images/apple/DRAWL.po
index 871859c4f91ea7c916b654f4793a23e2d4b9f4d2..8db68656169373952c892c618aabb52d5f7ffec1 100644
GIT binary patch
delta 4341
zcmaJ@eQZ<L6~Fh{`5?sb5<Uu9fGgvq&n7q_R4b%PAS5B6I<e<CS;&yWv;CadygVC!
z0TIHuT1%^SbY7}G<qs(Bs&1sy21N_B-Tr8&ZQ36#V{B#J+7)Q`RZ(eGr>c`SvUBhI
zu;Z{<xw+?@dw%EZo_p^*b*uW+t?G+CR@>dSj^zmb3=vAq_^b^N84^SZ4mI}-^loe4
zfs9|}c2tA9dA3S{jF>rB0%WE*B=|fd1MVVpp%;K>>r5b1o4LCbcw^|mkl~HaD~AzA
zh%<qVnCYl!FoS23%VNcAl^m+NyrFjCtd*rh<~A?Zneok)B{+<l_wM)f?f04<?`2UH
zT3b`*?%Yz~>TZAk(4!^}-OEFqztjp+tjyh|z^46!f$i-jz^@}K`cFlf$BvhmB>3{{
z&l=nFplvynWZ8pFLw%z@e~GOZP%YZNda*6lw;Ml@o8P@ydLA|P`n$jCDFOc)0(qh=
zkn_mN)Z9K#x29_SEn1F#vZ~zLx}m;++p~YjryI2X3F`58Y^de5%A7~*L8nyF`T^)Y
zZ|WIpjRW1jQcdeEQ2TRPdC#MD{XM;lyxs=2`6X)W_o`AiUKzRrtKV9>>hXGgC048-
zg4(A`)qH+$f2rC>pk^<Rd<JvQ`91hhpGs1=dJQ2*C!?}Nq+^Msjp#o$ej2w{o80+B
zc(s~&2G^-ap1|u?P<bS(=-Mi*e#uH@S3Wt7@2sgEw{Q|d?R+hIzh139hd0jDa5cHn
zY8*j3DuO5N{7J%RIbbZoEb`SOMxg+rL<NW<Xz-H-H0|JhF%+}&RLx4~ir}=Jk63qb
zhg`hFi-58OW6ivyi;@7W^tGT!B?#dUti=T0v04{Y1aq3O&9{PzsCJ}s@Wz6#8o;33
z1`d8uiDC}^)ZjN4BHT3Lfrf>#>QRmcZV5s_Xp9@J)VM5)(JXu$QG|oV2y)mc#bQKb
zm5hWWxxw2D?oC3!w~e^nZYK##sdQ8k)6uv>lz5s%;u$5}!E%Rx@CR6MNRG9sZRhaF
zqbKS>mgU+a+?aKgL$MY<=H^|wSUnn1kf#v=_X;|5sKHSMWjm9Ftf?U3Tg6m)G}6{Q
zTQ}|EuU-GmWz5~fwlOHY=Zyt2#s%K2Q{Ov>n;TEm9R$=tFb|@^DioNl8{<HNnwQn9
z8=u1u=a>mCJ_Q}}^n<V13N&)Eh4*Zvj$FBhSR?hdvmSi8PJ!yQoA+%(Zhlx1gV0^+
zIEg1DrGvmygyso<W1JfYG;&(t-PRuOU@x%K&3tn^u(X+h-C;@Qn!n)PT)$W2nm^{<
zmHxiKuzye&jMcd<dk*yJTmra(z5$I3jMhVk0UdMkBQR-ylWn}`?gG&0AlJ?#?qe8V
zz!<ATTmr@k7_%_mgt4q1<+z>oh#Rd(`9~1ScOg_5LR<17prbI3z&HxyDUd&pn({Bg
z{A1Kqcnj$3AioLY7K{%;{uhva2DAmEd;>;>0c<V!@#exXw&cfwm$9pm#(d!zb`~DP
zRfXqpRem1lP~lbV$o~RBzXGMV@uvJup#KKrQ{evz{J((yH;ft%6<RrKzMVt)FT?1B
z(F0>23=gb%IY;3!SbrS&CxQP4x1n%`+gO<8Hs#NP?7JYl0Q3)mz6A6<w<7;)42bKT
zweSv%cR5SpHs>mQ#5Lvr3i5w&uKZ`9{5jAIKv!5$q1NKc*TcL4=FKo~fq5IuJ7L}h
zbDzbM-v_hD(p2zTHW&OBdwv-BuURZA*@Yia-+BROmcRY;n;*P!<HoffehXY#Cti9H
zb2T@9_s-4Vzx#(jzV|+K^XGW}`}lQi6O}OBUTH~5!KqSTyMUd!te7N;WPGB9{U4`y
zn@%RBbS9~g)>hJ!NhT#FO=zF7+fPbS11TE?r;bmJhvH!Pem?*Y9iIxuWjMY`Le&H(
zLnV?@cs!lVxTOC9^MOJ%B&H>X4ETrp)H@e&+sYDkFz#2^&S9ZUxL4gXhaF|Yuc)y(
z+?W$s4(x)FMP(u*PSE>YuZXR+)n*Gz5dzmvcAQp4p!IOV^=*`C9O@t$6$*(!(WF?}
zY@kLlj3K0xRjRWq6sC^_U4YPYH2lsIHOOH&5vFN|?q6inDD|sDwHnacirFHNx&Un&
zanU(!P*Gb-cacnj$nlUU(~P3@!bt(9>|Il&qvK*K6%VoWAqAS};IPM|{^)5;ax6)`
zJ35)%G*Qf-wi>;*OO!!NuMikqR0igvxU8pO8e>JIjo6(^Wu`Vj%5eqWh75Zg7%Upm
z9EC(R4sWdb%;R{~_RyphI?UQfpcf_)=(f|%q(9hdjVMBson7ks)A*sBxuwQdLA=IB
zY9Os(rk-w!u7NozE6S`11XF<}$o@G=C*6Oo`=t^f?3|9<np_GD(*VSzlUAWO8BdU;
zl*-6yz_Skx=&Ryq1`WgX3@MoO;vD37JfZuS<Ww;fBaEcLHsJnVsSm?rYpbM^r*K1#
zY$d6~(L@W0x+OP(r<^Q$#&u_U<u$Y(1odPTo1HMw)jO;#98K!9NlLintTJg%F^_9W
z*Oi`yqE*_>w3dO%XbO&koRP@Us4SD9M8Z(sgcK%G`0g<7fiia!anlpM7-TUh$t@%|
z5vO+m>)tZ2OhZqQx*ZCM3hP)RM^kAyk@3S(WrFqUl$Z`pQfBDD09eyHjp2b~{lys8
z4z!o3JGKIsi+N(em7&G1ABxoLNi%2q#`YPpEdm((l1ZloJKf3u^G#-VJ_4Sj%C5B5
z^)w<X%A{rb<y-2P?HV)yl)&HT^UwlE;R>6S<b;&G^7I_uSJ_e0j9>!Xmwy;Be{>}R
zU*n26B^l1tYZtL2XPhm%1?EYlR~o!jf<0h&vP0A(Cg6FK^u3Qq2z_E~#mB6Zm=Jn-
z*cpg*OKLKnk;6m`r8A-|A17?X2vxFCNDFgApBcNevx{~R)V`DKF7}dXxZkVZp2cgN
z&^M+``&=`j22d-ax^NM%RS(SK<?4n@cs--mPDxW@R*cHFgqTc8<Dsdr991NB?<M^0
zmtMiO-?@sbwnCjI(vw7x#i?LegxR<TX=7+VcG`)MAz5|zRlItckdo3zNS3rQ_F;|9
zkozFP9=&3SASf9)LK$a^pznFssqVUp*Q_wW0z8H!Q!2|6VGG#?KB-=#FcBx>($JXX
P%J;6~19<+Y_*v<{oeH#K

delta 1620
zcmZWoZA@Eb6h7znLRX-0i)?Jj$CZ^!sgbf_bRiBYP$pR5hISPQ33PhP+CjrQR_3CX
zn_yU?nOsY9e<+9~@B^k%iC~7ApNX4){Fut-R~8e082RI0ldYcH+OD)W?|I+nocDRo
zdEayIoxZbg`p&-h+F0Y?4aG$OUjVOxsK}N*nv8%37!caJ+m9SQ2FWM45%R#!#dkGf
z97Gq>gz;1iSVX6%yZ*j3)=t6&Q%V@8MR&7>H(dj+WHoIqItd8Cq=a!0ZOSQ29X=k}
z@aA02WiYl;Q4m{T<JaNW4)5he#kGtJo&=$z)9L8!O;x-X20a|e%P6;)EiAG3op3#!
z(!o8M&iPfMA@@78n=P#A>~S|9O%u)l3wLueDmJZWU2uJSKKXiTjd|1(Lv4-A(J%I;
z<ywXUXe`;AOBGwNH1cxG-slq4wD;Mcai)pC1s$~MGHG>jTD|DBC#dXA>d<_CChefh
z;jVXfy2SqzvbU)pe_@gqNpxlj4iP7v$o@>cw^O_%t-RYVrZd@Ji1uejdzawgiMIAV
zRevSgW)|&Ghbq~z=!xHGcP@L^+1o3oWnq6O+CQ1JC^F(^D~>pd3_L$|+CL`o(uIkT
z(V)IKi#9Z<OCwmKUY|u{DG{{iR7mokF~%LAKS)Hpg!|F3Re1^j*dOJXBL&xykpL{5
z0bVhw1&dgj+s`0>K~PV<g&t2A=LQHf4L)X&?PnlR%>~SyH4-QWPY|5tK;8#%d8Ev&
z2OnGxLn1ICJ`ksJ;As#>xr;mpgNzTHpT+n=#y!WWh07?EcX2}`AELAr>d}LHlpACy
z0>Tcbip%(TBrc@`&<MhavzBTE3c>SIHRpU#D`1V31<JJ=dK1;KP808<nUc5#lVIWM
zb*%#q3LVphgl6)(9o-2}EY>mxc+NvhVw@H@=WdKJ3^5iCm}auBdYVSb=E!!)^d?{g
z6UdJMC{18hT7gqKpiU7%uZ(~5-3Br-jOgVV+MWfoJP#nNgx`cJd4({26Y?kIe@;IA
zrSjKgx5&Q>toGx|ELlF8iR=Jb8G=%QW<^9+c9HKPe*i0#A*@tJu}VHev9lDLBK!j3
z2;rH>uuz^Q=T)-TD4?QMUZ8aat;)Noliw%&A=W4#;bCPPtL1Cte~CJke-cYob_LHz
z8RpvRDl)m>|M25aJGbak|KjEvZlii*9WCk`SJ1}VY<x()eFZHV@~PZAXch>aJ@237
z{lQ5oG!c?$=6z${QKQjjqrvxhC;ee*Yi0wV%2o5PV%0<5&^c-N+41Mb{6WbWl%|Hy
zJwI-#rgv6dcf2|1oeZlF(+Robe2eA`k4xj;u-8AP2DkBb`gAR;A7jB*%MJY0r_C+-
F{{ba|i536=

diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla
index afe4ae8..605f770 100644
--- a/src/lisp/drawl.pla
+++ b/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
diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla
index c264993..ef23131 100644
--- a/src/lisp/s-expr.pla
+++ b/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
diff --git a/src/mklisp b/src/mklisp
index 17e07d0..ce2edb1 100755
--- a/src/mklisp
+++ b/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
diff --git a/src/mkrel b/src/mkrel
index 1d0c072..8626861 100755
--- a/src/mkrel
+++ b/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