From 7dd569b809bfb29667206b012bde709fc5412699 Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Sat, 27 Jul 2024 14:20:37 -0700 Subject: [PATCH] Allow cset with FUNCTION --- images/apple/DRAWL.po | Bin 143360 -> 143360 bytes src/lisp/s-expr.pla | 145 +++++++++++++++++++----------------------- 2 files changed, 64 insertions(+), 81 deletions(-) diff --git a/images/apple/DRAWL.po b/images/apple/DRAWL.po index f5a1d79591dc15853c4ef6a26225e06dd61bb951..df97acad98306a4c0e0c9f33eb9f23c7dafc072f 100644 GIT binary patch delta 3542 zcmZwI4^ULc9S88=zI%84QRMh@z(F{Vy8}e)6VWO|G7SrgP%>YN9row6+8V`Ez2*I8o93>BJ^&I@36lOz6}ZDzz!&)JZdr+V8$Q z5RN#0Zg+ogf4lp3_m0l-_|Eb8^A%#!{bKzhqA{}aO1D?cUOgQlUJ^_gT01?U)yV1vHEa?X2yK0?V0!zd_5Yt31`tZ8PJEk4Q)9G51dGM`rn) z@5l|xmTPL=bu)=13XIW}m>0M~v_D7KLnNm>NxMfDoMao4g&vD4_pa26lG=w;2p z7Q4}JDAjlP#h==ZJL0#+3w|oqH}*HWWx5&1>G;1>~U*b$HZzCEeMe!;gk zH(-eL)w&}ceYC3I;2X=0G_F#~RXd+xXa6kb1R`<;&}NRzj1EcjTq;E94iU?la`J89a+gO7zsrven(-l*@dC z5q$s5L`j&thI#dXQf*Y@ZB;vviN|J&EPMM&GL2Sdd>5r*eHWG2s&&1 z1N3aJQ7$4WF3DHxtZ-}d8r1%C%q)2~@Bws9E$8NUNy^^Jb!FA6{K3w)~yhbs!G=NL(AYsX0ZYzU`OOls+Q<`m>S_3(KXSlwf3qt3oW zzG?jR%6+%;c8J;lk^Sq81aMyu;&w#$G=G5QYjC+W|8+#pEW?6 za297KL=L%lh(G^)8jgiSc+an9&H!QL+ZHc%c ze2JZX89c0QQQv|{M$3q?T(*;xGJP18^(Ie+ud2qQouv@HLpuz|hnO{6Tet7IG=7#H z{G%yA{7Z&|SU<$t`5W{PvA(>l{5DZGM%EB{L%-PJ#l@x4xF+mGmU?8EtrSM{)q!EQ zl&5_$%uev~P?#;}kUc?_XfK>y8%& z1b*d($Ge2Pg8$LBY>K=sA~Pf98gX~|NW&M{Q+%ZVUSQP=al;JS-lD5oJ;L_zC&MFb z8881n!bXDRXbBr}dl^_?*B))a5Krd#cHNvx>x)I}ejLX-cHN1ONZB+==s zsg5=sHc4=QFWQK+OL3n1>T-9jHyTN^Njgu>bZ)Q!6FEJu=))~`NvN5g6+K1%8xVb# z=#b(o>m#Qb4PACf2A8|C%Hxg(5(*@}v$oc`J=&fqz{2a?)3Zs1lAbrGS9hSWTGD%K zH@mk*`yVfqL~kwrct>_&68*JiwEX~&`43XGnY2XGYd;jxcCq@8cbF0!%Ozp0g|NjW z6y_1W*CgD6dyr-$!2xl05(;1ow8JSFhbbTj35jqSvhoS{iiCs$5+*<@B;f!Yhe>z< zNlQp5UP8(~MoJr_k%>RBn?mqd5-BI)L--uNf_sp-h?F8&1>0dKG(iUh;Z-;aZ@^n{ z4#F@B*Wi7yB$KiRegOO7Tr!2OB#X*>C_hZrDHF*QRLDq*306P}xM4HwG*W1vQB>Md zK98~!u@_M9GU}8N>Zeh^i1;Oxmk~=%Ateu%!%A2K>%a+>unTrW7YxAX@b8o$DGyOe zP9^0DutG6xg?HgT=+a0rf(@R6O|TnU;UGK*3WVSUoPiz~g6nV-Zo@b5WI8Dg=@e>D z7nL8QJQPgVDMt`|30{S_U=YIa5ik=eg(eC)P3F)uCQo&5RzQiF zLYvLjV5r(`5BbbCWjlgDguT!T?Qj^5fC63c3LJye&G{Zjl5j+nsz{?PV6Yy&|17{%& zqwoRz32wrda2x&u|0~7ELx|5IWf5e71qxv~tcCSZ2{JUmPH0vKuCPh|^L*+m+qI}L b@9M`NfAr-if4T08zm+${giGwqHP-rnL9d0s delta 3703 zcmaLZ4^Wfm9S88=^X5%Jg(RSn1f--%K&s~}rA(1hX&@1qA*A8OD$biAgu|!6G8lg)Ozh|wd>6*SFQ8fde_a`TjyD&y0h0-ud?s+CP9e3 zd4BTz{XNg`dEPhC&I{?C7t#l6#LRC>($a}ekeye$0%C4ivWIv@prV?3&;6z4l>B3O zfF_gMtc~(Ot1`ERaNjF*=@dfMKHRc|tppFRPONGc=`#Rhfj50@c^c9#a3-%i5-eM4yS) zIn5zMxqf3v{HfF2oUZ<&mn~dx(1nD~{wWj^%5|;lhRoHz0+KSSTiWbCcYU?TU166A zgYu;ultj&j5Lzw^pRaF4NJy0D=gXt{f$Ws7=knL&n|=3@l$I$6-8J3{Z5{RTerAh? zgfbqjEzoROW)wmcZ-m8iVbv_NVGV8ynb`ozNpDxBiA+fwbUqa#AYK! z(s5OCdv*!VJwHE^5zkJ`7B{DDi}fOgWG$2-$4@(pr1VUzim!2eP3^eG_&hCM#$$=? zV>V_~d-t)T8CMw==V`jO^O~+TY)GE_E%hoUI$mdiJ;a||tIvvqXf-V%x$>R};n-W$ z8GUR9f8G^+%%0=L3RmEY4E%}=0X-o$WbhZ^Lh8bimdDn% z*+Wl+S8rOoK0M(*A{6+X@2@5KOJ2iO9yPo0IPfkYE%_|+2)v_S>|^Cccrmc*g!~Fg zGRNN~d;60c+E;ICZ&P3GXQ9&U+aZD9CpD)p69v@s%!zv^ty_Bngxn(}zm#19YVCgJ z79Mh_Tlcd_*+@Z{I{PQ{b7~J-KIdo_wUy#W?u>Wfd$tKLPU0HM23R4#s}%z*#LE){ ztinH1@bD(FP2}^Zjawir?8Dn7#2-k>!^!pei^kvn2y)(s?GsD;KOe& zNI|FnGJ29x^5&^HP-JX6ves?X)=6Zx{Q$G`jD`-dGS^4}dMBI)8{TQ7W)RfqL1x!s zp1S)Wv+`>>dXR14OUypR`tR*242wQ)0DiNXZbJ z&C8WTY$$r&wQkUiOD#I%l5{ohpxkZYtxtH%lWeuPB(bK!-slM56hbLlWI` zLw%xYaY};skwoKbroN>CMgHtRTzfra0~QCQZm5;ONEZ=!wzbL}Ql9yC#`$s{VxC|8N)(kH(2c>rU{XKI zV<_K1-*MDWBH(@0KY)M3CHODg1TvE{2{K?ctcRaNKfD2#%@oVb5|!*MidnLB%A71x zDxelt!4p|gQnq05_n7oYl&@gYO$v47d0>Y^m<=UR2J_(&kYO|IfnoS3d;v5S zHwam9FD!-uxB@qTO(SJ$6d!Y;9AsDt?XU(m!qc!7RM-hG!x1!Lrc;b^L?u0kVpDQ-%7Zyb z3^t*?9sPemc^>5@^y#gnm|-eRhx=fzm16U(g5pNK7ImLhr#y=K4wUo!bflsF2NV@C9r57DQRE=3*>_nW+&^m6Yj3ho`LF!B<7}1D2>G$9E Qq@QziG2zQUon(*w51(he0{{R3 diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index 5c53c80..6ded837 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -738,7 +738,20 @@ def eval_args(argvals) return sweep_stack_top end -def build_args(argsyms, argbase)#0 +def set_args(argsyms, argbase)#0 + var arglist + + if argsyms == sym_nil; return; fin + arglist = assoc_list + while argsyms + arglist=>car=>cdr = sweep_stack[argbase] + arglist = arglist=>cdr + argsyms = argsyms=>cdr + argbase++ + loop +end + +def pair_args(argsyms, argbase)#0 var arglist, pairlist if argsyms == sym_nil; return; fin @@ -760,80 +773,24 @@ def build_args(argsyms, argbase)#0 argsyms = argsyms=>cdr argbase++ loop - if arglist - pairlist=>cdr = assoc_list - assoc_list = arglist - fin + pairlist=>cdr = assoc_list + assoc_list = arglist end -def copy_args(argsyms, argbase)#0 - var arglist - - if argsyms == sym_nil; return; fin - 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("Bad LAMBDA: "); print_expr(expr); putln - return NULL, NULL - fin - if curl == expr - // - // Overwrite argument associations - // - copy_args(expr=>cdr=>car, eval_args(argvals)) - else - // - // Build argument association list - // - build_args(expr=>cdr=>car, eval_args(argvals)) - fin - if trace - puts("\nTRACE:"); print_expr(expr) - puts("\n ASSOC:"); print_expr(assoc_list); putln - fin - return expr, expr=>cdr=>cdr=>car -end - -def eval_funarg(funarg, argvals) - var funexpr, argsyms, arglist, pairlist, argbase +def apply_funargs(funarg, argvals) + var funexpr, argbase funexpr = funarg=>cdr=>car // Lambda expression if funexpr->type <> CONS_TYPE - if funexpr->type & TYPE_MASK == SYM_TYPE - if funexpr=>natv - return funexpr=>natv(funexpr, argvals) // Native function - elsif funexpr=>lambda // DEFINEd lambda S-expression - funexpr = funexpr=>lambda - else - funexpr = assoc(funexpr) - fin - fin - fin - if !funexpr or funexpr->type <> CONS_TYPE or funexpr=>car <> sym_lambda - puts("Unknown FUNCTION:"); print_expr(funarg); putln - return NULL + return funexpr=>natv(funexpr, argvals) // Native function fin // // Build arg list before prepending to new assoc_list // - arglist = NULL push_sweep_stack(assoc_list) // Save current association list argbase = eval_args(argvals) - assoc_list = funarg=>cdr=>cdr=>car // Swap associcate list pointer - argsyms = funexpr=>cdr=>car - build_args(funexpr=>cdr=>car, argbase) - if trace - puts("\nFUNARG:"); print_expr(funarg) - puts("\n ASSOC:"); print_expr(assoc_list); putln - fin + assoc_list = funarg=>cdr=>cdr=>car // Swap association list pointer + pair_args(funexpr=>cdr=>car, argbase) funexpr = eval_expr(funexpr=>cdr=>cdr=>car) funarg=>cdr=>cdr=>car = assoc_list // Save updated FUNARG associations assoc_list = pop_sweep_stack // Restore association list @@ -858,7 +815,7 @@ export def eval_expr(expr)#1 expr = expr_car=>natv(expr_car, expr=>cdr) // Native function break elsif expr_car=>lambda // DEFINEd lambda S-expression - curl, expr = apply_args(curl, expr_car=>lambda, expr=>cdr) + expr_car = expr_car=>lambda elsif expr_car == sym_cond // Inline cond() evaluation expr = expr=>cdr while expr @@ -879,29 +836,42 @@ export def eval_expr(expr)#1 fin fin else // Associated symbol - expr_car = assoc(expr_car) + if expr_car=>apval + expr_car = expr_car=>apval ^ NULL_HACK + else + expr_car = assoc(expr_car) + if !expr_car // Make sure we don't hang + puts("NULL EVAL:"); print_expr(expr); putln + expr = NULL + break + fin + fin fin else curl = NULL // Set-up for in-line LAMBDA fin - if !expr_car // Make sure we don't hang - puts("Invalid function:"); print_expr(expr); putln - expr = NULL - break - fin if expr_car->type == CONS_TYPE - if expr_car=>car == sym_funarg // FUNARG - expr = eval_funarg(expr_car, expr=>cdr) - break - fin if expr_car=>car == sym_label // LABEL new_assoc(expr_car=>cdr=>car, expr_car=>cdr=>cdr=>car) // Add LABEL - expr_car = expr_car=>cdr=>cdr=>car // Continue evaluating LAMBDA expression + expr_car = expr_car=>cdr=>cdr=>car // Continue evaluating LAMBDA fin if expr_car=>car == sym_lambda // LAMBDA - curl, expr = apply_args(curl, expr_car, expr=>cdr) + if curl == expr_car // Tail recursion: overwrite associations + set_args(expr_car=>cdr=>car, eval_args(expr=>cdr)) + else // Add argument association pair list + pair_args(expr_car=>cdr=>car, eval_args(expr=>cdr)) + curl = expr_car + fin + expr = expr_car=>cdr=>cdr=>car + if trace + puts("\nTRACE:"); print_expr(expr_car) + puts("\n ASSOC:"); print_expr(assoc_list); putln + fin + elsif expr_car=>car == sym_funarg // FUNARG + expr = apply_funargs(expr_car, expr=>cdr) + break else - puts("LAMBDA expected:"); print_expr(expr); putln + puts("Invalid EVAL:"); print_expr(expr); putln expr = NULL break fin @@ -930,12 +900,11 @@ end export def eval_quote(expr, hook)#1 hook_eval = hook - push_sweep_stack(assoc_list) assoc_list = NULL push_sweep_stack(expr) // Keep expr from being GC'ed expr = eval_expr(expr) pop_sweep_stack - assoc_list = pop_sweep_stack + assoc_list = NULL return expr end @@ -1080,12 +1049,26 @@ end def natv_function(symptr, expr) var funptr + expr = expr=>car + if expr->type & TYPE_MASK == SYM_TYPE + if !expr=>natv // Not native function + if expr=>lambda // DEFINEd lambda S-expression + expr = expr=>lambda + else + expr = assoc(expr) + fin + if !expr or expr->type <> CONS_TYPE or expr=>car <> sym_lambda + puts("Invalid FUNCTION:"); print_expr(expr); putln + return NULL + fin + fin + fin funptr = new_cons symptr = funptr symptr=>car = sym_funarg symptr=>cdr = new_cons symptr = symptr=>cdr - symptr=>car = expr=>car + symptr=>car = expr symptr=>cdr = new_cons symptr = symptr=>cdr symptr=>car = copy_expr(assoc_list)