From f77c0e9a9e33daa18528ff728d700571314ce6e5 Mon Sep 17 00:00:00 2001 From: David Schmenk Date: Fri, 2 Aug 2024 07:58:09 -0700 Subject: [PATCH] Convert all errors to exceptions. Add nice aliases --- doc/DRAWL.md | 26 ++- images/apple/DRAWL.po | Bin 143360 -> 143360 bytes src/lisp/defun.lisp | 3 + src/lisp/drawl.pla | 64 ++++-- src/lisp/lores.lisp | 4 +- src/lisp/s-expr.pla | 478 ++++++++++++++++++++++-------------------- src/lisp/s-math.pla | 40 +++- 7 files changed, 353 insertions(+), 262 deletions(-) diff --git a/doc/DRAWL.md b/doc/DRAWL.md index 9173053..d8846b7 100644 --- a/doc/DRAWL.md +++ b/doc/DRAWL.md @@ -38,6 +38,7 @@ The DRAWL implementation comes with the following built-in functions: - NIL = NULL - CSET() = Set constant value - CSETQ() = Set constant value +- :=() = Alias got CSETQ() - DEFINE() = Define function ### Function types @@ -55,8 +56,8 @@ The DRAWL implementation comes with the following built-in functions: - AND(...) - OR(...) - NULL() -- NUMBERP() -- STRINGP() +- NUMBER?() +- STRING?() ### Misc @@ -98,12 +99,14 @@ The DRAWL implementation comes with the following built-in functions: - LABEL() - SET() - SETQ() +- =() = Alias got SETQ() ### Program feature - PROG(...) = Algol like programming in LISP - SET() = Update variable value - SETQ() = Update variable value +- = = Alias for SETQ - COND(...) = Fall-through COND() - IF() = Fall-through IF THEN w/ optional ELSE - GO() = Goto label inside PROG @@ -122,26 +125,33 @@ The DRAWL implementation comes with the following built-in functions: - <() - MIN(...) - MAX(...) -- NUMBERP() +- NUMBER?() ### Integers - BITNOT() = Bit-wise NOT +- ~() = Alias for BITNOT() - BITAND() = Bit-wise AND +- &() = Alias for BITAND() - BITOR() = Bit-wise OR -- BITXOR= Bit-wise XOR +- |() = Alias for BITOR() +- BITXOR = Bit-wise XOR +- ^() = Alias for BITXOR() - ARITHSHIFT() = Bit-wise arithmetic SHIFT (positive = left, negative = right) +- <<-() = Alias for ARITHSHIFT() - LOGICSHIFT() = Bit-wise logicalal SHIFT (positive = left, negative = right) +- <<() = Alias for LOGICSHIFT() - ROTATE() = Bit-wise ROTATE (positive = left, negative = right) +- <<<() = Alias for ROTATE() ### Floating Point (from the SANE library) -- PI() = Constant value of pi -- MATH_E() = Constant value of e +- *PI* = Constant value of pi +- *E* = Constant value of e - NUMBER() = Convert atom to number (symbol and array return NIL) - INTEGER() = Convert number to integer - LOGB() -- SCALEB_I() +- SCALEB() - TRUNCATE() - ROUND() - SQRT() @@ -175,7 +185,7 @@ The DRAWL implementation comes with the following built-in functions: - HOME() - GOTOXY() -- KEYPRESSED() +- KEYPRESSED?() - READKEY() - READ() - READFILE() diff --git a/images/apple/DRAWL.po b/images/apple/DRAWL.po index 701a75375c2a68d288bfae4538e7e9f82f96182e..fdb4bf8d3659f855dab86b33ae84c8f17c014232 100644 GIT binary patch delta 14422 zcma)@34B!5*|^WSb7wLM3ET`xNCJcqLI_!gum{AzB!oq?jLCq2s1WN^gGS`DQKMyY zEn2PA_KI~VRqKX;%C4d)3L+qtO+XM_P}@oswblhGD*2vsXC{fze*eEepLyT&o_)RN zzBjaf;BNiEy{1A>(gu%;6Jo2#R>~s3o;fUL5lYcSUPblz!9z+#>_68~ksy4A9jh|h z%A$ulWweXZM83ajYPGi`Yuk7-KA7B|(N4DLvvV^ZsGnXRt4+ynQ-q|N_Kdc&XtXo4 zz45kX{cPuEmyBCv_6e;ww9DnXuDu@6?OtU++3%-G7x|w&tDjRu-h|0jm6L1RD?ZaK z;zU})S+zcNZpIW}-NgC}+w+MtCe7Uu8JCU$`t00{{U_H1h7ReJae>gqkIu7d9R1W; z{aiHrsdE}%IKe++c*ziNMeX=XRiNu$;SnOIy{K$^99DPAXj`U;oXYXOn$C@XR%D2` z2eoIkmGwV9<@_QmUjD6Wa=pJ(;$KADt_lxlFOgZHbkS1$)4aPy|N3fQU{a@U9v4ZX zSC4a&jj!`vT-7PrH;n%kUCvIHUtbyUs&+(E>fZ~8crLm)Lb3I@TV#-?b3*+`X5}?` zc5%I`eg4iV^)n=^JSSQD#ES7hskMz{2hW;gx|%V;SMiftg_L6TS?R*F|0KJIBrzYH zQ&C~{SF?xeJ>=ag1ZRa;kC-;qv_qqJA;(lYE_ zZx6?AA!hg0uH-klMqKILkobU{BEy$IDEp?B7=hWzjl=BUQu}udzv25Il!HesP7aDv zXG62_JB4T#K~b}z|;aoefn<5gAw<&U{!FhZZM4{%u>cUJ?|PK?Q$qd;E88&05J-?;BM;1;6)* zhYiuB=N&UP>J1e1_%|x~jD%^LB(`8|ZWqy*Z(R0cKnMyU*-P&m^N3k^)B8qH%+OG4 zB1wKwNmPl%MA9|P41e*kygF23G!8KW+dVBqj284^M&k%OIKpT_FEtuR+riOB3;GzN zvCIyZ87*UsnSoGp;JxI4x4XFM^5mJ*bQu)X)1*Z!J!7{^o1stB1eH`JtKVkz(?D(h zZsMxTlT#LwwQJz!?$}Fc^t_;GDG9&xi0oB3!p`L(7P0j`j>XjScGaf_lra zaPgxur*O2LVYJb#(ddSj(Va46sv0!96V&DfwU*NG?T^Y}^3C0wQbf?8nFT#m0#CUA zV{)z>6Tbg3S=D=3YLiyw5>6Hv&$&2CRz1EwaUFt zk5n@zTFsbn!{hRSd{zn5*CQ=foGXp;ZnKlB6{I)VjmjGr9=udelIz1QOXdH_vEeV4 z%AT@cIN=HTOYL-8_^u~pmXa%?awoF#bXq|+%@5|3YRx&14{B@9E%9oXCSmdysKw?` zTDH)$#rtPU#N0FE#8+qh;&>aQTwt(vROXU!#WGo(y*b@pq)no#uga;-Dll?9qQI+) z7Xd2%{W6(H12#OrOuj1RfbcCVUFvA4 zF_4jdU-rG~crXFGa~_TG-y+-?+Oox@wgF;(TfUgyHc*UjD-xw`Ua_j}Jdr~80>d+^ zx~kDwo?*A>JoH(CJEF!xs+orH=P7GJPOhEu`f%%0GH>Ad)LfG&XmOLf+2tRg8pMHc zc7y1|2T#e=sdLXTXs#Jur@6JDcsh{+nU67Z3$n{qmgwAFc3Sm84T4T;oiPY%2q#0) zz1bDigDy;*R!HZ(psU3jp8mA#nYcNfY%|>K)<$o*^=UaMe@E{oy^2aAx&57L__sYu z`V3bj^@*ot$tCZzzx+d0lN=2JXLhGk=T^?7ag#c?FnTiC=O_o13 za&S!n$|(YK zx~mRrs(YW4)y|cBB;0eg%oxn#Rh^*AL08ai>*V!skp4elY20Jv4iS;Xqk78lhp${M z`zBwiBKH}&gCpx4b9lAPJD-KSmbW!LnR1$0VHul;;ei$(4D+%}ca(a^X* z+;xpi4_(}wpgm3)88ka?yOBGNi3z%LQ&sB7u(=u4Ksd{vc9x03bg@7?l_LC?L@RmS z$hCW_rXnz@4?S%a{<3J~E+e;psJ$?%54r;v_h#6BT2`mkYIo76lOOGdwwFtl?Oh{A$dn^Ys8SEi5v82j<9!~%#+UWly&mwh)wI{d6S*l z<8IJ@rmMs$)7V|Hvb7qnFEd<()d5oH6^-xma4K~uW-Vk0lwsJc+ZN76F63Yf`_{{X z6lZpmrp}#6wt|vz6dVq%mzg1FwmRvxXtQ*U%}6S?C3QaCMd|jj&|32;sbZb62gt)E zCmPGxsnaU5bQoR299wFz?4DPRjtuF4$Pv$u)woG;QucjDcJHh5sPXL>FzW9d4o`VT z=ET=Ts;-$3Zhc0kg|f0#b6Z!jSXB=TjPg~{rZ;Xk>@A{2pA+_)qWMia7nIjo8R`_^ zI8qH(KkDYD_Wn6mwZ;NDc1%zmpl-F}gIbk3yTbX;%3&;#OP`fJyd5oXQcFOc@;RLr zwSCBU3|07+4Kh3P|A^nbLH1&jxVU7im3C8(aaE2HnFp7B=-7R>=cq|%7uZFs(Wv>P z&2A{|p-TbhfM!i?9(8@|Xd-hJn-!Vd#Jf9?^dxKO@Zuf+CY8k=@A?IuL+lgcRnk#<;w7<&&uJUzZkjsYU9NBGe`%y;w4_<&#pOq4P4zBPXfqF^ z1ks!re&{)wkW(5vWwV=7>~5&(N{OzQNSlv8$4z8&8~2OEU{@}f*QBWCuwc{y8d>1dx>WE;fxv@l-MU!sZ)#&Ka(fLNTh_QpT6bjsMTbZ|IA?B>neyH6 zjhkcvJ?co;(W^+~{GA&YX+MpdB?3pgcUtBDy(?<8xdPk$u?I5RqE5Ri6di~EQdJd4 z6Zsd;Qp-15uO~9f_7KNTjMyM|oES~fnNVjGgUBwoA2Mf;x5h5p^Sta)^lfi7Irhx_ zKeCV``vsYk$$iRS&VJxZm>Jna%qmyHtKJXKd_m@gj&={ILS0yEHnyn~-ZL#hwcXh; z|7~ObA#Q$ljpX-4@(UjFvDRuepSOvYqlSOGXnb3p6TEpLoeeE-t6QyoVPPxSmlEzq zT*uWlgBOc|ku6$UWA{Z}r_?QvxJc(p)cK$;;LUEX<%in*b>sZ829mnkr}-ZG74#h-$4F%yw=$#1oebMaRn0 z7ORvU%ZE49L*X|!@?d&fnVBW~xgu&l>I$x=M(J2qL+rt#;5u;3=juQVvl-E%+ zxhl|-*0R~qxO$hy&+|G80tL$Qs=>WPTip0+NSSTjD+9z3(!6p)MDx0;eAVUSeJaOx z!|R$br3T-i3cYT4oz=dIx>^<3Wq9?9+M4l7-(z^S$truxKEvz4x24p-kh;oOUTHUG zKY@#;)CMY5%xfVdFW8?qIu6Oa3H`l}3SS*|6`HC-<71&ixpp1((MU&suddu&(cq6c zUfma{t&RqZ`gyg=i=u&RbG>mjQ>x1=>&8Yc-EzIIh$YYxvg_*EkFlzam9{X~>+sp# zQSDfp>(y#w%^;y(Go?y(M8(bR?{zaM6@kgMHBnRdJg;kf<%G#Ks(&iYlzgw#S6Ano z9u3dQqbHGpAv%<|JkRS?;aGbKYopJPCjN*>f8C_YY0-9WNWDUVI= z^93}_7l;MZ3z_T6npki`A>%d4R~HN4M%Y(hF?n*NsYODvZ(80pio~p$+HBnOAy^FW zL90h-%V9g<#M0)3__-Mt!BH5HBD8B@SgOz#K#w$`wZLiEoG!HC8A7`QmcyW)Lc1Q; z1Mex?4)_+bvV>L(VK@kr`UvegaApf_Opf4@Bj}YqFPiRHZEmvsQ!a`UJhrrQa zXcJ&61Ys_8&!g3_96kc)0HGB^8Pve_FdyRbg*FA!1`6#%_zs>g5L$X6Wx{Q+sZfNp zZAC(R3n%wKpvWt<3%tT?mBRcL+yQsNLiior3x9we@FDySJ_GKVW(G`zSrCM|zzJzC zfQ6c{EUnB8qc4Gn;89qig@n19$Y+Rr9>YuU3gFW<2RVc}1cn0-Q}aA110RfsiEsf_ z0}o2G9;U){m7>K^kYt%<_AJ+aJu0euVXfkW^q_LHGR&H5oxGc%HeSqvpf z!Wy1bW{yI?4(1WQk?<|(_rMZ(9F}2!F-bQ!Bey0w%r~%o58b*7)6-R0J-U{eIq3B; z3$B15G(r>H47ZXlWRh?Zfd^qJtc0WRIkbVRn=pIAXc!NTa4q}~+z$7`!>|-q!W#Gy zcw;pCzyK(Q5iklCz#rfx*kOo}`87&>vM>{qSzyU!W&wHyOoQuS9^3}E!y~{OocS`m z37^1cNTz@RI>UdkCwvhr^tRegVvcpF<;D3oYke!wa5Fc0*>F*$;gP3@1FA za2@*WOy>V*7_P?fC*<->kGYbFweSq=fRC_$g*~aKFq0t#`a%f|?a8S1EHlf|YvD4O zjV*|64tg`(0`uW+SOO0c|0wYMA zd$$DK15#9i0|zN%qI*HA9XL|$Zb{p>W&eR~k&@Q;v`bBS^R2xHE8SyqUfsKQ*Rg&3 zw~cpyma|A|zs@<>O?_Lx&=@Lq_ujhuwF5`$Y0>&22e#~~+_iVlj=${ohkNdk(?dQZ zUu$%Wsf{UOYDu2YhrUZ?SJs1GW9vAocTI@#5$t@@nYx~h{WI{Ew#qk9uMVMjKxn&LAet^W8QpL}}av(LZy=a>KbiVytX%J``ze6%9h z;qZX{a&)(4MkcMvPqtsZDQfP1IVACJBSjgD@{Fg%sYYj{FOalKe#FwNl9% zJq(RIKatUCAE{UsSJR?%s#teG4(rjm3cEJDn8fhhgEBR3gqF_$Ffc!DTmC^g_@`~V z@}TTb+wMLnD-e4R$}7*QZOvP9U@TL<-JzSX{C_0-`&)7Vg(e-6MINTeb_)*4HAH?w zzAJEH*mqb?OIoJB0ZtP6DSX|%JG|zQ9MeOY@Q7|`%THi%X5>%H$8p5K{$J&!wwIHi zV2?bX^3=#5mcug6DX(i}a1MvRKP>Yy4)kC#7+O9)$G~BGAR{yB4Uc|X=JmIub*&(U z=$P(_>Fp)mPSS3X-1%K2`45LTzAf`Zm!{j^nSxC6#PqCAI*$05UCmfDNn(epmRi*6 z?od^8qSjs=Dh{WZHCk@kf9czeM`T{^f@s@RVKF_eLq|Jhgtr`#JvHR}M`XH^r;fp{?8dog)KcC|SfUY82DCn%02sEn3X8i}uLkFUtUCsTXz<&&ccnj`6_ zM}xN!tf;N_M}zldc;kFEHB%-Bq6zH1T#%VpY=jyUqlf2APCky%V&(ML7JKyq|KtLd zKYm``$f(UxP#H5dBzxl+r^<XuU z=rkY1n4R)y(8XlcSNN(b%R^DiC_d!|>hQAp@EJzxsZ94e>uRUqql<(uV#4b$stZJe zOPG`L$pPiji^Ok;7?e{lV)%whA_cy%NO*9jonu7URI7>;-BB)rCL z`Fb(RyjkEs5TmTy(0?t2`556fV!ZXb7;C*D%B+22jQJk+FW?ND(CQ*bSsBn9@}$ok zCWYlguZ4O!%DhSn^Cnn|eY4EAcF2C#E}3KU$B5Pm>9M{b%}Mlslm16^{s!1e)J9op zkO{?Fxiv!bnfz6vH9_;3eq=!NSXXP=R#QmpZ~c#!W3`arS48}p1ot5CCBYxa{AYL! zp47_CjX1526Q?<{t$4>ktE(f&%)!4@?C@A6j#0{qWu503WsOCjj9!C24Q9f1j&kcJ zhtFJq{Z5C+ycc;t`9e=o*cwNnwZV~Ny-b1~M7%+Q{m4TkI6~&X!g2V*QEr~beuj9Q zQC6bvvHI%SR-RsH4c2|iA!U`}e5yoFCay{!Wle<{Fk3G-=U~5;^dY^EwLs6Y?$&)F zYbg<{iP%NNULp<>@ulvw;+^GYDo&{kr^oDv9N_d=W1QKR&pFf@@2oVdv0X&mG~`U; zE_aTyu7+!&nfTkV-$DHEk@pe5g1oDo!>zT%ZN&C6aoe2C|4t%zk?9Z|g};*Eb39_1 zc)tqqehtF=HPV%BmAQsmb6h^F1uxkG;(kxueZ)Nge|C+sR=`SlnfTqr9dVVLeOH=Zk)$#2@&yYlzWi(lHd<<%sD&;&tTt*eQ#X3`3~|J z@gHG70sn-P*fqRkUGau_+#WL%*~dM~DgZAGcbA(!;;R7Be24^(5b-pufeplOCG%c*2ady6@FTe6c@={!7zo2)EL?~yt~TCdUW}X> zKg#+!%z=6F<>q|ie*^c!!|@_yt&jJan+O~x@t5eQ(Nl2G6({)2kqN@Q2)z;g2K0N- z2Y2zA=i!o@f~)Q;^dHdEaJ6kt^qJd`yA#Km2axX|KSX|l{3r4h@(eOAX`GpaS1lcx zmBjq_M=8WG3^^KEft-vCAZH-2Kwgc!0oj6Ffcy<|5%Q17N0G~s&m@hrHYSZSx1hh4 zG|GA%_7FZm_)t>0^&#nwqkoG24f<(xSE%baGZ8;s3NjO!jm$$9A%`GKk!8s7$P18l z$Z5z~Nc??P6Y>UR3$hh?2XZ0uKI9VQqsZmRwa5*~SCOwH-$K5F4E-JD1j;wa(@1Bx zab}lpxY&@rka@@=ublh?b=rD z=J~;Yi=5hrUA}awH_+DP9^(8BUH&1PWw`Bxj1S-SiEMU#{q4!`PW_wrwbN4S&wVB* zNZBPk@pCz0NPhR08pUgM3ifG_H6^LCp+LHN-Rm-2VMy8Y zrpN2z>s;-$*uC-*kGIQ(p~~rg{y@IIa{Sn6xf{t=SLuu0dsb4e3SL+l%eU3zO;DET z7rDrFXlHk?TN%|qA&C?exFjXdk=i0e-f$!Gi+%q5rdrGs|50p9WudhK+bV7d&q&U*mt>LkiZraP z7)NNWlDQdpr4v(_S?(~8ZPNxK7f!#=)uS#N25%=Za=K>`2Lyyi*dzp=F;bw`{P z=kQv|NUtN#tmJ7v$uZcR!Y8I_=$AVBm_hU#p_TBj2;YUi5Pk>h6V_v}3|2wx^VKHO zZgvc|_J_F~u4hoqEQQpDuA@T&04{X+Hq~J=B=o(~tkUf!o zkwwTM$a3T)<(Us7A9M9HpFlqA(#_{x zb$m8*Ik|%ju(rE2YbSD-tHj!eJm7M0CvlkXlK2DeGJkcIm>;8m=5mOAZyl^KG$nS` z7DvUz0 zqk=Ex>eNq=ybp^V z@0{tzNYQ?#8>KiD|NO*BscENw;K)8BpExbMYMPGu%yaSDCYSxH8-AsmHdb@FmGy~u zO={D#@Aqhz+i@Fad$d2v`%|>k)Gqv6ptagr{~(G|56LIeG)+rLv`fvlbJL5k_{^h8daK6RG@*yBFmD0-Ofgy8r+H delta 14628 zcma)@3tUuX{_vl3=FBjF;9hzZOQn{e3>c6q#4Exrl~q11b5PVGq@s#~$_Zlzl$MF;e~y77PE_bt ztW0Prs~+f-(8@{`g}$1}6Fg^S=Nhm_79SJRE z)lhq8N8v5YQ?u+l9Exp~krRAMS1(t#Cib{bvufpjH1BNJRlY~hsplk7Ft)m;s=Bu0 z!KYhAj7W<+=cx~zpD?AOZe0Dv9qGhrgW|pxZkIC+bmIJky{f(bfu)@i-XJvbi~XD@ z4&8K4Jy*@zbY9{6j`a<`prq7OSv#gmX6U#>xP-{<$jWWC!xNnnT9!#7w`xprvGvK$dl?Pp;V&qfAEFghOJ78&?-cGOPO zE3Yc&X4hjvg|D-x){a}%d2Z?BD#x7lRG}#1;5mIv9WusNRG#%z1-~cG@e9qmS4j@4 z#C&?*gZfUW_D-mn+VLz+Q*2`NIb)yN`RZ!NbvOy3Imqpm^KvVysjaK3KjWu4$?YX8 zw+!p8x0>T^A?D<%jY3?WG(p^0vaQQ~$|NOp#r;Z7nn(9vp43!o{T*!m9m?O(>id-e zWp^h9M47#zRru^ew2FZ6?rNW|PK^^y{dE7`NktyoRnZ%dHHq>+#fl&MX zO1kpbrxf)|B@>&v8gJiN>0ocDNeD~--Ju?9mEz#tN$bCFZ`Dcyf?RmSn)da#x3{V# zb3W2*x(ojPL9Eq9vsUo2zFlh|qxGkx`}DY}szPkh$ow4PNv&Vn*tpQWXz{Eoe&b%y z+Sn49w_s_4pAj@&4G5CH@R8nv_sXk3(gWB~y(CMkU)t+Tx+TrCJ0+YUAC0?}IJ9f6 zGB4=Sn@V*530GT*-iBVPHx06agY-7^!Fp4f6)e-+(1+?xe;UZsmnr64nzWMmL`vQ)yfk#7?nWQ)u6xl!eOB(5MHMnylMWo7EbJ2&mJY0Wot#SE^C2*Hkd}98Kk+ zjSnhieam^Uw@0*{oLjZ?iZ(P-w4otoy>j0`h9{%u>a=Lijx@4fac(L(inRu-P6Z=E zyVfh?l{Z6)4=IbXCM&YFXO?$etQOi(<7cZRE|ho@oc4*owR=(~HUFl0!O~{;ti=oFyB9B8*f`Xk zkF)hyB>#tYY*32T%8byr8fHI4?TI~sapqtZR8oZ7AAHBKPQ;Y^Eb`)f9I{eSK}^P`7u%V)rcfCH2!L$V{g@ zWgBWF)@Z_jim=m?$*qon7I0ujhk-c3sX@@3i0S`7sWXX(qQ6dfaL(V_)c%$>D(?tkGx+9!JugywH z!$-XPzM--zwg&$Jcc)qN8s^zi<7>JJPeMh@mFG;bRK{8)tmPq~;>(D0&@4?a>G_(N z?x0GonlF!OIJ9N6(r=YPlsY^|Y?3GBRWlj!Xtkq9it0NpiL&-A9_GzGr$S3|+>}mQ z+CMwTmv)Yc26iyWJLMvL^Q8|D*{$bWwU^!FPjyq4JA}^{iF{Mf?-lIG4EKQ3|DP(o8N|t9CFDpE{_P>(79~?#lkC4P)VxK>RmbIp?%1OAQPzZB*rF6o z+U}ap8^J3eXU`g^XxgFsY;qqmRZ{~hRU(^aVf9#eM2+?z&BOgn?DDW7MHP#+NQ%&~ zCzS%_K&atKD>O7+92uos_O)_&O z<3Jh)&0Mi^A#x=%X~?@(DN3PKs+`Ee$%;xwk#T6{RwXn3fZO|Zdq9=N3O$J-c)-2f zdmKx+oSMp8N(-@jixfe=t;}uVK|*!qt0-TsNG)rI%GdjUNx?duWX%UMjr9)8e7%R- zt@N^8we*g<(wd!HF4XXpk{g^AE{AuTluYqfotRcsrWMM3EW4HT%O7XV%BmLWqaTkC zr)YXrA6=8jE+)ESjh*DJ^jFtL4F#|kY=;hQyfZM)@0Os<2;Rs|!4EoBD&6|)>{ zF0P?3kL?sqC^T96t5{@}d0SDhg6US3j%djhqyntlZ5h zvY`j$77I`M*@d1xcYb5@A|@$o!Id+0w3X9BFFwoW;=y)S+%ADcwvYFu$RaT&KcTk!6{2)u{oRRdqGbifsvm9)4O$ z4a%LZOf>PoOr=H#I#Z?97YE#IYu&Q-uFlox$4gvc}B4ZzwOg1H=S&bJI@uoUH^}V^_Dw`@WWi;m!?^>W`!bmt~@o3UC`pT#*Mp~ zUCN?m^BWe-lRd$(vC7dLDH*R|i5wr4%bK$WvpBvu!pl*kHf=CzQV97A@xJCJS&*26fw&+)QR(-)Ke>uWx2YOR+VX z^HJyz+u7HBm+Y6%aL^Fm?bamW>gf1!a$b#-6}LBB_r8AJLG~e5X~@hK&P=epM2n?* zziAh3hjrg>(e%D9$Ff68dqdm%a!+P0m3K!LDpqRto{q9m!SjlKG5yP$CWkNH;o6qS zS4eI#*)ux5@3;HvA}LwMIS|OD(b}0%ZYDg-(@GdJo>y|1VM~0xak5q=O^2 z&8~v-3CcskHai4S%e?~_Cv69r;#sWDEF$V^>3L?XaIB;H!j~;yY}QpZKXMKyGdcR@ za!d~i?`Q3vjNrIh_w2?+i|005n?|d10t+}FpFIRdI<`%o#OGIP)DDh!CF@Ecmb*AyMBh0ME9v!RD6etv|b-a^Tr!3jcS>XND?+K3aZj<{e*Ge}36Dx;LmVl*z>d4V2c} z&Yas3(V`S^%sacuE9xt&tADL5HS7k+bmdGrZo>uh*u2#>{twgIUeZ+#H7pDsTamxW zAH=jnXM?A%<_~5|^(cOP38@}sY*_O+!aG%&$E&)>!N!6sWf|J7d+ZY`D(h-x;7#45 zRn~gPNPUm)QLAP0w!ON?#^NK@*YU2Y7+qx*X1^Zv*e6b^^;gNLoqEBv0*>Y^jRivr zJhsY;I?OUuEkk3Xp*MP2&!~??{yGlJT?}*NN81G*@{75v@B~0%M05` z^eg>5>Nwe@vRqsGc^q|B{z-MwC+8GLJ5)wrRP52@-Xh{X+~bL<_fxKM(N=CL_Bg_p zh)cbP6ui`O{8>5lr!W=%XqP@pP`+pp?{E6kEaNNcqTxX$G@~5+;rM<+;hk?gqW2Rs zXQ-Da3H4gI8$N{VTteLrCxEL<)r2+h9aN_Tg?dklP;W~W>Jhj)jYJUWCb+B;>T?jA zDb&8OwYyMH!QdW3q63H2zPgv5NI=78Eu zs52oL6|~95huJ z-Jl9CgW1pwi(!Q-%yp_}Y((D-Ti|JU9{UH_KSBQ-zJM=P5i};*gfSH^fy-bP%!VtW z3FgB>SOl%G46cD7tbiNg7Wf_f0q%giU^Uza55h)x9Ja!9@PbX4J8X%@>$adU_t-`l z`!ODd@8LhdH!eeiI7rll>CzI7Ok}n;!pOx|1QVbhros$pfB-&C__iQh@omGl0)3U{ zGQZLiP0g;EUF}I`iapWjVHc)5Xdhv$vJ2x=_$T}f7dV7594Z{b9OpsaE z!|wob@5c-?gCE3bW;+Qqr)H+YAgG5Hr)J#f6y|MC)w~b=A@oPlUqIi5{wDfI=wF~8 zNB@O1F|nkF@>r)iGS+5JM86_dHJW3Ec{6e)G8C(to6(;}|135&Xnqr$YR-&HH5=oy z%-iFN%sb=q&HD*|1wGDUpgZ)1 zI@k_Bz-fq26^1)in8m3sgI@v|Ltr?}h2KI5*1`+03*LtPz?5zrhkrmjsAKyfxp7f5Z{ft0D8f6Sl&&T|I;nQ+}2Gq{(`=< zo6X2dr>|iY_@Eh9z~kw{d@r4Gh5R(#X6PBT5LELq+HA_ujH{7PAYa6I1ipYT;cGYz zwoGAUWePJl(`F1n9|U7zBKTnnaW`jbMhN*D^8a8vfu7M_Ge&i%TVXOx>&^h~?lxPx z=b1~p=NiG~7_Wz0;dZzWHo|6j8Qy_Ia1_3Pe?iwCbO#KBi(wipgB5TStb{vZHQWp9 z;8FN9yaapUiyn-XEG=ks%Mxa0mdz;4V!%KdTnaPcw{SD8!)JZgg~k);Tj3ePf6f|a zyoml9yaoHQ9n5kWhtNNQf5R_e&t`yTy9_;B7-^6NgJB4a&8GirQD)$DUAAUikGv_{ zX55K~-WAGjP3)Ea;IKc(!xxD{9QF_AwxDYB}9Qa@|%!B|efF%%w8{zk` z3hskH!6tYTo`aX*4cG^V;A8kJoPZzUG{ojHkn{Rc3Y2W<4aG1R%3&;UmugJT6XxZ4 ziAF~~hDNQZY1lE*mbkyI=2!35`rY5QM3 z@b0c~PJ??`xxVw>zJpcH{&_q1?Tg)WbpL@}W1L6xRw?S??)P?;zm6EA4;06Yo6>XzJD&6wV3aU@{(&72k|BI8yZ_8-+DcC^M}9q%dHUDtT))YC)BN!L zw4cXW*H<`nkq*k*kn%Pke%FRBd|Mfql$u0D8mD!>ti^HBy*BjXex)C=$M-8k6UO}Q ztK(mv_~!55p8W0~|Kyh$rgu0aLjp+aQ^xuYTo&kN8I&}GU)6_ zy!VdM`@E9GA5aFI?Kb{^(ul*;WSTd&-~;8O5dWw)Vm}ntXcU)I_xq1KsnJMt`>6r?LTGpO1Psg z4rRTs6!fy9HMJ;(=%~&WZ&>fhX%4Pk!>J1s!|6|j?tfn?47R1qQK=SXk|wHWchb|( z=(11|mo8^iIg%n)uC}78EKbDQ9^+w?<9LB+aA*<@x>J?)H+mYT#p zkh~_kL%wM$QZ`}uYL3Xz%ZHS775U*IrKgn9aQfl1!;{Vl-*H&k)Y*U92g*a8!2bY^gluN_w!@lDR)7Kz~H10sg( z43An9P1{F0dpqI=5%kqgA#Kol>_`&JaEHT1VTYv~ ze_ABChG1pw1Yab$DZ>*};q^|c_D3A7>7*#Lpg<2cb&1THGn#~)I}79;uDaTz`mDTT zTMGD1m1S|rUlCqz6$xuF$rD3ERgJ5vi#+AlB-(D$gfk(fZ$zKs@+id-{VnvOh<;D9 zC#dv~1iGepY;{%9jv%a#TrYbnPqYWox^VjiBv4ShR@RJ(SJ@&fVN!*cz!_DMUKe5gq z32viXMpyggjaoSVVAvop)xw6POphH8E~dg^Z>E)EYKKAjU1-$DN=mS;eJ1?+|* zu7Eg8s2W#5Kfy_^fx4v&H4i2S`O^UG>D4w^2Z!MpoP?jj$$e2WWCQzqbr6h%i(nGW zgjKKxHo-PH2ua*8dEs|Z#~o8LcTAtLLv9j7j20oxrDBK~{4Igyf*lWrjbfzvxzNnx zVubmPuo)+@{{-<0rznNPt1`qK3`3z(DK{o!y9|9EEL4UVH{y2}?8N@D;x>;ddFEG2 zuJH?Dr|L4})geYQS2k(t5Hk}!pQ{?P4}pPjAzY*mH|y1M<8qv?P+i7+$13F5bs_667huc^b0Ln=2dT*u_t+-8BTkJ;CjYm6j(kouoFNyya`A_11Ag$1bm>R@u!;NlS(R9~bMlWO^u4+bTZnIMBYkIYEV+yuQh-(O< z1c;nVqD8P2t|Rd+*zY01eOivWPRlhP(aO!8*!N)n3i}D{-(gR%mzxFl;YKOYwuAp(8$R8ZT4Sw@%6vGHEkw$ZObWx1koEUR~d0kAo`TH1` z5yHM6xe56M@mpi)bJzjzVE+{RiJ0NWkI0{iZ^!O*4l%nxvU9kRg_G8QA3#SSrVfLq}9*x|;#I6Mqb!HdN2 zk1aQjpr1ldh$}a`#c{xiV^pL2(VNk4MmNznp?l-Yjj3EAGI9p80XYY`5ZQ{n4tWD|CGrmBYUBgR^~gsP zgTma3@*IX8$lb_&$oG(+Be`}nzeoNDY41ABi08U31(}KLh3tzQj4VfvMb;pvATLGE zLvkHw8pxZGcXS;l_P=*LWzQK~NtlII)EfZ2G9MU7i9{lPnibYEKS!UYx{f@YSQc_UxMA{HzBDoJmUjj}CdN z3nq0Fmu-vxtJ123R{Tx5E=D``!@qv~_fPozq-;};D`OQUE;RmYKGyY4Zd;nfPqp~r z){E`#>8jtC>@5_Ytg&;%?Qe_Zm6rr%mW z>y}Ak1UXGtv510uLp#1!W+`ula!)9umENJo6UtSD4xLb@5bFPpa!Fh;scC@q-R|Dd zo!{`2hTTaXZ6bTA$RfQhiH}K@k-$eX5MAs~C-G^gmVW^diA-{_>#OP5ER?!DG1eEZ zjvdq@9LCp9i0(d?yF3m)Q`Jt5ZtK>%JaHEXtETz*HwE=o(LKhWNmW->5e;r8TN%8# zDw=F3$)qLnl`6awIiBosN~8QoH{tU6uSqG$Pi^Cndx0MQi`|`{COlnhY1st<_x#5B z3tEE9te=hZnVsmSrAduD{?Pek!`RWK7!Mb#I~dq7Qu2@3!CB3 zuoL3gvh)TY+zW5Pakz%<3%_eLZ&U`Gw*-|w=1QfXVY0%9Skc#ET(11qA|nmX8wRePG;#C95K zv&EPWTd}Dli)}H+7#8kvwi3f{a3A|}9Vt3Hbc$dfz2!BqZFOlCOzeoOzR9V=&I6Q_6*&W#v zS&STrEJuz;PC(Wp8<2C5S0R@ouSedBT#bAHxe0mUlWZlPCa}%X+t`kL(NSRRK)&M0 zV=JMVpE+#CF~VOuO3kkw{f)n)pK{nj?t7GOp>h9E8qZv=>Al6l124Z)r5B3bZy!9m zd%v7>`$Y8J2VSn!i^OY{df$%uxSyqkZ`1VRaNvUpx~KEh++UozTGLB9&C>(I`a6B) zJ)2(IY1SSXowb>&^}(WJs@5;$`fdM)Q;Mqo=NBgA)5?Y)l|eT-Wna(_9 diff --git a/src/lisp/defun.lisp b/src/lisp/defun.lisp index e210f53..e2896ef 100644 --- a/src/lisp/defun.lisp +++ b/src/lisp/defun.lisp @@ -18,4 +18,7 @@ )) )) )) + (DEFVAL (MACRO (L) + (EVAL (CONS 'CSETQ L)) + )) ) diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla index 3537149..da3ed83 100644 --- a/src/lisp/drawl.pla +++ b/src/lisp/drawl.pla @@ -47,7 +47,23 @@ import sexpr byte stringstr[1] end + const ERR_INTERNAL = -1 + const ERR_OUT_OF_MEM = -2 + const ERR_SWEEP_OVRFLW = -3 + const ERR_SWEEP_UNDFLW = -4 + const ERR_BAD_DOT = -5 + const ERR_NOT_SYM = -6 + const ERR_NOT_ASSOC = -7 + const ERR_NOT_FUN = -8 + const ERR_NOT_NUM = -9 + const ERR_NOT_INT = -10 + const ERR_NOT_FLOAT = -11 + const ERR_NOT_STR = -12 + const ERR_BAD_INDEX = -13 + const ERR_BAD_GO = -14 + var exception + var err_expr var hook_eval byte trace @@ -82,7 +98,7 @@ const FILEBUF_SIZE = 128 var readfn // Read input routine var fileref, filebuf // File read vars byte quit = FALSE // Quit interpreter flag - +var error // // REPL native helper functions @@ -246,7 +262,6 @@ end def refill_file if not read_fileline - puts("File input prematurely ended\n") return refill_keybd fin return filebuf @@ -335,31 +350,34 @@ end // puts("DRAWL (LISP 1.5) v1.0 symbolic processor\n") -sym_fpint = new_sym("FMTFPI") -sym_fpfrac = new_sym("FMTFPF") -sym_fpint=>natv = @natv_fpint -sym_fpfrac=>natv = @natv_fpfrac -sym_fpint=>apval = new_int(fmt_fpint, 0) ^ NULL_HACK -sym_fpfrac=>apval = new_int(fmt_fpfrac, 0) ^ NULL_HACK -new_sym("QUIT")=>natv = @natv_bye -new_sym("GC")=>natv = @natv_gc -new_sym("GR")=>natv = @natv_gr -new_sym("COLOR")=>natv = @natv_color -new_sym("PLOT")=>natv = @natv_plot -new_sym("PRINTER")=>natv = @natv_printer -new_sym("HOME")=>natv = @natv_home -new_sym("GOTOXY")=>natv = @natv_gotoxy -new_sym("KEYPRESSED")=>natv = @natv_keypressed -new_sym("READ")=>natv = @natv_read -new_sym("READKEY")=>natv = @natv_readkey -new_sym("READSTRING")=>natv = @natv_readstring -new_sym("READFILE")=>natv = @natv_readfile +sym_fpint = new_sym("FMTFPI") +sym_fpfrac = new_sym("FMTFPF") +sym_fpint=>natv = @natv_fpint +sym_fpfrac=>natv = @natv_fpfrac +sym_fpint=>apval = new_int(fmt_fpint, 0) ^ NULL_HACK +sym_fpfrac=>apval = new_int(fmt_fpfrac, 0) ^ NULL_HACK +new_sym("QUIT")=>natv = @natv_bye +new_sym("GC")=>natv = @natv_gc +new_sym("GR")=>natv = @natv_gr +new_sym("COLOR")=>natv = @natv_color +new_sym("PLOT")=>natv = @natv_plot +new_sym("PRINTER")=>natv = @natv_printer +new_sym("HOME")=>natv = @natv_home +new_sym("GOTOXY")=>natv = @natv_gotoxy +new_sym("KEYPRESSED?")=>natv = @natv_keypressed +new_sym("READ")=>natv = @natv_read +new_sym("READKEY")=>natv = @natv_readkey +new_sym("READSTRING")=>natv = @natv_readstring +new_sym("READFILE")=>natv = @natv_readfile parse_cmdline hook_eval = @hookfn exception = @break_repl -if except(@break_repl) == -1 - puts("Out of memory!\n") +error = except(@break_repl) +if error + puts("\nError "); puti(error) + if err_expr; putc(':'); print_expr(err_expr); err_expr = NULL; fin + putln fin while not quit putln; print_expr(eval_quote(readfn())) diff --git a/src/lisp/lores.lisp b/src/lisp/lores.lisp index 7c9eb76..4ec1f8d 100644 --- a/src/lisp/lores.lisp +++ b/src/lisp/lores.lisp @@ -18,14 +18,14 @@ ; BEST OPTION FOR GENERIC CASE ; (PLOTSIN (LAMBDA () - (PLOTFUNC (FUNCTION (LAMBDA (S) (SIN (* S PI))))) + (PLOTFUNC (FUNCTION (LAMBDA (S) (SIN (* S *PI*))))) )) ; ; USE QUOTE TO PASS IN LAMBDA EQUATION ; ONLY APPLICABLE IF NO FREE VARIABLES ; (PLOTCOS (LAMBDA () - (PLOTFUNC '(LAMBDA (S) (COS (* S PI)))) + (PLOTFUNC '(LAMBDA (S) (COS (* S *PI*)))) )) ) (GR T) diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index 5ea5eea..00e5648 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -54,12 +54,36 @@ struc t_string byte stringstr[1] end +// +// Errors +// + +const ERR_INTERNAL = -1 +const ERR_OUT_OF_MEM = -2 +const ERR_SWEEP_OVRFLW = -3 +const ERR_SWEEP_UNDFLW = -4 +const ERR_BAD_DOT = -5 +const ERR_NOT_SYM = -6 +const ERR_NOT_ASSOC = -7 +const ERR_NOT_FUN = -8 +const ERR_NOT_NUM = -9 +const ERR_NOT_INT = -10 +const ERR_NOT_FLOAT = -11 +const ERR_NOT_STR = -12 +const ERR_BAD_INDEX = -13 +const ERR_BAD_GO = -14 + +// +// Variables +// + byte prhex = FALSE // Hex output flag for integers const fmt_fp = FPSTR_FIXED|FPSTR_STRIP|FPSTR_FLEX export var fmt_fpint = 6 export var fmt_fpfrac = 4 export byte trace = FALSE export var exception = NULL +export var err_expr = NULL export var hook_eval = NULL // Installable hook for eval_expr() var assoc_list = NULL // SYM->value association list var cons_list = NULL @@ -165,8 +189,7 @@ end def push_sweep_stack(expr)#1 if sweep_stack_top == SWEEPSTACK_MAX - 1 - puts("Sweep stack overflow\n") - return NULL + throw(exception, ERR_SWEEP_OVRFLW) fin sweep_stack[sweep_stack_top] = expr sweep_stack_top++ @@ -175,8 +198,7 @@ end def pop_sweep_stack#1 if sweep_stack_top == 0 - puts("Sweep stack underflow\n") - return NULL + throw(exception, ERR_SWEEP_UNDFLW) fin sweep_stack_top-- return sweep_stack[sweep_stack_top] @@ -227,6 +249,16 @@ end // Build ATOMS // +def new(size) + var memptr + + memptr = heapalloc(size) + if !memptr + throw(exception, ERR_OUT_OF_MEM) + fin + return memptr +end + export def new_cons#1 var consptr @@ -235,8 +267,7 @@ export def new_cons#1 cons_free = cons_free=>link else gc_pull++ - consptr = heapalloc(t_cons) - if !consptr; throw(exception, -1); fin + consptr = new(t_cons) fin consptr=>link = cons_list cons_list = consptr @@ -254,8 +285,7 @@ export def new_int(intlo, inthi)#1 int_free = int_free=>link else gc_pull++ - intptr = heapalloc(t_numint) - if !intptr; throw(exception, -1); fin + intptr = new(t_numint) fin intptr=>link = int_list int_list = intptr @@ -273,8 +303,7 @@ export def new_float(extptr)#1 float_free = float_free=>link else gc_pull++ - floatptr = heapalloc(t_numfloat) - if !floatptr; throw(exception, -1); fin + floatptr = new(t_numfloat) fin floatptr=>link = float_list float_list = floatptr @@ -302,15 +331,10 @@ def new_array(dim0, dim1, dim2, dim3) else ofst0 = 2 fin - size = dim0 * ofst0 - memptr = heapalloc(size) - if not memptr - puts("Array too large!\n") - return NULL - fin + size = dim0 * ofst0 + memptr = new(size) memset(memptr, NULL, size) - aptr = heapalloc(t_array) - if !aptr; throw(exception, -1); fin + aptr = new(t_array) aptr=>link = NULL aptr->type = ARRAY_TYPE aptr=>dimension[0] = dim0 @@ -371,8 +395,7 @@ export def new_string(strptr)#1 fin if !stringptr // Nothing free gc_pull++ - stringptr = heapalloc(t_string + alloclen) - if !stringptr; throw(exception, -1); fin + stringptr = new(t_string + alloclen) fin stringptr=>link = string_list string_list = stringptr @@ -409,8 +432,7 @@ export def new_sym(symstr)#1 index = (^symstr ^ ((^(symstr+1) << 1) ^ ^(symstr+1 + ^symstr / 2) << 2)) & HASH_MASK symptr = match_sym(symstr, hashtbl[index]) if symptr; return symptr; fin // Return already existing symbol - symptr = heapalloc(t_sym + ^symstr) - if !symptr; throw(exception, -1); fin + symptr = new(t_sym + ^symstr) symptr=>link = hashtbl[index] hashtbl[index] = symptr symptr->type = ^symstr | SYM_TYPE @@ -495,7 +517,8 @@ def print_atom(atom)#0 puts(atom + stringstr) break otherwise - puts("Unknown atom type: $"); putb(atom->type); putln + err_expr = atom + throw(exception, ERR_INTERNAL) wend fin end @@ -688,8 +711,8 @@ export def parse_expr(evalptr, level, refill)#2 // return evalptr, exprptr // Add expression to CDR // if not (consptr and consptr=>car) - puts("Invalid . operator\n") - return evalptr, exprptr + err_expr = consptr + throw(exception, ERR_BAD_DOT) fin consptr=>cdr = elemptr elemptr = NULL @@ -719,8 +742,8 @@ export def parse_expr(evalptr, level, refill)#2 // return evalptr, exprptr exprptr = consptr else if consptr=>cdr - puts("Improperly formed .\n") - return evalptr, exprptr + err_expr = consptr + throw(exception, ERR_BAD_DOT) fin consptr=>cdr = new_cons consptr = consptr=>cdr @@ -742,8 +765,8 @@ def new_assoc(symptr, valptr)#0 var pair, pairlist if symptr and (symptr->type & TYPE_MASK <> SYM_TYPE) - puts("NEW ASSOC: Not a SYM\n") - return + err_expr = symptr + throw(exception, ERR_NOT_SYM) fin pair = new_cons pair=>car = symptr @@ -783,7 +806,8 @@ def set_assoc(symptr, valptr)#1 if pair pair=>cdr = valptr // Update association else - puts("Unknown association: "); print_expr(symptr); putln + err_expr = symptr + throw(exception, ERR_NOT_ASSOC) fin return pair end @@ -820,8 +844,8 @@ def eval_args(argvals) sweep_stack[sweep_stack_top] = eval_expr(argvals=>car) sweep_stack_top++ if sweep_stack_top >= SWEEPSTACK_MAX - puts("Arg overflow\n") - return NULL + err_expr = argvals + throw(exception, ERR_SWEEP_OVRFLW) fin argvals = argvals=>cdr loop @@ -948,8 +972,8 @@ export def eval_expr(expr)#1 else // Associated symbol func = eval_atom(func) if !func or func->type <> CONS_TYPE - puts("Non-function EVAL:"); print_expr(expr); putln - expr = NULL + err_expr = expr + throw(exception, ERR_NOT_FUN) fin fin else @@ -976,8 +1000,8 @@ export def eval_expr(expr)#1 curl = NULL expr = func=>cdr=>cdr=>car else - puts("Non-LAMBDA EVAL:"); print_expr(expr); putln - expr = NULL + err_expr = expr + throw(exception, ERR_NOT_FUN) fin if trace puts("\nTRACE:"); print_expr(func) @@ -1170,8 +1194,8 @@ def natv_function(symptr, expr) 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 + err_expr = expr + throw(exception, ERR_NOT_FUN) fin fin fin @@ -1209,6 +1233,72 @@ def natv_define(symptr, expr) return deflist end +def natv_cset(symptr, expr) + symptr = eval_expr(expr=>car) + if symptr->type & TYPE_MASK <> SYM_TYPE + err_expr = symptr + throw(exception, ERR_NOT_SYM) + fin + expr = eval_expr(expr=>cdr=>car) + symptr=>apval = expr ^ NULL_HACK + return expr +end + +def natv_csetq(symptr, expr) + symptr = expr=>car + if symptr->type & TYPE_MASK <> SYM_TYPE + err_expr = symptr + throw(exception, ERR_NOT_SYM) + fin + expr = eval_expr(expr=>cdr=>car) + symptr=>apval = expr ^ NULL_HACK + return expr +end + +def natv_prhex(symptr, expr) + if expr + prhex = eval_expr(expr=>car) ?? TRUE :: FALSE + fin + return bool_pred(prhex) +end + +def natv_prin(symptr, expr) + var result + + result = NULL + while expr + result = eval_expr(expr=>car) + print_expr(result) + expr = expr=>cdr + loop + return result +end + +def natv_print(symptr, expr) + expr = natv_prin(symptr, expr) + putln + return expr +end + +def natv_eval(symptr, expr) + return eval_expr(eval_expr(expr=>car)) +end + +def natv_trace(symptr, expr) + if expr + trace = eval_expr(expr=>car) ?? TRUE :: FALSE + fin + return bool_pred(trace) +end + +def natv_copy(symptr, expr) + return copy_expr(expr=>car) +end + +// +// Arrays +// + def eval_index(arrayptr, expr) var idx[4], i, ii, index @@ -1216,8 +1306,8 @@ def eval_index(arrayptr, expr) while expr and ii < 4 index = eval_expr(expr=>car) if index->type <> NUM_INT or isuge(index=>intval, arrayptr=>dimension[ii]) - puts("Invalid array index: "); print_expr(expr=>car); putln - return NULL + err_expr = expr + throw(exception, ERR_BAD_INDEX) fin idx[ii] = index=>intval expr = expr=>cdr @@ -1264,8 +1354,8 @@ def natv_array(symptr, expr) while idx_expr and ii < 4 index = eval_expr(idx_expr=>car) if index->type <> NUM_INT - puts("Invalid array dimension\n"); print_expr(idx_expr=>car); putln - return NULL + err_expr = index + throw(exception, ERR_BAD_INDEX) fin idx[ii] = index=>intval idx_expr = idx_expr=>cdr @@ -1282,80 +1372,144 @@ def natv_array(symptr, expr) return arraylist end -def natv_cset(symptr, expr) - symptr = eval_expr(expr=>car) - if symptr->type & TYPE_MASK <> SYM_TYPE - puts("CSET: Not a SYM\n") +// +// Strings language extension +// + +def natv_string(symptr, expr) + expr = eval_expr(expr=>car) + if not expr; return NULL; fin + ^tempstr = 0 + when expr->type & TYPE_MASK + is NUM_TYPE + when expr->type + is NUM_INT + i32tos(expr + intval, tempstr) + break + is NUM_FLOAT + ext2str(expr + floatval, tempstr, fmt_fpint, fmt_fpfrac, fmt_fp) + if ^(tempstr + 1) == ' ' // Remove leading space + memcpy (tempstr + 1, tempstr + 2, ^tempstr) + ^tempstr-- + fin + break + wend + break + is SYM_TYPE + ^tempstr = expr->type & SYM_LEN + memcpy(tempstr + 1, expr + name, ^tempstr) + break; + is ARRAY_TYPE + ^tempstr = 2 + ^(tempstr + 1) = '[' + ^(tempstr + 2) = ']' + break; + wend + return new_string(tempstr) +end + +def natv_stringp(symptr, expr) + return bool_pred(eval_expr(expr=>car)->type == STRING_TYPE) +end + +def natv_subs(symptr, expr) + var stringptr + byte ofst, len + + stringptr = eval_expr(expr=>car) + if stringptr->type <> STRING_TYPE + err_expr = stringptr + throw(exception, ERR_NOT_STR) + fin + symptr = eval_expr(expr=>cdr=>car) + if symptr->type <> NUM_INT + err_expr = symptr + throw(exception, ERR_NOT_INT) + fin + ofst = symptr=>intval[0] + symptr = eval_expr(expr=>cdr=>cdr=>car) + if symptr->type <> NUM_INT + err_expr = symptr + throw(exception, ERR_NOT_INT) + fin + len = symptr=>intval[0] + if ofst > stringptr->stringstr return NULL fin - expr = eval_expr(expr=>cdr=>car) - symptr=>apval = expr ^ NULL_HACK - return expr -end - -def natv_csetq(symptr, expr) - symptr = expr=>car - if symptr->type & TYPE_MASK <> SYM_TYPE - puts("CSETQ: Not a SYM\n") - return NULL + if ofst + len > stringptr->stringstr + len = stringptr->stringstr - ofst fin - expr = eval_expr(expr=>cdr=>car) - symptr=>apval = expr ^ NULL_HACK - return expr + memcpy(tempstr + 1, stringptr + stringstr + ofst + 1, len) + ^tempstr = len + return new_string(tempstr) end +def natv_cats(symptr, expr) + var len, stringptr -def natv_prhex(symptr, expr) - if expr - prhex = eval_expr(expr=>car) ?? TRUE :: FALSE - fin - return bool_pred(prhex) -end - -def natv_prin(symptr, expr) - var result - - result = NULL + len = 0 while expr - result = eval_expr(expr=>car) - print_expr(result) + stringptr = eval_expr(expr=>car) + if stringptr->type == STRING_TYPE + if len + stringptr->stringstr < 255 + memcpy(tempstr + len + 1, stringptr + stringstr + 1, stringptr->stringstr) + len = len + stringptr->stringstr + fin + fin expr = expr=>cdr loop - return result + ^tempstr = len + return new_string(tempstr) end -def natv_print(symptr, expr) - expr = natv_prin(symptr, expr) - putln - return expr -end - -def natv_eval(symptr, expr) - return eval_expr(eval_expr(expr=>car)) -end - -def natv_trace(symptr, expr) - if expr - trace = eval_expr(expr=>car) ?? TRUE :: FALSE +def natv_lens(symptr, expr) + symptr = eval_expr(expr=>car) + if symptr->type <> STRING_TYPE + err_expr = symptr + throw(exception, ERR_NOT_STR) fin - return bool_pred(trace) + return new_int(symptr->stringstr, 0) end +def natv_chars(symptr, expr) + symptr = eval_expr(expr=>car) + if symptr->type <> NUM_INT + err_expr = symptr + throw(exception, ERR_NOT_INT) + fin + tempstr->[0] = 1 + tempstr->[1] = symptr=>intval[0] + return new_string(tempstr) +end + +def natv_ascii(symptr, expr) + symptr = eval_expr(expr=>car) + if symptr->type <> STRING_TYPE + err_expr = symptr + throw(exception, ERR_NOT_STR) + fin + return new_int(symptr->stringstr ?? symptr->stringstr[1] :: 0, 0) +end + +// +// FOR(...) loop language extension +// + def natv_for(symptr, expr) var index, ufunc, dlist word[2] idxval, stepval index = expr=>car if index->type & TYPE_MASK <> SYM_TYPE - puts("For index not symbol\n") - return NULL + err_expr = index + throw(exception, ERR_NOT_SYM) fin expr = expr=>cdr symptr = eval_expr(expr=>car) expr = expr=>cdr if symptr->type <> NUM_INT - puts("FOR initial not integer\n") - return NULL + err_expr = symptr + throw(exception, ERR_NOT_INT) fin idxval[0] = symptr=>intval[0] idxval[1] = symptr=>intval[1] @@ -1363,8 +1517,8 @@ def natv_for(symptr, expr) symptr = eval_expr(expr=>car) expr = expr=>cdr if symptr->type <> NUM_INT - puts("FOR step not integer\n") - return NULL + err_expr = symptr + throw(exception, ERR_NOT_INT) fin stepval[0] = symptr=>intval[0] stepval[1] = symptr=>intval[1] @@ -1391,12 +1545,8 @@ def natv_for(symptr, expr) return pop_sweep_stack end -def natv_copy(symptr, expr) - return copy_expr(expr=>car) -end - // -// (PROG ...) language extension +// PROG(...) language extension // def natv_prog(symptr, expr) @@ -1461,135 +1611,17 @@ def natv_go(symptr, expr) fin symptr = symptr=>cdr loop - puts("GO destination not found:"); print_expr(expr); putln + err_expr = expr + throw(exception, ERR_BAD_GO) return NULL end def natv_set(symptr, expr) - symptr = eval_expr(expr=>car) - expr = set_assoc(symptr, eval_expr(expr=>cdr=>car)) - return expr ?? expr=>cdr :: NULL + return set_assoc(eval_expr(expr=>car), eval_expr(expr=>cdr=>car))=>cdr end def natv_setq(symptr, expr) - symptr = expr=>car - expr = set_assoc(symptr, eval_expr(expr=>cdr=>car)) - return expr ?? expr=>cdr :: NULL -end - -def natv_string(symptr, expr) - expr = eval_expr(expr=>car) - if not expr; return NULL; fin - ^tempstr = 0 - when expr->type & TYPE_MASK - is NUM_TYPE - when expr->type - is NUM_INT - i32tos(expr + intval, tempstr) - break - is NUM_FLOAT - ext2str(expr + floatval, tempstr, fmt_fpint, fmt_fpfrac, fmt_fp) - if ^(tempstr + 1) == ' ' // Remove leading space - memcpy (tempstr + 1, tempstr + 2, ^tempstr) - ^tempstr-- - fin - break - wend - break - is SYM_TYPE - ^tempstr = expr->type & SYM_LEN - memcpy(tempstr + 1, expr + name, ^tempstr) - break; - is ARRAY_TYPE - ^tempstr = 2 - ^(tempstr + 1) = '[' - ^(tempstr + 2) = ']' - break; - wend - return new_string(tempstr) -end - -def natv_stringp(symptr, expr) - return bool_pred(eval_expr(expr=>car)->type == STRING_TYPE) -end - -def natv_subs(symptr, expr) - var stringptr - byte ofst, len - - stringptr = eval_expr(expr=>car) - if stringptr->type <> STRING_TYPE - puts("Not string in subs:"); print_expr(expr); putln - return NULL - fin - symptr = eval_expr(expr=>cdr=>car) - if symptr->type <> NUM_INT - puts("SUBS offset not integer\n") - return NULL - fin - ofst = symptr=>intval[0] - symptr = eval_expr(expr=>cdr=>cdr=>car) - if symptr->type <> NUM_INT - puts("SUBS len not integer\n") - return NULL - fin - len = symptr=>intval[0] - if ofst > stringptr->stringstr - return NULL - fin - if ofst + len > stringptr->stringstr - len = stringptr->stringstr - ofst - fin - memcpy(tempstr + 1, stringptr + stringstr + ofst + 1, len) - ^tempstr = len - return new_string(tempstr) -end - -def natv_cats(symptr, expr) - var len, stringptr - - len = 0 - while expr - stringptr = eval_expr(expr=>car) - if stringptr->type == STRING_TYPE - if len + stringptr->stringstr < 255 - memcpy(tempstr + len + 1, stringptr + stringstr + 1, stringptr->stringstr) - len = len + stringptr->stringstr - fin - fin - expr = expr=>cdr - loop - ^tempstr = len - return new_string(tempstr) -end - -def natv_lens(symptr, expr) - symptr = eval_expr(expr=>car) - if symptr->type <> STRING_TYPE - puts("Not string in LENS:"); print_expr(expr); putln - return NULL - fin - return new_int(symptr->stringstr, 0) -end - -def natv_chars(symptr, expr) - symptr = eval_expr(expr=>car) - if symptr->type <> NUM_INT - puts("CHRS not integer\n") - return NULL - fin - tempstr->[0] = 1 - tempstr->[1] = symptr=>intval[0] - return new_string(tempstr) -end - -def natv_ascii(symptr, expr) - symptr = eval_expr(expr=>car) - if symptr->type <> STRING_TYPE - puts("Not string in ASCII:"); print_expr(expr); putln - return NULL - fin - return new_int(symptr->stringstr ?? symptr->stringstr[1] :: 0, 0) + return set_assoc(expr=>car, eval_expr(expr=>cdr=>car))=>cdr end // @@ -1617,7 +1649,7 @@ new_sym("CONS")=>natv = @natv_cons new_sym("LIST")=>natv = @natv_list new_sym("ATOM")=>natv = @natv_atom new_sym("EQ")=>natv = @natv_eq -new_sym("NUMBERP")=>natv = @natv_numberp +new_sym("NUMBER?")=>natv = @natv_numberp new_sym("NUMBER")=>natv = @natv_number new_sym("NOT")=>natv = @natv_null new_sym("AND")=>natv = @natv_and @@ -1628,6 +1660,7 @@ new_sym("DEFINE")=>natv = @natv_define new_sym("ARRAY")=>natv = @natv_array new_sym("CSET")=>natv = @natv_cset new_sym("CSETQ")=>natv = @natv_csetq +new_sym(":=")=>natv = @natv_csetq new_sym("PRHEX")=>natv = @natv_prhex new_sym("PRIN")=>natv = @natv_prin new_sym("PRINT")=>natv = @natv_print @@ -1640,7 +1673,8 @@ new_sym("GO")=>natv = @natv_go new_sym("RETURN")=>natv = @natv_return new_sym("SET")=>natv = @natv_set new_sym("SETQ")=>natv = @natv_setq -new_sym("STRINGP")=>natv = @natv_stringp +new_sym("=")=>natv = @natv_setq +new_sym("STRING?")=>natv = @natv_stringp new_sym("STRING")=>natv = @natv_string new_sym("SUBS")=>natv = @natv_subs new_sym("CATS")=>natv = @natv_cats diff --git a/src/lisp/s-math.pla b/src/lisp/s-math.pla index f0b30e9..e1feb35 100644 --- a/src/lisp/s-math.pla +++ b/src/lisp/s-math.pla @@ -1,6 +1,7 @@ include "inc/cmdsys.plh" include "inc/int32.plh" include "inc/sane.plh" +include "inc/longjmp.plh" import sexpr const TYPE_MASK = $70 @@ -44,6 +45,24 @@ import sexpr res floatval[10] end + const ERR_INTERNAL = -1 + const ERR_OUT_OF_MEM = -2 + const ERR_SWEEP_OVRFLW = -3 + const ERR_SWEEP_UNDFLW = -4 + const ERR_BAD_DOT = -5 + const ERR_NOT_SYM = -6 + const ERR_NOT_ASSOC = -7 + const ERR_NOT_FUN = -8 + const ERR_NOT_NUM = -9 + const ERR_NOT_INT = -10 + const ERR_NOT_FLOAT = -11 + const ERR_NOT_STR = -12 + const ERR_BAD_INDEX = -13 + const ERR_BAD_GO = -14 + + var exception + var err_expr + predef new_sym(symstr)#1 predef new_int(intlo, inthi)#1 predef new_float(extptr)#1 @@ -92,11 +111,11 @@ def eval_num(expr) var result result = eval_expr(expr=>car) - if result and result->type & TYPE_MASK == NUM_TYPE - return result + if !result or result->type & TYPE_MASK <> NUM_TYPE + err_expr = expr + throw(exception, ERR_NOT_NUM) fin - puts("Evaluated not an number type: "); print_expr(expr=>car); putln - return @nan + return result end def eval_ext(expr) @@ -777,8 +796,8 @@ end // sane:initFP() -new_sym("PI")=>apval = new_float(@ext_pi) ^ NULL_HACK -new_sym("MATH_E")=>apval = new_float(@ext_e) ^ NULL_HACK +new_sym("*PI*")=>apval = new_float(@ext_pi) ^ NULL_HACK +new_sym("*E*")=>apval = new_float(@ext_e) ^ NULL_HACK new_sym("INTEGER")=>natv = @natv_integer new_sym("SUM")=>natv = @natv_sum new_sym("+")=>natv = @natv_sum @@ -793,7 +812,7 @@ new_sym("<")=>natv = @natv_lt new_sym("MIN")=>natv = @natv_min new_sym("MAX")=>natv = @natv_max new_sym("LOGB")=>natv = @natv_logb -new_sym("SCALEB_I")=>natv = @natv_scalebI +new_sym("SCALEB")=>natv = @natv_scalebI new_sym("TRUNCATE")=>natv = @natv_trunc new_sym("ROUND")=>natv = @natv_round new_sym("SQRT")=>natv = @natv_sqrt @@ -804,5 +823,12 @@ new_sym("BITXOR")=>natv = @natv_bitxor new_sym("ARITHSHIFT")=>natv = @natv_arithshift new_sym("LOGICSHIFT")=>natv = @natv_logicshift new_sym("ROTATE")=>natv = @natv_rotate +new_sym("~")=>natv = @natv_bitnot +new_sym("&")=>natv = @natv_bitand +new_sym("|")=>natv = @natv_bitor +new_sym("^")=>natv = @natv_bitxor +new_sym("<<-")=>natv = @natv_arithshift +new_sym("<<")=>natv = @natv_logicshift +new_sym("<<<")=>natv = @natv_rotate return modkeep | modinitkeep done